packages feed

ideas 0.6 → 0.7

raw patch · 180 files changed

+11604/−7617 lines, 180 filesdep +uniplate

Dependencies added: uniplate

Files

ideas.cabal view
@@ -1,7 +1,7 @@ name:                   ideas-version:                0.6+version:                0.7 synopsis:               Feedback services for intelligent tutoring systems-homepage:               http://ideas.cs.uu.nl/+homepage:               http://ideas.cs.uu.nl/www/ description:    ideas provides feedback services to intelligent tutoring systems such as @@ -18,47 +18,54 @@ extra-source-files:     CREDITS.txt build-type:             Simple cabal-version:          >= 1.8.0.2-tested-with:            GHC == 6.12.1+tested-with:            GHC == 6.10.1, GHC == 6.12.1  --------------------------------------------------------------------------------  Executable              ideas   Main-is: Main.hs-  ghc-options: -W -fwarn-tabs -fwarn-duplicate-exports+  ghc-options: -Wall   hs-source-dirs: src-  other-modules:        -    Common.Apply+  other-modules:+    Common.Classes     Common.Context     Common.Derivation     Common.Exercise+    Common.Id+    Common.Library     Common.Navigator     Common.Rewriting.AC+    Common.Rewriting.Axioms+    Common.Rewriting.Confluence     Common.Rewriting.Difference-    Common.Rewriting.MetaVar+    Common.Rewriting.Group+    Common.Rewriting.Operator     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.Parsing     Common.Strategy.Prefix     Common.Strategy+    Common.StringRef+    Common.TestSuite     Common.Transformation-    Common.Traversable     Common.Uniplate     Common.Utils     Common.View     Documentation.DefaultPage+    Documentation.DerivationUnitTests     Documentation.ExercisePage-    Documentation.LatexRules     Documentation.Make     Documentation.OverviewPages+    Documentation.RulePage+    Documentation.RulePresenter     Documentation.SelfCheck     Documentation.ServicePage     Documentation.TestsPage@@ -72,18 +79,20 @@     Domain.LinearAlgebra.MatrixRules     Domain.LinearAlgebra.Parser     Domain.LinearAlgebra.Strategies-    Domain.LinearAlgebra.Symbols     Domain.LinearAlgebra.Vector     Domain.LinearAlgebra     Domain.Logic.BuggyRules+    Domain.Logic.Examples     Domain.Logic.Exercises     Domain.Logic.FeedbackText     Domain.Logic.Formula     Domain.Logic.GeneralizedRules     Domain.Logic.Generator     Domain.Logic.Parser+    Domain.Logic.Proofs     Domain.Logic.Rules     Domain.Logic.Strategies+    Domain.Logic.Views     Domain.Logic     Domain.Math.Approximation     Domain.Math.Clipboard@@ -93,17 +102,20 @@     Domain.Math.Data.PrimeFactors     Domain.Math.Data.Relation     Domain.Math.Data.SquareRoot-    Domain.Math.DerivativeExercise-    Domain.Math.DerivativeRules+    Domain.Math.Derivative.Exercises+    Domain.Math.Derivative.Rules+    Domain.Math.Derivative.Strategies+    Domain.Math.Equation.BalanceRules     Domain.Math.Equation.CoverUpExercise     Domain.Math.Equation.CoverUpRules     Domain.Math.Equation.Views     Domain.Math.Examples.DWO1     Domain.Math.Examples.DWO2     Domain.Math.Examples.DWO3+    Domain.Math.Examples.DWO4+    Domain.Math.Examples.DWO5     Domain.Math.Expr.Data     Domain.Math.Expr.Parser-    Domain.Math.Expr.Symbolic     Domain.Math.Expr.Symbols     Domain.Math.Expr.Views     Domain.Math.Expr@@ -120,23 +132,27 @@     Domain.Math.Polynomial.Exercises     Domain.Math.Polynomial.Generators     Domain.Math.Polynomial.IneqExercises+    Domain.Math.Polynomial.LeastCommonMultiple+    Domain.Math.Polynomial.RationalExercises+    Domain.Math.Polynomial.RationalRules     Domain.Math.Polynomial.Rules     Domain.Math.Polynomial.Strategies     Domain.Math.Polynomial.Tests     Domain.Math.Polynomial.Views+    Domain.Math.Power.Equation.Exercises+    Domain.Math.Power.Equation.NormViews+    Domain.Math.Power.Equation.Rules+    Domain.Math.Power.Equation.Strategies     Domain.Math.Power.Exercises+    Domain.Math.Power.NormViews+    Domain.Math.Power.OldViews     Domain.Math.Power.Rules     Domain.Math.Power.Strategies+    Domain.Math.Power.Utils     Domain.Math.Power.Views     Domain.Math.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@@ -144,13 +160,15 @@     Domain.RelationAlgebra.Rules     Domain.RelationAlgebra.Strategies     Domain.RelationAlgebra-    Main.ExerciseList+    Main.IDEAS     Main.LoggingDatabase     Main.Options     Main.Revision     Main+    Service.BasicServices     Service.Diagnose     Service.DomainReasoner+    Service.Evaluator     Service.ExercisePackage     Service.FeedbackText     Service.ModeJSON@@ -159,9 +177,9 @@     Service.Request     Service.RulesInfo     Service.ServiceList+    Service.State     Service.StrategyInfo     Service.Submit-    Service.TypedAbstractService     Service.TypedExample     Service.Types     Text.HTML@@ -181,6 +199,7 @@     Text.OpenMath.MakeSymbols     Text.OpenMath.Object     Text.OpenMath.Symbol+    Text.OpenMath.Tests     Text.Parsing     Text.Scanning     Text.UTF8@@ -202,7 +221,8 @@                         uulib,                         filepath,                         parsec,-                        old-time+                        old-time,+                        uniplate  --------------------------------------------------------------------------------
− src/Common/Apply.hs 
@@ -1,57 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)------ This module defines the type class Apply and some related utility functions.----------------------------------------------------------------------------------module Common.Apply where--import Common.Utils  (safeHead)-import Control.Monad (join)-import Data.Maybe    (isJust, fromMaybe)----- | A type class for functors that can be applied to a value. Transformation, Rule, and--- Strategy are all instances of this type class. Minimal complete definition: only one of--- the two member functions should be defined.-class Apply t where-   apply    :: t a -> a -> Maybe a     -- ^ Returns zero or one results-   applyAll :: t a -> a -> [a]         -- ^ Returns zero or more results-   -- default definitions-   apply    ta = safeHead . applyAll ta-   applyAll ta = maybe [] return . apply ta---- | Checks whether the functor is applicable (at least one result)-applicable :: Apply t => t a -> a -> Bool-applicable ta = isJust . apply ta---- | If not applicable, return the current value (as default)-applyD :: Apply t => t a -> a -> a-applyD ta a = fromMaybe a (apply ta a)---- | Same as apply, except that the result (at most one) is returned in some monad-applyM :: (Apply t, Monad m) => t a -> a -> m a-applyM ta = maybe (fail "applyM") return . apply ta- --- | Apply a list of steps, and return at most one result-applyList :: Apply t => [t a] -> a -> Maybe a-applyList xs a = foldl (\ma t -> join $ fmap (apply t) ma) (Just a) xs---- | Apply a list of steps, and return all results-applyListAll :: Apply t => [t a] -> a -> [a]-applyListAll xs a = foldl (\ma t -> concatMap (applyAll t) ma) [a] xs---- | Apply a list of steps, and if there is no result, return the current value (as default)-applyListD :: Apply t => [t a] -> a -> a-applyListD xs a = foldl (\a t -> applyD t a) a xs---- Apply a list of steps, and return the result (at most one) in some monad-applyListM :: (Apply t, Monad m) => [t a] -> a -> m a-applyListM xs a = foldl (\ma t -> ma >>= applyM t) (return a) xs
+ src/Common/Classes.hs view
@@ -0,0 +1,112 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Type classes and instances.+--+-----------------------------------------------------------------------------+module Common.Classes +   ( Apply(..), applicable, applyD, applyM+   , Switch(..), Crush(..), Zip(..)+   ) where++import Common.Utils (safeHead)+import Data.Maybe+import Control.Monad.Identity+import qualified Data.IntMap as IM +import qualified Data.Map as M++-----------------------------------------------------------+-- * Type class |Apply|++-- | A type class for functors that can be applied to a value. Transformation, Rule, and+-- Strategy are all instances of this type class. Minimal complete definition: only one of+-- the two member functions should be defined.+class Apply t where+   apply    :: t a -> a -> Maybe a     -- ^ Returns zero or one results+   applyAll :: t a -> a -> [a]         -- ^ Returns zero or more results+   -- default definitions+   apply    ta = safeHead . applyAll ta+   applyAll ta = maybe [] return . apply ta++-- | Checks whether the functor is applicable (at least one result)+applicable :: Apply t => t a -> a -> Bool+applicable ta = isJust . apply ta++-- | If not applicable, return the current value (as default)+applyD :: Apply t => t a -> a -> a+applyD ta a = fromMaybe a (apply ta a)++-- | Same as apply, except that the result (at most one) is returned in some monad+applyM :: (Apply t, Monad m) => t a -> a -> m a+applyM ta = maybe (fail "applyM") return . apply ta++-----------------------------------------------------------+-- * Type class |Switch|++class Functor f => Switch f where+   switch :: Monad m => f (m a) -> m (f a)+         +instance Switch [] where+   switch = sequence++instance Switch Maybe where+   switch = maybe (return Nothing) (liftM Just)++instance Switch Identity where+   switch (Identity m) = liftM Identity m++instance Eq a => Switch (M.Map a) where+   switch m = do+      let (ns, ms) = unzip (M.toList m)+      as <- sequence ms +      return $ M.fromAscList $ zip ns as++instance Switch IM.IntMap where+   switch m = do+      let (ns, ms) = unzip (IM.toList m)+      as <- sequence ms +      return $ IM.fromAscList $ zip ns as++-----------------------------------------------------------+-- * Type class |Crush|++class Functor f => Crush f where+   crush :: f a -> [a]++instance Crush [] where+   crush = id++instance Crush Maybe where+   crush = maybe [] return++instance Crush Identity where+   crush = return . runIdentity++instance Crush (M.Map a) where+   crush = M.elems++instance Crush IM.IntMap where+   crush = IM.elems++-----------------------------------------------------------+-- * Type class |Zip|+   +class Functor f => Zip f where+   fzip     :: f a -> f b -> f (a, b)+   fzipWith :: (a -> b -> c) -> f a -> f b -> f c+   -- default implementation+   fzip = fzipWith (,)+   fzipWith f a b = fmap (uncurry f) (fzip a b)++instance Zip [] where+   fzipWith = zipWith++instance Zip Maybe where+   fzipWith = liftM2
src/Common/Context.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XDeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -22,17 +22,17 @@      -- * Variables    , Var, newVar, makeVar      -- * Lifting-   , liftToContext, liftTransContext, contextView+   , liftToContext, liftTransContext+   , use, useC, termNavigator, applyTop      -- * Context Monad-   , ContextMonad, runCM, readVar, writeVar, modifyVar-   , maybeCM, withCM, evalCM -- , listCM, runListCM, withListCM+   , ContextMonad, readVar, writeVar, modifyVar+   , maybeCM, withCM, evalCM    ) where   import Common.Navigator--import qualified Common.Navigator as Navigator+import Common.Rewriting import Common.Transformation-import Common.Utils (safeHead, commaList, readM)+import Common.Utils (commaList, readM) import Common.View import Control.Monad import Data.Maybe@@ -65,7 +65,7 @@    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+   location  (C _   a) = location a    changeM f (C env a) = liftM (C env) (changeM f a)  instance TypedNavigator Context where@@ -155,46 +155,65 @@  -- | Lift a rule to operate on a term in a context liftToContext :: Rule a -> Rule (Context a)-liftToContext = liftRuleIn thisView+liftToContext = liftRuleIn contextView  liftTransContext :: Transformation a -> Transformation (Context a)-liftTransContext = liftTransIn thisView+liftTransContext = liftTransIn contextView -thisView :: View (Context a) (a, Context a)-thisView = makeView f g+-- | Apply a function at top-level. Afterwards, try to return the focus +-- to the old position+applyTop :: (a -> a) -> Context a -> Context a+applyTop f c = +   case top c of +      Just ok -> navigateTowards (location c) (change f ok)+      Nothing -> c++termNavigator :: IsTerm a => a -> Navigator a+termNavigator a = fromMaybe (noNavigator a) (make a)  where-   f ctx = current ctx >>= \a -> Just (a, ctx)-   g = uncurry replace+   make = castT termView . viewNavigatorWith spineHoles . toTerm -contextView :: MonadPlus m => ViewM m a b -> ViewM m (Context a) (Context b)-contextView v = makeView f g+   spineHoles :: Term -> [(Term, Term -> Term)]+   spineHoles term+      | null xs   = []+      | otherwise = (x, flip makeTerm xs) : zipWith f [0..] xs+    where+      (x, xs)    = getSpine term+      f i y      = (y, makeTerm x . changeAt i)+      changeAt i b = +         case splitAt i xs of+            (ys, _:zs) -> ys ++ b:zs+            _          -> xs++use :: (IsTerm a, IsTerm b) => Rule a -> Rule (Context b)+use = useC . liftToContext++useC :: (IsTerm a, IsTerm b) => Rule (Context a) -> Rule (Context b)+useC = liftRule (makeView (castT termView) (fromJust . castT termView))++contextView :: View (Context a) (a, Context a)+contextView = newView "views.contextView" f g  where-   f 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))+   f ctx = current ctx >>= \a -> Just (a, ctx)+   g = uncurry replace  ---------------------------------------------------------- -- Context monad -newtype ContextMonad a = CM (Environment -> [(a, Environment)])+newtype ContextMonad a = CM { unCM :: Environment -> Maybe (a, Environment) } -withCM :: (a -> ContextMonad b) -> Context a -> Maybe (Context b)-withCM f c = fromContext c >>= \a -> runCM (f a) (getEnvironment c)+withCM :: (a -> ContextMonad a) -> Context a -> Maybe (Context a)+withCM f c = do +   a0       <- current c+   (a, env) <- unCM (f a0) (getEnvironment c)+   let nav = replace a (getNavigator c)+   return (newContext env nav)  evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b-evalCM f c = withCM f c >>= fromContext--runCM :: ContextMonad a -> Environment -> Maybe (Context a)-runCM (CM f) env = do-   (a, e) <- safeHead (f env)-   return (newContext e (noNavigator a))+evalCM f c = do+   a0     <- current c+   (b, _) <- unCM (f a0) (getEnvironment c)+   return b  instance Functor ContextMonad where    fmap = liftM@@ -229,16 +248,3 @@  maybeCM :: Maybe a -> ContextMonad a maybeCM = maybe mzero return---{--listCM :: [a] -> ContextMonad a-listCM = foldr (mplus . return) mzero--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
@@ -22,9 +22,11 @@    , results, lengthMax      -- * Adapters    , restrictHeight, restrictWidth, commit-   , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps, changeLabel+   , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps+   , changeLabel, sortTree      -- * Query a derivation    , isEmpty, derivationLength, terms, steps, triples, filterDerivation+   , mapStepsDerivation, derivationM      -- * Conversions    , derivation, randomDerivation, derivations    ) where@@ -32,6 +34,7 @@ import Common.Utils (safeHead) import Control.Arrow import Control.Monad+import Data.List import Data.Maybe import System.Random @@ -143,8 +146,14 @@ 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)}+   rec t = t {branches = map (f *** rec) (branches t)} +sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a+sortTree f t = t {branches = change (branches t) }+ where+   change = map (second (sortTree f)) . sortBy cmp+   cmp (l1, _) (l2, _) = f l1 l2+ mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a mergeMaybeSteps = mapSteps fromJust . mergeSteps isJust @@ -166,6 +175,9 @@ isEmpty :: Derivation s a -> Bool isEmpty (D _ xs) = null xs +mapStepsDerivation :: (s -> t) -> Derivation s a -> Derivation t a+mapStepsDerivation f (D a xs) = D a (map (first f) xs)+ -- | Returns the number of steps in a derivation derivationLength :: Derivation s a -> Int derivationLength (D _ xs) = length xs@@ -187,6 +199,10 @@ filterDerivation :: (s -> a -> Bool) -> Derivation s a -> Derivation s a filterDerivation p (D a xs) = D a (filter (uncurry p) xs) +-- | Apply a monadic function to each term, and to each step+derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m ()+derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) xs+ ----------------------------------------------------------------------------- -- Conversions from a derivation tree @@ -194,7 +210,7 @@ derivations :: DerivationTree s a -> Derivations s a derivations t = map (D (root t)) $    [ [] | endpoint t ] ++-   [ ((r,a2):ys) | (r, st) <- branches t, D a2 ys <- derivations st ]+   [ (r,a2):ys | (r, st) <- branches t, D a2 ys <- derivations st ]  -- | The first derivation (if any) derivation :: DerivationTree s a -> Maybe (Derivation s a)@@ -214,8 +230,8 @@ 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+   rec g acc n ys = +      case splitAt i ys of          (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs)          _ -> (acc, g)     where
src/Common/Exercise.hs view
@@ -14,45 +14,48 @@ module Common.Exercise     ( -- * Exercises      Exercise, testableExercise, makeExercise, emptyExercise-   , description, exerciseCode, status, parser, prettyPrinter+   , exerciseId, status, parser, prettyPrinter    , equivalence, similarity, isReady, isSuitable, eqWithContext-   , strategy, navigation, canBeRestarted, extraRules+   , strategy, navigation, canBeRestarted, extraRules, ruleOrdering    , difference, ordering, testGenerator, randomExercise, examples, getRule    , simpleGenerator, useGenerator    , randomTerm, randomTermWith, ruleset-   , makeContext, inContext+   , makeContext, inContext, recognizeRule, ruleIsRecognized+   , ruleOrderingWith, ruleOrderingWithId      -- * Exercise status    , Status(..), isPublic, isPrivate-     -- * Exercise codes-   , ExerciseCode, noCode, makeCode, readCode, domain, identifier      -- * Miscellaneous+   , prettyPrinterContext    , equivalenceContext, restrictGenerator    , showDerivation, printDerivation+   , ExerciseDerivation, defaultDerivation, derivationDiffEnv    , checkExercise, checkParserPretty-   , checkExamples, generate+   , checkExamples, exerciseTestSuite+   , module Common.Id -- for backwards compatibility    ) where -import Common.Apply+import Common.Classes import Common.Context import Common.Strategy hiding (not, fail, replicate) import qualified Common.Strategy as S import Common.Derivation+import Common.Id import Common.Navigator+import Common.TestSuite import Common.Transformation-import Common.Utils (putLabel)+import Common.Utils (ShowString(..)) import Common.View (makeView) import Control.Monad.Error-import Data.Char import Data.List import Data.Maybe+import Data.Ord import System.Random import Test.QuickCheck hiding (label) import Test.QuickCheck.Gen  data Exercise a = Exercise    { -- identification and meta-information-     description    :: String       -- short sentence describing the task-   , exerciseCode   :: ExerciseCode -- uniquely determines the exercise (in a given domain)+     exerciseId     :: Id -- identifier that uniquely determines the exercise    , status         :: Status      -- parsing and pretty-printing    , parser         :: String -> Either String a@@ -70,6 +73,7 @@    , navigation     :: a -> Navigator a    , canBeRestarted :: Bool                -- By default, assumed to be the case    , extraRules     :: [Rule (Context a)]  -- Extra rules (possibly buggy) not appearing in strategy+   , ruleOrdering   :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst)      -- testing and exercise generation    , testGenerator  :: Maybe (Gen a)    , randomExercise :: Maybe (StdGen -> Int -> a)@@ -77,14 +81,18 @@    }  instance Eq (Exercise a) where-   e1 == e2 = exerciseCode e1 == exerciseCode e2+   e1 == e2 = getId e1 == getId e2  instance Ord (Exercise a) where-   e1 `compare` e2 = exerciseCode e1 `compare` exerciseCode e2+   compare = comparing getId  instance Apply Exercise where    applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex +instance HasId (Exercise a) where+   getId = exerciseId+   changeId f ex = ex { exerciseId = f (exerciseId ex) }+ testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a testableExercise = makeExercise    { testGenerator = Just arbitrary@@ -100,8 +108,7 @@ emptyExercise :: Exercise a emptyExercise = Exercise     { -- identification and meta-information-     description    = "<<description>>" -   , exerciseCode   = noCode+     exerciseId     = error "no exercise code"    , status         = Experimental      -- parsing and pretty-printing    , parser         = const (Left "<<no parser>>")@@ -118,7 +125,8 @@    , strategy       = label "Fail" S.fail    , navigation     = noNavigator    , canBeRestarted = True-   , extraRules     = [] +   , extraRules     = []+   , ruleOrdering   = compareId      -- testing and exercise generation    , testGenerator  = Nothing    , randomExercise = Nothing@@ -137,28 +145,22 @@  -- returns a sorted list of rules (no duplicates) ruleset :: Exercise a -> [Rule (Context a)]-ruleset ex = nub (sortBy cmp list)+ruleset ex = nub (sortBy compareId list)  where     list = rulesInStrategy (strategy ex) ++ extraRules ex-   cmp a b = name a `compare` name b   simpleGenerator :: Gen a -> Maybe (StdGen -> Int -> a)  simpleGenerator = useGenerator (const True) . const  useGenerator :: (a -> Bool) -> (Int -> Gen a) -> Maybe (StdGen -> Int -> a) -useGenerator p g = Just f+useGenerator p makeGen = Just (\rng -> rec rng . makeGen)  where-   f rng level +   rec rng gen@(MkGen f)       | p a       = a-      | otherwise = f (snd (next rng)) level+      | otherwise = rec (snd (next rng)) gen     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+      (size, r) = randomR (0, 100) rng+      a         = f r size  restrictGenerator :: (a -> Bool) -> Gen a -> Gen a restrictGenerator p g = do@@ -181,6 +183,29 @@               xs !! fst (randomR (0, length xs - 1) rng)        where xs = examples ex +ruleIsRecognized :: Exercise a -> Rule (Context a) -> Context a -> Context a -> Bool+ruleIsRecognized ex r ca = not . null . recognizeRule ex r ca++-- Recognize a rule at (possibly multiple) locations+recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [Location]+recognizeRule ex r ca cb = rec (fromMaybe ca (top ca))+ where+   rec x = [ location x | here r x cb ] ++ concatMap rec (allDowns x)+   here  = ruleRecognizer $ \cx cy -> fromMaybe False $+      liftM2 (similarity ex) (fromContext cx) (fromContext cy)++ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering+ruleOrderingWith = ruleOrderingWithId . map getId+ +ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering+ruleOrderingWithId bs r1 r2 =+   let xs = map getId bs in+   case (findIndex (==getId r1) xs, findIndex (==getId r2) xs) of+      (Just i,  Just j ) -> i `compare` j+      (Just _,  Nothing) -> LT+      (Nothing, Just _ ) -> GT+      (Nothing, Nothing) -> compareId r1 r2+ --------------------------------------------------------------- -- Exercise status @@ -197,46 +222,7 @@  -- | An exercise that is not public isPrivate :: Exercise a -> Bool-isPrivate   = not . isPublic-------------------------------------------------------------------- Exercise codes (unique identification)--data ExerciseCode = EC String String | NoCode-   deriving (Eq, Ord)--instance Show ExerciseCode where-   show (EC xs ys) = xs ++ "." ++ ys-   show NoCode     = "no code"--noCode :: ExerciseCode-noCode = NoCode--makeCode :: String -> String -> ExerciseCode-makeCode a b-   | null a || null b || any invalidCodeChar (a++b) =-        error $ "Invalid exercise code: " ++ show (EC a b)-   | otherwise = -        EC (map toLower a) (map toLower b)-   -readCode :: String -> Maybe ExerciseCode-readCode xs =-   case break invalidCodeChar xs of-      (as, '.':bs) | all validCodeChar bs -> -         return $ makeCode as bs-      _ -> Nothing--validCodeChar, invalidCodeChar :: Char -> Bool-validCodeChar c = isAlphaNum c || c `elem` "-_"-invalidCodeChar = not . validCodeChar--domain :: ExerciseCode -> String-domain (EC s _) = s-domain _        = []--identifier :: ExerciseCode -> String-identifier (EC _ s) = s-identifier _        = []+isPrivate = not . isPublic  --------------------------------------------------------------- -- Rest@@ -252,42 +238,47 @@ 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 +getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a))+getRule ex a = +   case filter ((a ==) . getId) (ruleset ex) of        [hd] -> return hd-      []   -> fail $ "Could not find ruleid " ++ s-      _    -> fail $ "Ambiguous ruleid " ++ s+      []   -> fail $ "Could not find ruleid " ++ showId a+      _    -> fail $ "Ambiguous ruleid " ++ showId a +-- |Shows a derivation for a given start term. The specified rule ordering+-- is used for selection. showDerivation :: Exercise a -> a -> String-showDerivation ex a =-   case derivation tree of-      Just d  -> show (f d) ++ extra d-      Nothing -> prettyPrinterContext ex (root tree)-                 ++ "\n   =>\n<<no derivation>>"+showDerivation ex a = show (present der) ++ extra  where-   tree = derivationTree (strategy ex) (inContext ex a)-   extra d =-      case fromContext (last (terms d)) of+   der   = derivationDiffEnv (defaultDerivation ex a)+   extra =+      case fromContext (last (terms der)) of          Nothing               -> "<<invalid term>>"-         Just a | isReady ex a -> ""+         Just b | isReady ex b -> ""                 | 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)+   present = mapStepsDerivation (ShowString . uncurry f) +           . fmap (ShowString . prettyPrinterContext ex)+   f b env | nullEnv env = showId b+           | otherwise   = showId b ++ "\n      " ++ show env --- local helper datatype-data Shown = Shown String +type ExerciseDerivation a = Derivation (Rule (Context a)) (Context a) -instance Show Shown where-   show (Shown s) = s+defaultDerivation :: Exercise a -> a -> ExerciseDerivation a+defaultDerivation ex a =+   let ca     = inContext ex a+       tree   = sortTree (ruleOrdering ex) (derivationTree (strategy ex) ca)+       single = newDerivation ca []+   in fromMaybe single (derivation tree) +derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a)+derivationDiffEnv d =+   -- A bit of hack to show the delta between two environments, not including+   -- the location variable+   let t:ts = terms d+       xs   = zipWith3 f (steps d) (drop 1 (terms d)) (terms d)+       f b x y = (b, deleteEnv "location" (diffEnv (getEnvironment x) (getEnvironment y))) -- ShowString (show a ++ extra)+   in newDerivation t (zip xs ts)+ printDerivation :: Exercise a -> a -> IO () printDerivation ex = putStrLn . showDerivation ex          @@ -337,26 +328,28 @@                   ++ "  =>  " ++ prettyPrinterContext ex y -}  checkExercise :: Exercise a -> IO ()-checkExercise ex = do-   putStrLn ("** " ++ show (exerciseCode ex))+checkExercise = runTestSuite . exerciseTestSuite++exerciseTestSuite :: Exercise a -> TestSuite+exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do    checkExamples ex    case testGenerator ex of        Nothing  -> return ()       Just gen -> do          let showAsGen = showAs (prettyPrinter ex) gen-             check txt p = putLabel txt >> quickCheck p-         check "parser/pretty printer" $ forAll showAsGen $+         addProperty "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 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 "soundness strategy/generator" $ +         suite "Soundness non-buggy rules" $+            forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> +               let eq a b = equivalenceContext ex (from a) (from b)+                   myGen  = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen)+                   myView = makeView (return . from) (S (prettyPrinterContext ex))+                   args   = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100}+               in addPropertyWith (showId r) args $ +                     propRuleSmart eq (liftRule myView r) myGen + +         addProperty "soundness strategy/generator" $              forAll showAsGen $                maybe False (isReady ex) . fromContext                . applyD (strategy ex) . inContext ex . from@@ -371,47 +364,42 @@  -- check combination of parser and pretty-printer checkParserPretty :: (a -> a -> Bool) -> (String -> Either b a) -> (a -> String) -> a -> Bool-checkParserPretty eq parser pretty a = -   either (const False) (eq a) (parser (pretty a))+checkParserPretty eq p pretty a = +   either (const False) (eq a) (p (pretty a))  checkParserPrettyEx :: Exercise a -> a -> Bool checkParserPrettyEx ex =     checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex) -checkExamples :: Exercise a -> IO ()+checkExamples :: Exercise a -> TestSuite 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"+   unless (null xs) $ suite "Examples" $+      mapM_ (checksForTerm True ex) xs -checksForTerm :: Bool -> Exercise a -> a -> IO Bool+checksForTerm :: Bool -> Exercise a -> a -> TestSuite 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+   when leftMost $+      case derivation tree of+         Just d  -> checksForDerivation ex d+         Nothing -> +            fail $ "no derivation for " ++ prettyPrinter ex a    -- Random derivation-   g  <- getStdGen-   b2 <- case randomDerivation g tree of-            Just d  -> checksForDerivation ex d-            Nothing -> return True -   return $ and [b1, b2]+   g <- liftIO getStdGen+   case randomDerivation g tree of+      Just d  -> checksForDerivation ex d+      Nothing -> return ()           -checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> IO Bool+checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> TestSuite 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+   assertTrueMsg "start term" +      ("not suitable: " ++ prettyPrinterContext ex start) $+      maybe False (isSuitable ex) (fromContext start)+       {-    b2 <- do let b = False -- maybe True (isReady ex) (fromContext start)             when b $ report $ @@ -425,55 +413,35 @@                "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+   assertTrueMsg "final term" +      ("not ready: " ++ prettyPrinterContext ex start+               ++ "  =>  " ++ prettyPrinterContext ex final) $ +      maybe False (isReady ex) (fromContext final)+    -- Parser/pretty printer on terms-   let ts = terms d-       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+   let ts  = terms d+       p1  = maybe False (not . checkParserPrettyEx ex) . fromContext+   assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd -> +      let s = prettyPrinterContext ex hd +      in "parse error for " ++ s ++ ": parsed as " +         ++ either show (prettyPrinter ex) (parser ex s)++    -- Equivalences between terms    let pairs    = [ (x, y) | x <- ts, y <- ts ]-       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+       p2 (x, y) = not (equivalenceContext ex x y)+   assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) ->+      "not equivalent: " ++ prettyPrinterContext ex x+      ++ "  with  " ++ prettyPrinterContext ex y+    -- Similarity of terms-   {--   let p (x, _, y) = fromMaybe False $ +   let p3 (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 -}+   assertNull  "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) -> +      "similar subsequent terms: " ++ prettyPrinterContext ex x+      ++ "  with  " ++ prettyPrinterContext ex y+      ++ "  using  " ++ show r+                   let xs = [ x | cx <- terms d, x <- fromContext cx, not (similarity ex x x) ]-   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) -}+   assertNull "self similarity" $ take 1 $ flip map xs $ \hd -> +      "term not similar to itself: " ++ prettyPrinter ex hd
+ src/Common/Id.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Identification of entities+--+-----------------------------------------------------------------------------+module Common.Id +   ( Id, IsId(..), HasId(..), ( # ), sameId+   , unqualified, qualifiers, qualification+   , describe, description, showId, compareId+   ) where++import Data.Char+import Data.List+import Data.Monoid+import Data.Ord+import Common.StringRef+import Common.Utils (splitsWithElem)++---------------------------------------------------------------------+-- Abstract data type and its instances++data Id = Id +   { idList        :: [String]+   , idDescription :: String+   , idRef         :: !StringRef+   }+   +instance Show Id where+   show = concat . intersperse "." . idList++instance Eq Id where+   a == b = idRef a == idRef b++instance Ord Id where +   compare = comparing idRef++instance Monoid Id where+   mempty  = stringId ""+   mappend = ( # )++---------------------------------------------------------------------+-- Type class for constructing identifiers++class IsId a where+   newId    :: a   -> Id+   concatId :: [a] -> Id -- for String instance+   -- default definition+   concatId = mconcat . map newId++instance IsId Id where+   newId = id++instance IsId Char where+   newId c  = stringId [c]+   concatId = stringId++instance IsId a => IsId [a] where+   newId    = concatId+   concatId = mconcat . map newId++instance IsId () where+   newId = const mempty++instance (IsId a, IsId b) => IsId (a, b) where+   newId (a, b) = newId a # newId b+   +instance (IsId a, IsId b, IsId c) => IsId (a, b, c) where+   newId (a, b, c) = newId a # newId b # newId c+   +instance IsId a => IsId (Maybe a) where+   newId = maybe mempty newId+   +instance (IsId a, IsId b) => IsId (Either a b) where+   newId = either newId newId++-----------------------------------------------------+-- Type class for structures containing an identifier+   +class HasId a where+   getId    :: a -> Id+   changeId :: (Id -> Id) -> a -> a+ +instance HasId Id where+   getId    = id+   changeId = id++instance (HasId a, HasId b) => HasId (Either a b) where+   getId      = either getId getId+   changeId f = either (Left . changeId f) (Right . changeId f)+   +---------------------------------------------------------------------+-- Private constructors++appendId :: Id -> Id -> Id+appendId a b+   | null (idList a) = b+   | null (idList b) = a+   | otherwise       = Id (idList a ++ idList b) "" ref+ where+   ref = stringRef (show a ++ "." ++ show b)++-- Only allow alphanum and '-' ('.' has a special meaning)+stringId :: String -> Id+stringId txt = Id (make s) "" (stringRef s)+ where+   s    = norm txt+   make = filter (not . null) . splitsWithElem '.'+   norm = filter ok . map toLower+   ok c = isAlphaNum c || c `elem` ".-_"++---------------------------------------------------------------------+-- Additional functionality (overloaded)+   +infixr 8 #++( # ) :: (IsId a, IsId b) => a -> b -> Id+a # b = appendId (newId a) (newId b)+   +sameId :: (IsId a, IsId b) => a -> b -> Bool+sameId a b = newId a == newId b+   +unqualified :: HasId a => a -> String+unqualified a+   | null xs   = ""+   | otherwise = last xs+ where+   xs = idList (getId a)++qualifiers :: HasId a => a -> [String]+qualifiers a+   | null xs   = []+   | otherwise = init xs+ where+   xs = idList (getId a)++qualification :: HasId a => a -> String+qualification = concat . intersperse "." . qualifiers++description :: HasId a => a -> String +description = idDescription . getId++showId :: HasId a => a -> String+showId = show . getId++compareId :: HasId a => a -> a -> Ordering+compareId = comparing showId++describe :: HasId a => String -> a -> a+describe = changeId . describeId+ where+   describeId s a+      | null (idDescription a) = +           a {idDescription = s}+      | otherwise =+           a {idDescription = s ++ " " ++ idDescription a}
+ src/Common/Library.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Exports most from package Common+--+-----------------------------------------------------------------------------+module Common.Library +   ( module Common.Classes, module Common.Transformation+   , module Common.Context, module Common.Navigator+   , module Common.Derivation+   , module Common.Rewriting, module Common.Exercise+   , module Common.Strategy, module Common.View+   , failS, notS, repeatS, replicateS, sequenceS+   ) where++import Common.Classes+import Common.Context+import Common.Derivation+import Common.Exercise+import Common.Navigator hiding (left, right)+import Common.Rewriting hiding (difference)+import Common.Strategy  hiding (fail, not, repeat, replicate, sequence)+import Common.Transformation+import Common.View ++import qualified Common.Strategy as S+import Prelude (Int)++-- | Alias for strategy combinator @fail@+failS :: Strategy a+failS = S.fail++-- | Alias for strategy combinator @not@+notS :: IsStrategy f => f a -> Strategy a+notS = S.not++-- | Alias for strategy combinator @repeat@+repeatS :: IsStrategy f => f a -> Strategy a+repeatS = S.repeat++-- | Alias for strategy combinator @replicate@+replicateS :: IsStrategy f => Int -> f a -> Strategy a+replicateS = S.replicate++-- | Alias for strategy combinator @sequence@+sequenceS :: IsStrategy f => [f a] -> Strategy a+sequenceS = S.sequence
src/Common/Navigator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XExistentialQuantification #-}+{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -17,13 +17,14 @@      IsNavigator(..), TypedNavigator(..)      -- * Types and constructors     , Navigator, Location-   , navigator, noNavigator, viewNavigator+   , navigator, noNavigator, viewNavigator, viewNavigatorWith      -- * Derived navigations    , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo-   , top, leafs, downFirst, downLast, left, right+   , navigateTowards, top, leafs, downFirst, downLast, left, right+   , replaceT    ) where -import Common.Uniplate+import Common.Uniplate hiding (leafs) import Common.View hiding (left, right) import Control.Monad import Data.Maybe@@ -57,9 +58,7 @@    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+      fromMaybe a (changeM (Just . f) a)  class IsNavigator f => TypedNavigator f where    changeT  :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a) @@ -67,10 +66,10 @@    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"+   changeT _ _ = fail "changeT: not defined"+   currentT _  = fail "currentT: not defined"+   leaveT _    = fail "leaveT: not defined"+   castT _ _   = fail "castT: not defined"  --------------------------------------------------------------- -- Derived navigations@@ -102,6 +101,18 @@    js = location a    n  = length (takeWhile id (zipWith (==) is js)) +navigateTowards :: IsNavigator f => Location -> f a -> f a+navigateTowards is a = +   case ups (length js - n) a of +      Just b  -> safeDowns (drop n is) b+      Nothing -> a+ where +   js = location a+   n  = length (takeWhile id (zipWith (==) is js))+   +   safeDowns []     b = b+   safeDowns (m:ms) b = maybe b (safeDowns ms) (down m b)+ top :: (IsNavigator f, Monad m) => f a -> m (f a) top = navigateTo [] @@ -144,12 +155,12 @@ -- 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+data UniplateNav a = UN (HolesType a) [(Int, a -> a)] a -type UniplateType a = a -> ([a], [a] -> a)+type HolesType a = a -> [(a, a -> a)] -makeUN :: Uniplate a => a -> UniplateNav a-makeUN = UN uniplate []+makeUN :: HolesType a -> a -> UniplateNav a+makeUN f = UN f []  instance Show a => Show (UniplateNav a) where    show = showNav@@ -158,14 +169,9 @@    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+   allDowns (UN uni xs a) = +      let make i (b, f) = UN uni ((i, f):xs) b+      in zipWith make [0..] (uni a)        location (UN _ xs _) = reverse (map fst xs)    @@ -203,20 +209,27 @@    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"+      | tp1 == tp2 = return (VN (castView v) a)+      | otherwise  = fail $ "castT: " ++ show tp1 ++ " and " ++ show tp2     where-      f e = castM e >>= matchM v-      g   = fromMaybe (error "castT") . cast . build v+      tp1 = typeOf (getTp v)+      tp2 = typeOf (getTp v0)              getTp :: View a b -> a-      getTp = error "castT"+      getTp = error "castT: getTp" +replaceT :: (Monad m, TypedNavigator f, Typeable b) =>  b -> f a -> m (f a)+replaceT = changeT . const . return+ castM :: (Monad m, Typeable a, Typeable b) => a -> m b castM = maybe (fail "castM") return . cast +castView :: (Typeable c, Typeable a) => View a b -> View c b+castView v = makeView f g+ where+   f e = castM e >>= matchM v+   g   = fromMaybe (error "castT: build") . castM . build v+ --------------------------------------------------------------- -- Uniform navigator type @@ -252,10 +265,13 @@ -- Constructors  navigator :: Uniplate a => a -> Navigator a-navigator = N . S . makeUN+navigator = N . S . makeUN holes  noNavigator :: a -> Navigator a-noNavigator = N . S . UN (\a -> ([], const a)) []+noNavigator = N . S . UN (const []) []  viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a-viewNavigator = N . VN identity . makeUN+viewNavigator = viewNavigatorWith holes++viewNavigatorWith :: Typeable a => HolesType a -> a -> Navigator a+viewNavigatorWith f = N . VN identity . makeUN f
src/Common/Rewriting.hs view
@@ -10,15 +10,16 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting -   ( 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(..)+   ( module Common.Rewriting.Term+   , module Common.Rewriting.Group+   , module Common.Rewriting.Operator+   , module Common.Rewriting.Difference+   , module Common.Rewriting.RewriteRule    ) where -import Common.Rewriting.AC import Common.Rewriting.Difference+import Common.Rewriting.Group hiding (identity)+import Common.Rewriting.Operator hiding (unary, binary, isUnary, isBinary) import Common.Rewriting.RewriteRule-import Common.Rewriting.Term+import Common.Rewriting.Term hiding (Term(..))+import Common.Rewriting.Term (Term)
src/Common/Rewriting/AC.hs view
@@ -10,123 +10,53 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting.AC -   ( Operator, Operators, constructor, destructor-   , newOperator, associativeOperator, commutativeOperator, acOperator-   , makeAssociative, makeCommutative, isAssociative, isCommutative-   , collectWithOperator, buildWithOperator-   , isOperator, findOperator-   , normalizeWith, equalWith+   ( -- * Types+     Pairings, PairingsList, PairingsPair+     -- * Pairings with operator    , pairings, pairingsMatch-   , pairingsA2, onBoth+     -- * Primitive pairings functions+   , pairingsNone, pairingsA+   , pairingsC, pairingsAC    ) where -import Common.Uniplate-import Common.Utils-import Data.List+import Common.View+import Common.Rewriting.Group+import Control.Monad import Data.Maybe --------------------------------------------------------------- AC theories--type Operators a = [Operator a]--data Operator a = O -   { constructor   :: a -> a -> a-   , destructor    :: a -> Maybe (a, a)-   , isAssociative :: Bool-   , isCommutative :: Bool-   }-   -newOperator :: (a -> a -> a) ->  (a -> Maybe (a, a)) -> Operator a-newOperator f g = O f g False False--associativeOperator, commutativeOperator, acOperator :: (a -> a -> a) ->  (a -> Maybe (a, a)) -> Operator a-associativeOperator f = makeAssociative . newOperator f-commutativeOperator f = makeCommutative . newOperator f-acOperator          f = makeAssociative . commutativeOperator f--makeCommutative, makeAssociative :: Operator a -> Operator a-makeCommutative op = op { isCommutative = True }-makeAssociative op = op { isAssociative = True  }--collectWithOperator :: Operator a -> a -> [a]-collectWithOperator op a-   | isAssociative op = rec a []-   | otherwise        = maybe [a] (\(x, y) -> [x, y]) (destructor op a)- where-   rec a = case destructor op a of-              Just (x, y) -> rec x . rec y-              Nothing     -> (a:)--buildWithOperator :: Operator a -> [a] -> a-buildWithOperator op xs -   | null xs = -        error "Rewriting.buildWithOperator: empty list"-   | not (isAssociative op) && length xs > 2 =-        error "Rewriting.buildWithOperator: non-associative operator"-   | otherwise = -        foldr1 (constructor op) xs-   -isOperator :: Operator a -> a -> Bool-isOperator op = isJust . destructor op--findOperator :: Operators a -> a -> Maybe (Operator a)-findOperator ops a = safeHead $ filter (`isOperator` a) ops--normalizeWith :: (Uniplate a, Ord a) => Operators a -> a -> a-normalizeWith ops = rec- where-   rec a = -      case findOperator ops a of-         Just op -> -            buildWithOperator op $ (if isCommutative op then sort else id) $ map rec $ collectWithOperator op a-         Nothing -> -            let (cs, f) = uniplate a-            in f (map rec cs)--equalWith :: (Uniplate a, Ord a) => Operators a -> a -> a -> Bool-equalWith ops x y = normalizeWith ops x == normalizeWith ops y+type Pairings     a   = a -> a -> [[(a, a)]]+type PairingsList a b = [a] -> [b] -> [[([a], [b])]]+type PairingsPair a b = (a, a) -> (b, b) -> [[(a, b)]]  ----------------------------------------------------------- -- Pairing terms with an AC theory -- matchMode: the left-hand sides cannot have the operator at top-level  -pairings, pairingsMatch :: Operator a -> a -> a -> [[(a, a)]]+pairings, pairingsMatch :: IsMagma m => m a -> Pairings a pairings      = pairingsMode False pairingsMatch = pairingsMode True -pairingsMode :: Bool -> Operator a -> a -> a -> [[(a, a)]]+pairingsMode :: IsMagma m => Bool -> m a -> Pairings a pairingsMode matchMode op =    case (isAssociative op, isCommutative op) of-      (True , True ) -> pairingsAC matchMode op-      (True , False) -> pairingsA  matchMode op-      (False, True ) -> pairingsC op-      (False, False) -> pairingsNone op+      (True , True ) -> operatorPairings op (pairingsAC matchMode)+      (True , False) -> operatorPairings op (pairingsA matchMode)+      (False, True ) -> opPairings op pairingsC+      (False, False) -> opPairings op pairingsNone  -- non-associative, non-commutative pairings-pairingsNone :: Operator a -> a -> a -> [[(a, a)]]-pairingsNone op a b =-   case (destructor op a, destructor op b) of-      (Just (a1, a2), Just (b1, b2)) -> [[(a1, b1), (a2, b2)]]-      _ -> []-      +pairingsNone :: PairingsPair a b+pairingsNone (a1, a2) (b1, b2) = +   [[(a1, b1), (a2, b2)]]+ -- commutative pairings-pairingsC :: Operator a -> a -> a -> [[(a, a)]]-pairingsC op a b = -   case (destructor op a, destructor op b) of-      (Just (a1, a2), Just (b1, b2)) -> [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]]-      _ -> []+pairingsC :: PairingsPair a b+pairingsC (a1, a2) (b1, b2) =+   [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]]  -- associative pairings-pairingsA :: Bool -> Operator a -> a -> a -> [[(a, a)]]-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+pairingsA :: Bool -> PairingsList a b+pairingsA matchMode = rec  where    rec [] [] = [[]]    rec as bs = @@ -142,40 +72,33 @@       ]  -- associative/commutative pairings-pairingsAC :: Bool -> Operator a -> a -> a -> [[(a, a)]]  -pairingsAC matchMode op a b = rec (collectWithOperator op a) (collectWithOperator op b)+pairingsAC :: Bool -> PairingsList a b+pairingsAC matchMode = rec  where    rec [] [] = [[]]    rec [] _  = []    rec (a:as) bs = -      [ (a1, b1):ps+      [ (as1, bs1):ps       | (asr, as2) <- if matchMode then [([], as)] else splits as       , let as1 = a:asr       , (bs1, bs2) <- splits bs       , not (null bs1)       , length as1==1 || length bs1==1-      , let a1 = buildWithOperator op as1-      , let b1 = buildWithOperator op bs1       , ps <- rec as2 bs2       ] -{--data Tree = Leaf String | Bin Tree Tree deriving (Show, Eq, Ord)+----------------------------------------------------------+-- Helper functions -opBin :: Operator Tree-opBin = Operator isBin Bin- where-   isBin (Bin a b) = Just (a, b)-   isBin _ = Nothing-   -tree1 = Bin (Bin (Leaf "1") (Leaf "2")) (Bin (Leaf "3") (Leaf "4")) -- Bin (Bin (Leaf "a") (Leaf "b")) (Bin (Leaf "c") (Leaf "d"))-tree2 = Bin (Bin (Leaf "a") (Leaf "b")) (Bin (Leaf "c") (Leaf "d")) --Bin (Bin (Leaf "w") (Leaf "x")) (Bin (Leaf "y") (Leaf "z"))+opPairings :: IsMagma m => m a -> PairingsPair a a -> Pairings a+opPairings op f a b = fromMaybe [] $+   liftM2 f (match (magmaView op) a) (match (magmaView op) b) -ex1 = pairingsC opBin tree1 tree2-ex2 = pairingsA  False opBin tree1 tree2-ex3 = pairingsA  True  opBin tree1 tree2-ex4 = pairingsAC False opBin tree1 tree2-ex5 = pairingsAC True opBin tree1 tree2 -}+operatorPairings :: IsMagma m => m a -> PairingsList a a -> Pairings a +operatorPairings op g = curry $ +   let f a = fromMaybe [a] $ match (magmaListView op) a+       h = build (magmaListView op)+   in map (map (onBoth h)) . uncurry g . onBoth f  splits :: [a] -> [([a], [a])] splits = foldr insert [([], [])]
+ src/Common/Rewriting/Axioms.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Group axioms specified as rewrite rules (directed).+--+-----------------------------------------------------------------------------+module Common.Rewriting.Axioms +   ( -- Semigroup+     leftAssociative, rightAssociative, associative+     -- Monoid+   , leftIdentity, rightIdentity+     -- Group+   , leftInverse, rightInverse+   , inverseIdentity, inverseTwice+   , flippedInverseDistribution+   , groupAxioms+     -- Abelian group+   , commutative, inverseDistribution+   ) where++import Common.Id+import Common.Rewriting.Group+import Common.Rewriting.RewriteRule++-- helper+rule :: (IsMagma m, IsId n, RuleBuilder f a, Rewrite a) => m a -> n -> f -> RewriteRule a+rule m s = rewriteRule (getId (toMagma m), s)++-------------------------------------------------------------------+-- * SemiGroup++leftAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a+leftAssociative m = rule m "associative.left" $ +   \x y z -> x.(y.z) :~> (x.y).z+ where +   (.) = operation m++rightAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a+rightAssociative m = rule m "associative.right" $ +   \x y z -> (x.y).z :~> x.(y.z)+ where +   (.) = operation m++associative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a+associative m+   | leftIsPreferred m = leftAssociative m+   | otherwise         = rightAssociative m++-------------------------------------------------------------------+-- * Monoid++leftIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a+leftIdentity m = rule m "identity.left" $ +   \x -> e.x :~> x+ where +   (.) = operation m+   e   = identity m++rightIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a+rightIdentity m = rule m "identity.right" $ +   \x -> x.e :~> x+ where +   (.) = operation m+   e   = identity m++-------------------------------------------------------------------+-- * Group++leftInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a+leftInverse m = rule m "inverse.left" $ +   \x -> f x.x :~> e+ where +   (.) = operation m+   e   = identity m+   f   = inverse m++rightInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a+rightInverse m = rule m "inverse.right" $ +   \x -> x.f x :~> e+ where +   (.) = operation m+   e   = identity m+   f   = inverse m++inverseIdentity :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a+inverseIdentity m = rule m "inverse.identity" $ +   f e :~> e+ where+   e = identity m+   f = inverse m++inverseTwice :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a+inverseTwice m = rule m "inverse.twice" $ +   \x -> f (f x) :~> x+ where +   f = inverse m++flippedInverseDistribution :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a+flippedInverseDistribution m = rule m "inverse.distribution.flipped" $ +   \x y -> f (x.y) :~> f y.f x+ where +   (.) = operation m+   f   = inverse m++groupAxioms :: (IsGroup m, Different a, Rewrite a) => m a -> [RewriteRule a]+groupAxioms g = map ($ g)+   [ associative, leftIdentity, rightIdentity+   , leftInverse, rightInverse+   , inverseIdentity, inverseTwice, flippedInverseDistribution+   ] ++ extra+ where+   extra +      | leftIsPreferred g =+           [ rule g "group1" $ \x y -> (y.x).f x :~> y+           , rule g "group2" $ \x y -> (y.f x).x :~> y+           ]+      | otherwise = +           [ rule g "group3" $ \x y -> f x.(x.y) :~> y+           , rule g "group4" $ \x y -> x.(f x.y) :~> y+           ]+   (.) = operation g+   f   = inverse g++-------------------------------------------------------------------+-- * Abelian Group++-- The type class constraint IsAbelianGroup could be relaxed to +-- IsCommutative (or something similar)+commutative :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a+commutative m = rule m "commutative" $ +   \x y -> x.y :~> y.x+ where +   (.) = operation m+   +inverseDistribution :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a+inverseDistribution m = rule m "inverse.distribution" $ +   \x y -> f (x.y) :~> f x.f y+ where +   (.) = operation m+   f   = inverse m
+ src/Common/Rewriting/Confluence.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Common.Rewriting.Confluence +   ( isConfluent, checkConfluence, checkConfluenceWith+   , somewhereM+   , Config, defaultConfig, showTerm, complexity, termEquality+   ) where++import Common.Id+import Common.Navigator+import Common.Rewriting.RewriteRule+import Common.Rewriting.Substitution+import Common.Rewriting.Unification+import Common.Rewriting.Term+import Common.Uniplate hiding (rewriteM)+import Data.Char+import Data.Maybe++normalForm :: [RewriteRule a] -> Term -> Term+normalForm rs = run []+ where+   run hist a = +      case [ b | r <- rs, b <- somewhereM (rewriteTerm r) a ] of+         []   -> a+         hd:_ -> if hd `elem` hist+                 then error "cyclic"+                 else run (a:hist) hd ++rewriteTerm :: RewriteRule a -> Term -> [Term]+rewriteTerm r t = do+   let lhs :~> rhs = ruleSpecTerm r+   sub <- match [] lhs t+   return (sub |-> rhs)++-- uniplate-like helper-functions+somewhereM :: Uniplate a => (a -> [a]) -> a -> [a]+somewhereM f = concatMap leave . rec . navigator+ where+   rec ca = changeM f ca ++ concatMap rec (allDowns ca)++----------------------------------------------------++type Pair   a = (RewriteRule a, Term)+type Triple a = (RewriteRule a, Term, Term)++superImpose :: RewriteRule a -> RewriteRule a -> [Navigator Term]+superImpose r1 r2 = rec (navigator lhs1)+ where+    lhs1 :~> _ = ruleSpecTerm r1+    lhs2 :~> _ = ruleSpecTerm (renumber r1 r2)+    +    rec ca = case current ca of+                Just (Meta _) -> []+                Just a -> [ subTop s ca | s <- unifyM a lhs2 ] ++ concatMap rec (allDowns ca)+                Nothing -> []+    +    subTop s ca = fromMaybe ca $ +       fmap (change (freeze . (s |->))) (top ca) >>= navigateTo (location ca)+    +    renumber r = case metaInRewriteRule r of+                    [] -> id+                    xs -> renumberRewriteRule (maximum xs + 1)++criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)]+criticalPairs rs = +   [ (freeze a, (r1, freeze b1), (r2, freeze b2)) +   | r1       <- rs+   , r2       <- rs+   , na <- superImpose r1 r2+   , compareId r1 r2 == LT || not (null (location na))+   , a  <- leave na+   , b1 <- rewriteTerm r1 a+   , b2 <- changeM (rewriteTerm r2) na >>= leave+   ]++noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]+noDiamondPairs cfg rs = noDiamondPairsWith (normalForm rs) cfg rs++noDiamondPairsWith :: (Term -> Term) -> Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]+noDiamondPairsWith f cfg rs =+   [ (a, (r1, e1, nf1), (r2, e2, nf2)) +   | (a, (r1, e1), (r2, e2)) <- criticalPairs rs+   , let (nf1, nf2) = (f e1, f e2)+   , not (termEquality cfg nf1 nf2)+   ]++reportPairs :: Config -> [(Term, Triple a, Triple a)] -> IO ()+reportPairs cfg = putStrLn . unlines . zipWith report [1::Int ..]+ where+   f = showTerm cfg . unfreeze+   report i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines+      [ show i ++ ") " ++ f a+      , "  "   ++ showId r1+      , "    " ++ f e1 ++ if e1==nf1 then "" else "   -->   " ++ f nf1+      , "  "   ++ showId r2+      , "    " ++ f e2 ++ if e2==nf2 then "" else "   -->   " ++ f nf2+      ]++freeze :: Term -> Term+freeze (Meta n) = Con (newId ('m' : show n))+freeze term = descend freeze term++unfreeze :: Term -> Term+unfreeze (Con s) = case showId s of +                      'm':is | all isDigit is -> -- && not (null is) -> +                         Meta (read is)+                      _ -> Con s+unfreeze term = descend unfreeze term+++----------------------------------------------------++isConfluent :: [RewriteRule a] -> Bool+isConfluent = null . noDiamondPairs defaultConfig++checkConfluence :: [RewriteRule a] -> IO ()+checkConfluence = checkConfluenceWith defaultConfig++checkConfluenceWith :: Config -> [RewriteRule a] -> IO ()+checkConfluenceWith cfg = reportPairs cfg . noDiamondPairs cfg++data Config = Config+   { showTerm     :: Term -> String+   , complexity   :: Term -> Int+   , termEquality :: Term -> Term -> Bool+   }+   +defaultConfig :: Config+defaultConfig = Config show (const 0) (==)++----------------------------------------------------+-- Example+{-+r1, r2, r3, r4, r5 :: RewriteRule SLogic+r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r +r2 = rewriteRule "R2" $ \p q   -> p :||: q :~> q :||: p+r3 = rewriteRule "R3" $ \p     -> p :||: p :~> p+r4 = rewriteRule "R4" $ \p     -> p :||: T :~> T+r5 = rewriteRule "R5" $ \p     -> p :||: F :~> p++this = [r1, r2, r3, r4, r5, r6]+go = reportPairs $ noDiamondPairs this++r6 :: RewriteRule SLogic+r6 = rewriteRule "R6" $ \p -> p :||: T :~> F ++r1, r2, r3 :: RewriteRule Expr+r1 = rewriteRule "a1" $ \a -> 0+a :~> a+r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c+r3 = rewriteRule "a2" $ \a -> a+0 :~> a++go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2]+        checkConfluence [r1,r2,r3]+-}
src/Common/Rewriting/Difference.hs view
@@ -16,13 +16,16 @@    ( difference, differenceEqual, differenceMode    ) where -import Common.Rewriting.AC+import Common.Rewriting.Group+import Common.Rewriting.Term import Common.Rewriting.RewriteRule+import Common.View+import Common.Utils (safeHead) import Control.Monad import Common.Uniplate import Data.Maybe -differenceMode :: (Rewrite a, Uniplate a, ShallowEq a) +differenceMode :: (Rewrite a, Uniplate a)                 => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a) differenceMode eq b =    if b then differenceEqual eq else difference@@ -30,51 +33,59 @@ -- | This function returns the difference, except that the  -- returned terms should be logically equivalent. Nothing can signal that -- there is no difference, or that the terms to start with are not equivalent.-differenceEqual :: (Rewrite a, Uniplate a, ShallowEq a) +differenceEqual :: (Rewrite a, Uniplate a)                  => (a -> a -> Bool) -> a -> a -> Maybe (a, a) differenceEqual eq p q = do    guard (eq p q)    diff eq p q -difference :: (Rewrite a, Uniplate a, ShallowEq a) -           => a -> a -> Maybe (a, a)+difference :: (Rewrite a, Uniplate a) => a -> a -> Maybe (a, a) difference = diff (\_ _ -> True) +shallowEq :: IsTerm a => a -> a -> Bool+shallowEq a b = +   let f  = liftM fst . getFunction+       ta = toTerm a+       tb = toTerm b +   in fromMaybe (ta == tb) $ liftM2 (==) (f ta) (f tb)++findOperator :: [Magma a] -> a -> Maybe (Magma a)+findOperator ops a = safeHead $ filter (`isOperator` a) ops+ where isOperator op = isJust . match (magmaView op)+ -- local implementation function-diff :: (Rewrite a, Uniplate a, ShallowEq a) -     => (a -> a -> Bool) -> a -> a -> Maybe (a, a)-diff eq p q -   | shallowEq p q =-        case findOperator operators p of-           Just op | isAssociative op && not (isCommutative op) -> -              let ps = collectWithOperator op p-                  qs = collectWithOperator op q-              in diffA eq op ps qs-           _ -> diffList eq (children p) (children q)-   | otherwise = Just (p, q)+diff :: (Rewrite a, Uniplate a) => (a -> a -> Bool) -> a -> a -> Maybe (a, a)+diff eq = rec+ where+   rec p q+      | shallowEq p q =+           case findOperator operators p of+              Just op | isAssociative op && not (isCommutative op) -> do+                 ps <- match (magmaListView op) p+                 qs <- match (magmaListView op) q+                 diffA op ps qs+              _ -> diffList (children p) (children q)+      | otherwise = Just (p, q) -diffList :: (Rewrite a, Uniplate a, ShallowEq a) -         => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a)-diffList eq xs ys-   | length xs /= length ys = Nothing-   | otherwise = -        case catMaybes (zipWith (diff eq) xs ys) of-           [p] -> Just p-           _   -> Nothing+   diffList xs ys+      | length xs /= length ys = Nothing+      | otherwise = +           case catMaybes (zipWith rec xs ys) of+              [p] -> Just p+              _   -> Nothing            -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) && -                    isNothing (diff eq p q) && -                    (equal ps qs) = -      f (ps, qs)-   f pair = pair-   -   equal ps qs = buildWithOperator op ps `eq` buildWithOperator op qs-   rev   ps qs = (reverse ps, reverse qs)-   make pair   = -      case pair of -         ([p], [q]) -> diff eq p q-         (ps, qs)   -> Just (buildWithOperator op ps, buildWithOperator op qs)+   diffA op = curry (make . uncurry rev . f . uncurry rev . f)+    where+      f (p:ps, q:qs) | not (null ps || null qs) && +                       isNothing (rec p q) && +                       equal ps qs = +         f (ps, qs)+      f pair = pair+      +      equal ps qs = builder ps `eq` builder qs+      rev   ps qs = (reverse ps, reverse qs)+      builder     = build (magmaListView op)+      make pair   = +         case pair of +            ([p], [q]) -> rec p q+            (ps, qs)   -> Just (builder ps, builder qs)
+ src/Common/Rewriting/Group.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- A hierarchy of magma's (binary operators) and groups, up to Abelian groups.+--+-----------------------------------------------------------------------------+module Common.Rewriting.Group +   ( -- Magma+     IsMagma(..), Magma, magma, magmaView, magmaListView+   , withMatch, findMagma+   , isAssociative, isCommutative, isIdempotent+   , makeAssociative, makeCommutative, makeIdempotent+     -- Semigroup+   , IsSemiGroup(..), SemiGroup, semiGroup+   , leftIsPreferred, rightIsPreferred+   , preferLeft, preferRight+     -- Monoid+   , IsMonoid(..), Monoid, monoid+     -- Group+   , IsGroup(..), Group, group+     -- Abelian group+   , IsAbelianGroup(..), AbelianGroup, abelianGroup+   ) where++import Control.Arrow+import Common.Id+import Common.View hiding (identity)+import Common.Rewriting.Operator++-------------------------------------------------------------------+-- * Magma++class IsMagma f where +   operation   :: f a -> a -> a -> a+   hasMagma    :: f a -> (Magma a, Magma a -> f a)+   toMagma     :: f a -> Magma a+   changeMagma :: (Magma a -> Magma a) -> f a -> f a+   -- default definitions+   operation     = binary . magmaBinaryOp . toMagma+   toMagma       = fst . hasMagma+   changeMagma f = uncurry (flip ($)) . first f . hasMagma++data Magma a = Magma+   { magmaBinaryOp   :: BinaryOp a+   , magmaProperties :: [MagmaProperty]+   }++data MagmaProperty = Associative | Commutative | Idempotent | PreferLeft+   deriving Eq++instance Show (Magma a) where+   show m = "Magma " ++ showId m++instance HasId (Magma a) where+   getId = getId . magmaBinaryOp+   changeId f m = m {magmaBinaryOp = changeId f (magmaBinaryOp m)}++instance IsMagma Magma where+   hasMagma a = (a, id)++magma :: BinaryOp a -> Magma a+magma op = Magma op []++magmaView :: IsMagma m => m a -> View a (a, a)+magmaView = binaryView . magmaBinaryOp . toMagma++-- The list can (and should) only contain more than two elements if the magma +-- is associative+magmaListView :: IsMagma m => m a -> View a [a]+magmaListView m = makeView (Just . toList) fromList+ where+   toList = if isAssociative m then ($ []) . rec else f+ +   f a = maybe [a] (\(x, y) -> [x, y]) (match (magmaView m) a)+ +   rec a = case match (magmaView m) a of+            Just (b, c) -> rec b . rec c+            Nothing     -> (a:)++   fromList xs+      | null xs =+           error "semiGroupView.build: empty list"+      | n>2 && not (isAssociative m) =+           error $ "semiGroupView.build: not associativity for " +                   ++ showId (toMagma m)+      | otherwise = fold (operation m) xs+    where+      n    = length xs+      fold = if hasProperty PreferLeft m then foldl1 else foldr1++withMatch :: IsMagma m => (a -> Maybe (a, a)) -> m a -> m a+withMatch f = changeMagma $ \m -> m {magmaBinaryOp = g (magmaBinaryOp m)}+ where+   g op = makeBinary (getId op) (binary op) f++isAssociative, isCommutative, isIdempotent :: IsMagma m => m a -> Bool+isAssociative = hasProperty Associative+isCommutative = hasProperty Commutative+isIdempotent  = hasProperty Idempotent++makeAssociative, makeCommutative, makeIdempotent :: IsMagma m => m a -> m a+makeAssociative = giveProperty Associative+makeCommutative = giveProperty Commutative+makeIdempotent  = giveProperty Idempotent++findMagma :: IsMagma m => (m a -> b) -> m a -> (Magma a, Magma a -> b)+findMagma f = second (f .) . hasMagma++-- helper functions+hasProperty :: IsMagma m => MagmaProperty -> m a -> Bool+hasProperty p = elem p . magmaProperties . toMagma++giveProperty :: IsMagma m => MagmaProperty -> m a -> m a+giveProperty p = changeMagma $ \m -> +   m {magmaProperties = p:magmaProperties m}++removeProperty :: IsMagma m => MagmaProperty -> m a -> m a+removeProperty p = changeMagma $ \m -> +   m {magmaProperties = filter (/=p) (magmaProperties m)}++-------------------------------------------------------------------+-- * SemiGroup++class IsMagma f => IsSemiGroup f where+   toSemiGroup :: f a -> SemiGroup a+   -- default definition+   toSemiGroup m = SemiGroup (rightIsPreferred m) (toMagma m)++data SemiGroup a = SemiGroup Bool (Magma a)++instance Show (SemiGroup a) where+   show m = "Semigroup " ++ showId m++instance HasId (SemiGroup a) where+   getId    = getId . toMagma+   changeId = changeMagma . changeId++instance IsMagma SemiGroup where+   hasMagma (SemiGroup b m) = findMagma (SemiGroup b) m++instance IsSemiGroup SemiGroup where+   toSemiGroup = id++semiGroup :: BinaryOp a -> SemiGroup a+semiGroup op = makeAssociative $ SemiGroup True (magma op)++leftIsPreferred, rightIsPreferred :: IsSemiGroup m => m a -> Bool+leftIsPreferred  = hasProperty PreferLeft+rightIsPreferred = not . leftIsPreferred++preferLeft, preferRight :: IsSemiGroup m => m a -> m a+preferLeft  = giveProperty PreferLeft+preferRight = removeProperty PreferLeft++-------------------------------------------------------------------+-- * Monoid++class IsSemiGroup f => IsMonoid f where+   identity    :: f a -> a+   identityCon :: f a -> Constant a+   toMonoid    :: f a -> Monoid a+   -- default definition+   identity   = constant . identityCon+   toMonoid m = Monoid (identityCon m) (toSemiGroup m)++data Monoid a = Monoid (Constant a) (SemiGroup a)++instance Show (Monoid a) where+   show m = "Monoid " ++ showId m++instance HasId (Monoid a) where+   getId    = getId . toMagma+   changeId = changeMagma . changeId++instance IsMagma Monoid where+   hasMagma (Monoid e g) = findMagma (Monoid e) g++instance IsSemiGroup Monoid++instance IsMonoid Monoid where+   identityCon (Monoid e _) = e+   toMonoid = id++monoid :: BinaryOp a -> Constant a -> Monoid a+monoid op e = Monoid e (semiGroup op)++-------------------------------------------------------------------+-- * Group++class IsMonoid f => IsGroup f where+   inverse   :: f a -> a -> a+   inverseOp :: f a -> UnaryOp a+   toGroup   :: f a -> Group a+   -- default definition+   inverse   = unary . inverseOp+   toGroup g = Group (inverseOp g) (toMonoid g)++data Group a = Group (UnaryOp a) (Monoid a)++instance Show (Group a) where+   show m = "Group " ++ showId m++instance HasId (Group a) where+   getId    = getId . toMagma+   changeId = changeMagma . changeId++instance IsMagma Group where+   hasMagma (Group inv m) = findMagma (Group inv) m++instance IsSemiGroup Group++instance IsMonoid Group where+   identityCon (Group _ m) = identityCon m++instance IsGroup Group where+   inverseOp (Group inv _) = inv+   toGroup = id++group :: BinaryOp a -> Constant a -> UnaryOp a -> Group a+group op e inv = Group inv (monoid op e)++-------------------------------------------------------------------+-- * Abelian Group++class IsGroup f => IsAbelianGroup f where+   toAbelianGroup :: f a -> AbelianGroup a+   -- default definition+   toAbelianGroup = AbelianGroup . toGroup++newtype AbelianGroup a = AbelianGroup (Group a)+   deriving (HasId, IsMagma, IsSemiGroup, IsMonoid, IsGroup)++abelianGroup :: BinaryOp a -> Constant a -> UnaryOp a -> AbelianGroup a+abelianGroup op e inv = makeCommutative $ AbelianGroup (group op e inv)++instance Show (AbelianGroup a) where+   show m = "Abelian group " ++ showId m+   +instance IsAbelianGroup AbelianGroup
− src/Common/Rewriting/MetaVar.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Common.Rewriting.MetaVar where--import Common.Uniplate-import Common.Utils (readInt)-import qualified Data.IntSet as IS----------------------------------------------------------------- Meta variables---- | Type class for creating meta-variables-class MetaVar a where-    metaVar   :: Int -> a-    isMetaVar :: a -> Maybe Int--instance MetaVar String where-   isMetaVar  ('_':xs) = readInt xs-   isMetaVar _         = Nothing-   metaVar n = '_' : show n-   --- | Produces an infinite list of meta-variables-metaVars :: MetaVar a => [a]-metaVars = map metaVar [0..]---- | Collect all meta-variables-getMetaVars :: (MetaVar a, Uniplate a) => a -> IS.IntSet-getMetaVars a = getMetaVarsList [a]---- | Collect all meta-variables in the list-getMetaVarsList :: (MetaVar a, Uniplate a) => [a] -> IS.IntSet-getMetaVarsList xs = IS.fromList [ i | x <- xs, a <- universe x, Just i <- [isMetaVar a] ]---- | Checks whether the meta-variable is used in a term-hasMetaVar :: (MetaVar a, Uniplate a) => Int -> a -> Bool-hasMetaVar i = IS.member i . getMetaVars---- | Checks whether the meta-variable is used in one of the elements in the list-hasMetaVarList :: (MetaVar a, Uniplate a) => Int -> [a] -> Bool-hasMetaVarList i = IS.member i . getMetaVarsList---- | Checks whether a value has no variables-noMetaVars :: (Uniplate a, MetaVar a) => a -> Bool-noMetaVars = IS.null . getMetaVars  ---- | Determine what the next unused meta-varable is-nextMetaVar :: (Uniplate a, MetaVar a) => a -> Int-nextMetaVar a = nextMetaVarOfList [a]---- | Determine what the next meta-variable is that is not used in--- an element of the list-nextMetaVarOfList :: (Uniplate a, MetaVar a) => [a] -> Int-nextMetaVarOfList xs-   | IS.null s = 0-   | otherwise = 1 + IS.findMax s- where-   s = getMetaVarsList xs---- | Rename the meta-variables -renameMetaVars :: (MetaVar a, Uniplate a) => (Int -> Int) -> a -> a-renameMetaVars f a =-   case isMetaVar a of-      Just i  -> metaVar (f i)-      Nothing -> g $ map (renameMetaVars f) cs- where -   (cs, g) = uniplate a
+ src/Common/Rewriting/Operator.hs view
@@ -0,0 +1,117 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Common.Rewriting.Operator+   ( -- * Constants+     Constant, makeConstant, simpleConstant+   , constant, isConstant, constantView+     -- * Unary operators+   , UnaryOp, makeUnary, simpleUnary+   , unary, isUnary, unaryMatch, unaryView+     -- * Binary operators+   , BinaryOp, makeBinary, simpleBinary+   , binary, isBinary, binaryMatch, binaryView+   ) where++import Common.Id+import Common.Uniplate+import Common.View+import Data.Maybe+import Control.Monad++----------------------------------------------------------------------+-- Constants++data Constant a = C+   { constantId :: Id+   , constant   :: a+   , isConstant :: a -> Bool+   }++instance Show (Constant a) where+   show = showId++instance HasId (Constant a) where+   getId = constantId+   changeId f op = op {constantId = f (constantId op)}++makeConstant :: IsId n => n -> a -> (a -> Bool) -> Constant a+makeConstant = C . newId++simpleConstant :: (IsId n, Eq a) => n -> a -> Constant a+simpleConstant n a = makeConstant n a (==a)++constantView :: Constant a -> View a ()+constantView (C i a p) = newView i (guard . p) (const a)++----------------------------------------------------------------------+-- Unary operators++data UnaryOp a = U+   { unaryId    :: Id+   , unary      :: a -> a+   , unaryMatch :: a -> Maybe a+   }++instance Show (UnaryOp a) where+   show = showId++instance HasId (UnaryOp a) where+   getId = unaryId+   changeId f op = op {unaryId = f (unaryId op)}++makeUnary :: IsId n => n -> (a -> a) -> (a -> Maybe a) -> UnaryOp a+makeUnary = U . newId++simpleUnary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a) -> UnaryOp a+simpleUnary n op = makeUnary n op f+ where+   f a = case children a of+            [x] | op x == a -> Just x+            _ -> Nothing++isUnary :: UnaryOp a -> a -> Bool+isUnary op = isJust . unaryMatch op++unaryView :: UnaryOp a -> View a a+unaryView (U i op m) = newView i m op++----------------------------------------------------------------------+-- Binary operators++data BinaryOp a = B +   { binaryId    :: Id+   , binary      :: a -> a -> a+   , binaryMatch :: a -> Maybe (a, a)+   }++instance Show (BinaryOp a) where+   show = showId++instance HasId (BinaryOp a) where+   getId = binaryId+   changeId f op = op {binaryId = f (binaryId op)}++makeBinary :: IsId n => n -> (a -> a -> a) -> (a -> Maybe (a, a)) -> BinaryOp a+makeBinary = B . newId++simpleBinary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a -> a) -> BinaryOp a+simpleBinary n op = makeBinary n op f+ where+   f a = case children a of+            [x, y] | op x y == a -> Just (x, y)+            _ -> Nothing++isBinary :: BinaryOp a -> a -> Bool+isBinary op = isJust . binaryMatch op++binaryView :: BinaryOp a -> View a (a, a)+binaryView (B n op m) = newView n m (uncurry op)
src/Common/Rewriting/RewriteRule.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, -      FunctionalDependencies, FlexibleInstances, UndecidableInstances,-      TypeSynonymInstances #-}+       FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -14,45 +13,42 @@ ----------------------------------------------------------------------------- module Common.Rewriting.RewriteRule     ( -- * Supporting type classes-     Rewrite(..), ShallowEq(..), Different(..)+     Rewrite(..), Different(..)      -- * Rewrite rules and specs-   , RewriteRule(ruleName, rulePair), RuleSpec(..)-     -- * Compiling a rewrite rule-   , rewriteRule, rewriteRules, Builder, BuilderList+   , RewriteRule, ruleSpecTerm, RuleSpec(..)+     -- * Compiling rewrite rules+   , rewriteRule, RuleBuilder      -- * Using rewrite rules    , rewrite, rewriteM, showRewriteRule, smartGenerator+   , metaInRewriteRule, renumberRewriteRule, inverseRule+   , useOperators    ) where -import Common.Rewriting.AC+import Common.Classes+import Common.Id+import Common.View hiding (match) import Common.Rewriting.Substitution import Common.Rewriting.Term+import Common.Rewriting.Group+import Common.Rewriting.Unification hiding (match)+import Common.Uniplate (descend, leafs) import Control.Monad+import Data.Maybe import Test.QuickCheck-import Common.Apply-import Common.Rewriting.MetaVar (getMetaVars)-import Common.Rewriting.Unification+import qualified Common.Rewriting.Unification as Unification import qualified Data.IntSet as IS-import qualified Data.Map as M-+    ------------------------------------------------------ -- Supporting type classes -class Different a where-   different :: (a, a)--class ShallowEq a where -   shallowEq :: a -> a -> Bool- -- The arbitrary type class is a quick solution to have smart generators -- (in combination with lifting rules). The function in the RewriteRule module -- cannot have a type class for this reason -- The show type class is added for pretty-printing rules class (IsTerm a, Arbitrary a, Show a) => Rewrite a where-   operators      :: [Operator a]-   associativeOps :: a -> [Symbol]-   -- default definition: no associative/commutative operators-   operators      = []-   associativeOps = const []+   operators :: [Magma a]+   -- default definition: no special operators+   operators = []  ------------------------------------------------------ -- Rewrite rules and specs@@ -61,80 +57,69 @@     data RuleSpec a = a :~> a deriving Show -data RewriteRule a = Rewrite a => R -   { ruleName     :: String-   , nrOfMetaVars :: Int-   , rulePair     :: Int -> RuleSpec Term -   }- instance Functor RuleSpec where    fmap f (a :~> b) = f a :~> f b ---------------------------------------------------------- Compiling a rewrite rule+instance Crush RuleSpec where+   crush (a :~> b) = [a, b] -class Builder t a | t -> a where-   buildSpec :: t -> Int -> RuleSpec Term-   countVars :: t -> Int+instance Zip RuleSpec where +   fzipWith f (a :~> b) (c :~> d) = f a c :~> f b d -instance IsTerm a => Builder (RewriteRule a) a where-   buildSpec = rulePair-   countVars = nrOfMetaVars+data RewriteRule a = R+   { ruleId        :: Id+   , ruleSpecTerm  :: RuleSpec Term+   , ruleOperators :: [Magma a]+   , ruleShow      :: a -> String+   , ruleTermView  :: View Term a+   , ruleGenerator :: Gen a+   }+   +instance Show (RewriteRule a) where+   show = showId -instance IsTerm a => Builder (RuleSpec a) a where-   buildSpec (a :~> b) _ = toTerm a :~> toTerm b-   countVars _    = 0+instance HasId (RewriteRule a) where+   getId = ruleId+   changeId f r = r {ruleId = f (ruleId r)} -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+------------------------------------------------------+-- Compiling a rewrite rule -class BuilderList t a | t -> a where-   getSpecNr   :: t -> Int -> Int -> RuleSpec Term-   countSpecsL :: t -> Int-   countVarsL  :: t -> Int+class Different a where+   different :: (a, a) -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 Builder t a => BuilderList [t] a where-   getSpecNr rs = buildSpec . (rs !!)-   countSpecsL  = length-   countVarsL _ = 0+class RuleBuilder t a | t -> a where+   buildRuleSpec :: t -> Int -> RuleSpec Term -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+instance IsTerm a => RuleBuilder (RuleSpec a) a where+   buildRuleSpec = const . fmap toTerm -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)+instance (Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where+   buildRuleSpec f i = buildFunction i (\a -> buildRuleSpec (f a) (i+1)) +buildFunction :: (Zip f, Different a) => Int -> (a -> f Term) -> f Term+buildFunction n f = fzipWith (fill n) (f a) (f b)+ where (a, b) = different+  fill :: Int -> Term -> Term -> Term-fill i (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, Rewrite a) => String -> f -> [RewriteRule a]-rewriteRules s f = map (R s (countVarsL f) . getSpecNr f) [0 .. countSpecsL f-1]+fill i = rec+ where+   rec (Apply f a) (Apply g b) = Apply (rec f g) (rec a b)+   rec a b +      | a == b    = a+      | otherwise = Meta i -getMatcher :: Rewrite a => a -> Matcher-getMatcher = M.unions . map associativeMatcher . associativeOps+buildSpec :: [Symbol] -> RuleSpec Term -> Term -> [Term]+buildSpec ops (lhs :~> rhs) a = do+   s <- Unification.match ops lhs a+   let (b1, b2) = (specialLeft `elem` dom s, specialRight `elem` dom s)+       sym      = maybe (error "buildSpec") fst (getFunction lhs)+       extLeft  x = if b1 then binary sym (Meta specialLeft) x else x+       extRight x = if b2 then binary sym x (Meta specialRight) else x+   return (s |-> extLeft (extRight rhs)) +rewriteRule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> RewriteRule a+rewriteRule s f = R (newId s) (buildRuleSpec f 0) operators show termView arbitrary  ------------------------------------------------------ -- Using a rewrite rule@@ -143,10 +128,17 @@    applyAll = rewrite  rewrite :: RewriteRule a -> a -> [a]-rewrite r@(R _ _ _) a = do-   ext <- extendContext (associativeOps a) r-   build (rulePair ext 0) a+rewrite r a = +   let term = toTermRR r a+       syms = mapMaybe (operatorSymbol r a) (ruleOperators r)+   in concatMap (fromTermRR r) (buildSpec syms (ruleSpecTerm r) term) +operatorSymbol :: IsMagma m => RewriteRule a -> a -> m a -> Maybe Symbol+operatorSymbol r a op = +   case getFunction (toTermRR r (operation op a a)) of+      Just (s, [_, _]) -> Just s+      _                -> Nothing+  rewriteM :: MonadPlus m => RewriteRule a -> a -> m a rewriteM r = msum . map return . rewrite r @@ -154,58 +146,51 @@ -- Pretty-print a rewriteRule  showRewriteRule :: Bool -> RewriteRule a -> Maybe String-showRewriteRule sound r@(R _ _ _) = do-   x <- fromTermTp r (sub |-> a)-   y <- fromTermTp r (sub |-> b)+showRewriteRule sound r = do+   x <- fromTermRR r (sub |-> a)+   y <- fromTermRR r (sub |-> b)    let op = if sound then "~>" else "/~>" -   return (show x ++ " " ++ op ++ " " ++ show y)+   return (ruleShow r x ++ " " ++ op ++ " " ++ ruleShow r y)  where-   a :~> b = rulePair r 0-   vs  = IS.toList (getMetaVars a `IS.union` getMetaVars b)+   a :~> b = ruleSpecTerm r+   vs  = IS.toList (metaVarSet a `IS.union` metaVarSet 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  smartGenerator :: RewriteRule a -> Gen a-smartGenerator r@(R _ _ _) = do -   let a :~> _ = rulePair r 0-   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+smartGenerator r = do +   let a :~> _ = ruleSpecTerm r+   let vs = IS.toList (metaVarSet a)+   list <- replicateM (length vs) (ruleGenerator r)+   let sub = listToSubst (zip vs (map (toTermRR r) list))+   case fromTermRR r (sub |-> a) of+      Just x  -> return x+      Nothing -> ruleGenerator r  ------------------------------------------------------ --- 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]+inverseRule :: RewriteRule a -> RewriteRule a+inverseRule r = r {ruleSpecTerm = b :~> a}+ where a :~> b = ruleSpecTerm r++useOperators :: [Magma a] -> RewriteRule a -> RewriteRule a+useOperators xs r = r {ruleOperators = xs ++ ruleOperators r}++-- some helpers+metaInRewriteRule :: RewriteRule a -> [Int]+metaInRewriteRule r =+   [ n | a <- crush (ruleSpecTerm r), Meta n <- leafs a ]++renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a+renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)}  where-   lhs (a :~> _) = a- -   leftContext s a (x :~> y) =-      binary s a x :~> binary s a y+   f (Meta i) = Meta (i+n)+   f term     = descend f term    -   rightContext s a (x :~> y) =-      binary s x a :~> binary s y a+toTermRR :: RewriteRule a -> a -> Term+toTermRR = build . ruleTermView -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))+fromTermRR :: Monad m => RewriteRule a -> Term -> m a+fromTermRR = matchM . ruleTermView
src/Common/Rewriting/Substitution.hs view
@@ -8,75 +8,66 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) ----- Substitutions+-- Substitutions on terms -- ----------------------------------------------------------------------------- module Common.Rewriting.Substitution -   ( Substitution, emptySubst, singletonSubst, listToSubst, (@@), (@@@)-   , lookupVar, dom, removeDom, ran, (|->)+   ( Substitution, emptySubst, singletonSubst, dom+   , (@@), (@@@), (|->), listToSubst    ) where  import Common.Uniplate-import Common.Rewriting.MetaVar+import Common.Rewriting.Term import qualified Data.IntMap as IM-import qualified Data.IntSet as IS import Data.Maybe  ----------------------------------------------------------- --- Substitution  -- | Abstract data type for substitutions-newtype Substitution a = S { unS :: IM.IntMap a }+newtype Substitution = S { unS :: IM.IntMap Term }     infixr 4 |-> infixr 5 @@, @@@ -instance Show a => Show (Substitution a) where+instance Show Substitution where    show = show . unS  -- | Returns the empty substitution-emptySubst :: (Uniplate a, MetaVar a) => Substitution a+emptySubst :: Substitution emptySubst = S IM.empty  -- | Returns a singleton substitution-singletonSubst :: (MetaVar a, Uniplate a) => Int -> a -> Substitution a+singletonSubst :: Int -> Term -> Substitution singletonSubst i a = S (IM.singleton i a)  -- | Turns a list into a substitution-listToSubst :: (Uniplate a, MetaVar a) => [(Int, a)] -> Substitution a+listToSubst :: [(Int, Term)] -> Substitution listToSubst = S . IM.fromListWith (error "Substitution: keys are not unique")  -- | Combines two substitutions. The left-hand side substitution is first applied to -- the co-domain of the right-hand side substitution-(@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a+(@@) :: Substitution -> Substitution -> Substitution S a @@ S b = S $ a `IM.union` IM.map (S a |->) b  -- | Combines two substitutions with disjoint domains. If the domains are not disjoint, -- an error is reported-(@@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a+(@@@) :: Substitution -> Substitution -> Substitution S a @@@ S b = S (IM.unionWith err a b)  where err _ _ = error "Unification.(@@@): domains of substitutions are not disjoint"  -- | Lookups a variable in a substitution. Nothing indicates that the variable is -- not in the domain of the substitution-lookupVar :: Int -> Substitution a -> Maybe a+lookupVar :: Int -> Substitution -> Maybe Term lookupVar s = IM.lookup s . unS  -- | Returns the domain of a substitution (as a list)-dom :: Substitution a -> IS.IntSet-dom = IM.keysSet . unS---- | Removes variables from the domain of a substitution-removeDom :: IS.IntSet -> Substitution a -> Substitution a-removeDom s (S a) = S (IM.filterWithKey (\k _ -> IS.member k s) a)--ran :: Substitution a -> [a]-ran = IM.elems . unS+dom :: Substitution -> [Int]+dom = IM.keys . unS  -- | Apply the substitution-(|->) :: (MetaVar a, Uniplate a) => Substitution a -> a -> a-s |-> e = -   case isMetaVar e of-      Just i  -> fromMaybe e (lookupVar i s)-      Nothing -> let (cs, f) = uniplate e-                 in f (map (s |->) cs)+(|->) :: Substitution -> Term -> Term+s |-> term = +   case term of+      Meta i -> fromMaybe term (lookupVar i s)+      _      -> descend (s |->) term
src/Common/Rewriting/Term.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -12,46 +12,71 @@ -- A simple data type for term rewriting -- ------------------------------------------------------------------------------module Common.Rewriting.Term where+module Common.Rewriting.Term +   ( Term(..), IsTerm(..)+   , Symbol, newSymbol+   , fromTermM, fromTermWith+   , getSpine, makeTerm+     -- * Functions and symbols+   , WithFunctions(..), isSymbol, isFunction+   , unary, binary, isUnary, isBinary+     -- * Variables+   , WithVars(..), isVariable+   , vars, varSet, hasVar, withoutVar, hasSomeVar, hasNoVar+     -- * Meta variables+   , WithMetaVars(..), isMetaVar+   , metaVars, metaVarSet, hasMetaVar+   ) where +import Common.Id import Common.Utils (ShowString(..)) import Common.Uniplate+import Common.View import Control.Monad-import Common.Rewriting.MetaVar+import Data.Maybe import Data.Typeable+import qualified Data.IntSet as IS+import qualified Data.Set as S  ----------------------------------------------------------- -- * Data type for terms -data Symbol = S (Maybe String) String-   deriving (Eq, Ord)- data Term = Var   String            | Con   Symbol -          | App   Term Term+          | Apply Term Term           | Num   Integer            | Float Double           | Meta  Int  deriving (Show, Eq, Ord, Typeable)+ +instance Uniplate Term where+   uniplate (Apply f a) = ([f, a], \[g, b] -> Apply g b)+   uniplate term        = ([], \_ -> term) +newtype Symbol = S Id+   deriving (Eq, Ord)+ instance Show Symbol where-   show (S ma b) = maybe b (\a -> a++ "." ++ b) ma+   show = showId -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)+instance HasId Symbol where+   getId (S a) = a+   changeId f (S a) = S (f a) +newSymbol :: IsId a => a -> Symbol+newSymbol = S . newId+ ----------------------------------------------------------- -- * Type class for conversion to/from terms  class IsTerm a where    toTerm   :: a -> Term    fromTerm :: MonadPlus m => Term -> m a+   termView :: View Term a+   -- default definitions+   toTerm   = build termView+   fromTerm = matchM termView+   termView = makeView fromTerm toTerm  instance IsTerm Term where    toTerm   = id@@ -72,51 +97,127 @@ 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+fromTermWith f a = do+   (s, xs) <- getFunction a+   ys      <- mapM fromTermM xs+   f s ys  -------------------------------------------------------------- * Utility functions+-- * Functions and symbols -getSpine :: Term -> (Term, [Term])-getSpine = rec []- where-   rec xs (App f a) = rec (a:xs) f-   rec xs a         = (a, xs)+class WithFunctions a where+   -- constructing+   symbol   :: Symbol -> a+   function :: Symbol -> [a] -> a+   -- matching+   getSymbol   :: Monad m => a -> m Symbol+   getFunction :: Monad m => a -> m (Symbol, [a])+   -- default definition+   symbol s = function s []+   getSymbol a = +      case getFunction a of+         Just (t, []) -> return t+         _            -> fail "Common.Term.getSymbol"+         +instance WithFunctions Term where+   function = makeTerm . Con+   getFunction a = +      case getSpine a of+         (Con s, xs) -> return (s, xs)+         _           -> fail "Common.Rewriting.getFunction" +   +isSymbol :: WithFunctions a => Symbol -> a -> Bool+isSymbol s = maybe False (==s) . getSymbol -getConSpine :: Monad m => Term -> m (Symbol, [Term])-getConSpine a = liftM (\s -> (s, xs)) (isCon b)- where (b, xs) = getSpine a+isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a]+isFunction s a =+   case getFunction a of+      Just (t, as) | s == t -> return as+      _                     -> fail "Common.Term.isFunction" -makeTerm :: Term -> [Term] -> Term-makeTerm = foldl App+unary :: WithFunctions a => Symbol -> a -> a+unary s a = function s [a] -makeConTerm :: Symbol -> [Term] -> Term-makeConTerm = makeTerm . Con+binary :: WithFunctions a => Symbol -> a -> a -> a+binary s a b = function s [a, b] -unary :: Symbol -> Term -> Term-unary = App . Con+isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a+isUnary s a = +   case isFunction s a of+      Just [x] -> return x+      _        -> fail "Common.Term.isUnary" -binary :: Symbol -> Term -> Term -> Term-binary s = App . App (Con s)+isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a)+isBinary s a = +   case isFunction s a of+      Just [x, y] -> return (x, y)+      _           -> fail "Common.Term.isBinary" -isUnary :: Symbol -> Term -> Maybe Term-isUnary s term =-   case getSpine term of-      (t, [a]) | isCon t == Just s -> Just a-      _ -> Nothing+-----------------------------------------------------------+-- * Variables -isBinary :: Symbol -> Term -> Maybe (Term, Term)-isBinary s term =-   case getSpine term of-      (t, [a, b]) | isCon t == Just s -> Just (a, b)-      _ -> Nothing+class WithVars a where+   variable    :: String -> a+   getVariable :: Monad m => a -> m String  -isVar :: Monad m => Term -> m String-isVar (Var s) = return s-isVar _       = fail "isVar"+instance WithVars Term where +   variable    = Var+   getVariable (Var s) = return s+   getVariable _       = fail "Common.Rewriting.getVariable" -isCon :: Monad m => Term -> m Symbol-isCon (Con s) = return s-isCon _       = fail "isCon"+isVariable :: WithVars a => a -> Bool+isVariable = isJust . getVariable++vars :: (Uniplate a, WithVars a) => a -> [String]+vars = concatMap getVariable . leafs++varSet :: (Uniplate a, WithVars a) => a -> S.Set String+varSet = S.fromList . vars++hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool+hasVar i = (i `elem`) . vars++withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool+withoutVar i = not . hasVar i++hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool+hasSomeVar = not . hasNoVar++hasNoVar :: (Uniplate a, WithVars a) => a -> Bool+hasNoVar = null . vars++-----------------------------------------------------------+-- * Meta variables++class WithMetaVars a where+   metaVar    :: Int -> a+   getMetaVar :: Monad m => a -> m Int ++instance WithMetaVars Term where+   metaVar = Meta+   getMetaVar (Meta i) = return i+   getMetaVar _        = fail "Common.Rewriting.getMetaVar"++isMetaVar :: WithMetaVars a => a -> Bool+isMetaVar = isJust . getMetaVar++metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int]+metaVars = concatMap getMetaVar . leafs++metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet+metaVarSet = IS.fromList . metaVars++hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool+hasMetaVar i = (i `elem`) . metaVars++-----------------------------------------------------------+-- * Utility functions++getSpine :: Term -> (Term, [Term])+getSpine = rec [] + where+   rec xs (Apply f a) = rec (a:xs) f+   rec xs a           = (a, xs)++makeTerm :: Term -> [Term] -> Term+makeTerm = foldl Apply
src/Common/Rewriting/Unification.hs view
@@ -9,18 +9,35 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Common.Rewriting.Unification (match, Matcher, associativeMatcher) where+module Common.Rewriting.Unification +   ( match, unifyM, specialLeft, specialRight+   ) where  import Common.Rewriting.Term import Common.Rewriting.AC-import Common.Rewriting.MetaVar import Common.Rewriting.Substitution import Control.Monad-import qualified Data.IntSet as IS-import qualified Data.Map as M  ----------------------------------------------------------- -- Unification (in both ways)++unifyM :: Monad m => Term -> Term -> m Substitution+unifyM term1 term2 = +   case (term1, term2) of+      (Meta i, Meta j) | i == j -> +         return emptySubst+      (Meta i, _) | not (i `hasMetaVar` term2) -> +         return (singletonSubst i term2)+      (_, Meta j) | not (j `hasMetaVar` term1) -> +         return (singletonSubst j term1)+      (Apply f a, Apply g b) -> do+         s1 <- unifyM f g+         s2 <- unifyM (s1 |-> a) (s1 |-> b)+         return (s1 @@ s2)+      _ | term1 == term2 -> +         return emptySubst+      _ -> fail "unifyM: no unifier"+ {- class ShallowEq a where     shallowEq :: a -> a -> Bool@@ -66,51 +83,56 @@ ----------------------------------------------------------- -- Matching (or: one-way unification) -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+-- second term should not have meta variables++match :: [Symbol] -> Term -> Term -> [Substitution]+match assocSymbols = rec True  where-   rec (Meta i) y = do -      guard (not (hasMetaVar i y))+   rec _ (Meta 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+   rec isTop x y =+      case getSpine x of+         (Con s, [a1, a2]) | s `elem` assocSymbols ->+            concatMap (uncurry recList . unzip) (associativeMatch isTop s a1 a2 y)+         (a, as) -> do+            let (b, bs) = getSpine y             guard (a == b)             recList as bs     recList [] [] = return emptySubst    recList (x:xs) (y:ys) = do-      s1 <- rec x y+      s1 <- rec False x y       s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys)-      return (s2 @@ s1)+      return (s2 @@@ s1)    recList _ _ = []--type Matcher = M.Map Symbol (Term -> Term -> [[(Term, Term)]])--associativeMatcher :: Symbol -> Matcher-associativeMatcher s = M.singleton s f+      +associativeMatch :: Bool -> Symbol -> Term -> Term -> Term -> [[(Term, Term)]]+associativeMatch isTop s1 a1 a2 (Apply (Apply (Con s2) b1) b2) +   | s1==s2 = map (map make) result  where-   f a b = map (map make) result-    where-      (as, bs) = onBoth collect (a, b)-      result   = pairingsA2 True as bs-      make     = onBoth construct+   as = collect a1 . collect a2 $ []+   bs = collect b1 . collect b2 $ []+   list | isTop     = map ($ as) [id, extLeft, extRight, extBoth]+        | otherwise = [as]+        +   extLeft  = (Meta specialLeft:)+   extRight = (++[Meta specialRight])+   extBoth  = extLeft . extRight    -   collect = ($ []) . rec-    where -      rec term =-         case isBinary s term of-            Just (a, b) -> rec a . rec b-            Nothing     -> (term:)+   result   = concatMap (\zs -> pairingsA True zs bs) list+   make (a, b) = (construct a, construct b)    +   collect term =+      case getFunction term of+         Just (t, [a, b]) | s1==t -> collect a . collect b+         _ -> (term:)+       construct xs        | null xs   = error "associativeMatcher: empty list"-      | otherwise = foldr1 (binary s) xs+      | otherwise = foldr1 (binary s1) xs+associativeMatch _ _ _ _ _ = []++specialLeft, specialRight :: Int -- special meta variables for context extension+specialLeft  = maxBound+specialRight = pred specialLeft
src/Common/Strategy.hs view
@@ -16,30 +16,31 @@ ----------------------------------------------------------------------------- module Common.Strategy     ( -- * Data types and type classes-     Strategy, LabeledStrategy, strategyName+     Strategy, LabeledStrategy    , 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+   , while, until, multi      -- ** Traversal combinators    , fix, once, somewhere, topDown, bottomUp+   , onceWith, somewhereWith      -- * Configuration combinators    , module Common.Strategy.Configuration      -- * Strategy locations-   , StrategyLocation, topLocation, nextLocation, downLocation-   , locationDepth-   , subTaskLocation, nextTaskLocation, parseStrategyLocation-   , StrategyOrRule, subStrategy, strategyLocations-   , mapRules, mapRulesS, rulesInStrategy, cleanUpStrategy+   , strategyLocations, subStrategy+   , subTaskLocation, nextTaskLocation      -- * Prefixes    , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..)    , prefixToSteps, stepsToRules, lastStepInPrefix+     -- * Misc+   , cleanUpStrategy, rulesInStrategy, mapRules, mapRulesS    ) where  import Common.Strategy.Abstract@@ -47,5 +48,5 @@ import Common.Strategy.Prefix import Common.Strategy.Location import Common.Strategy.Configuration--import qualified Prelude ()+import Common.Strategy.Parsing+import Prelude ()
src/Common/Strategy/Abstract.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XFlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -16,20 +16,21 @@    , fullDerivationTree, derivationTree, rulesInStrategy    , mapRules, mapRulesS, cleanUpStrategy      -- Accessors to the underlying representation-   , toCore, fromCore, liftCore, liftCore2, fixCore, makeLabeledStrategy+   , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy    , toLabeledStrategy-   , LabelInfo, strategyName, processLabelInfo, changeInfo, makeInfo-   , removed, collapsed, hidden, labelName, IsLabeled(..)+   , LabelInfo, processLabelInfo, changeInfo, makeInfo+   , removed, collapsed, hidden, IsLabeled(..)    ) where +import Common.Id import Common.Utils (commaList) import Common.Strategy.Core-import Common.Strategy.BiasedChoice-import Common.Apply-import Common.Rewriting (RewriteRule(..))+import Common.Classes+import Common.Rewriting (RewriteRule) import Common.Transformation import Common.Derivation-import Common.Uniplate+import Common.Uniplate hiding (rewriteM)+import Common.Strategy.Parsing  ----------------------------------------------------------- --- Strategy data-type@@ -41,13 +42,13 @@    show = show . toCore  instance Apply Strategy where-   applyAll s = results . fullDerivationTree s+   applyAll = runCore . toCore  ----------------------------------------------------------- --- The information used as label in a strategy  data LabelInfo = Info -   { labelName :: String +   { labelId   :: Id     , removed   :: Bool    , collapsed :: Bool    , hidden    :: Bool@@ -59,16 +60,20 @@                ["collapsed" | collapsed info] ++                ["hidden"    | hidden    info]           extra = " (" ++ commaList ps ++ ")"-      in show (labelName info) ++ if null ps then "" else extra+      in showId info ++ if null ps then "" else extra -makeInfo :: String -> LabelInfo-makeInfo s = Info s False False False+instance HasId LabelInfo where+   getId = labelId+   changeId f info = info { labelId = f (labelId info) }+   +makeInfo :: IsId a => a -> LabelInfo+makeInfo s = Info (newId s) False False False  ----------------------------------------------------------- --- Type class  -- | Type class to turn values into strategies-class Apply f => IsStrategy f where+class IsStrategy f where    toStrategy :: f a -> Strategy a  instance IsStrategy (Core LabelInfo) where@@ -78,20 +83,16 @@    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)+  toStrategy (LS info (S core)) = S (Label info core) -instance IsStrategy Rule where -- Major rules receive a label+instance IsStrategy Rule where    toStrategy r       | isMajorRule r = toStrategy (toLabeled r)-      | otherwise     = S (Rule Nothing r)+      | otherwise     = S (Rule r)  instance IsStrategy RewriteRule where    toStrategy r = -      toStrategy (makeRule (ruleName r) (RewriteRule r))+      toStrategy (makeRule (getId r) (makeRewriteTrans r))  ----------------------------------------------------------- --- Labeled Strategy data-type@@ -111,15 +112,16 @@       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 +instance HasId (LabeledStrategy a) where+   getId = getId . labelInfo+   changeId = changeInfo . changeId+ class IsLabeled f where    toLabeled :: f a -> LabeledStrategy a    @@ -127,18 +129,15 @@    toLabeled = id  instance IsLabeled Rule where-   toLabeled r = LS (makeInfo (name r)) (S (Rule Nothing r))+   toLabeled r = LS (makeInfo (showId r)) (S (Rule r))  instance IsLabeled RewriteRule where-   toLabeled r = toLabeled (makeRule (ruleName r) (RewriteRule r))+   toLabeled r = toLabeled (makeRule (showId r) (makeRewriteTrans r))  -- | Labels a strategy with a string-label :: IsStrategy f => String -> f a -> LabeledStrategy a+label :: (IsId l, IsStrategy f) => l -> 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@@ -147,42 +146,45 @@ --- Process Label Information  processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a-processLabelInfo getInfo = mapCore forLabel forRule+processLabelInfo getInfo = rec emptyCoreEnv  where-   forLabel l c +   rec env core = +      case core of +         Rec n a   -> Rec n (rec (insertCoreEnv n core env) a)+         Label l a -> forLabel env l (rec env a)+         _ -> descend (rec env) core+ +   forLabel env l c        | removed info   = Fail-      | collapsed info = Rule (Just l) asRule+      | collapsed info = Label l (Rule asRule) -- !!       | otherwise      = new     where        new | hidden info = mapRule minorRule (Label l c)           | otherwise   = Label l c       info   = getInfo l-      asRule = makeSimpleRuleList (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+      asRule = makeSimpleRuleList (showId info{- ++ " (collapsed)"-}) +                  (runCoreWith env new)  ----------------------------------------------------------- --- Remaining functions  -- | Returns the derivation tree for a strategy and a term, including all -- minor rules-fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a-fullDerivationTree = makeBiasedTree p . processLabelInfo id . toCore . toStrategy +fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a+fullDerivationTree = make . processLabelInfo id . toCore . toStrategy   where -   p t = endpoint t || any isMajorRule (annotations t) || any p (subtrees t)-+   make core = fmap value . parseDerivationTree . makeState core+  -- | Returns the derivation tree for a strategy and a term with only major rules derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a-derivationTree s = mergeSteps isMajorRule . fullDerivationTree s-+derivationTree s = mergeMaybeSteps . mapSteps f . fullDerivationTree s+ where+   f (RuleStep r) | isMajorRule r = Just r+   f _ = Nothing+    -- | Returns a list of all major rules that are part of a labeled strategy rulesInStrategy :: IsStrategy f => f a -> [Rule a]-rulesInStrategy f = [ r | Rule _ r <- universe (toCore (toStrategy f)), isMajorRule r ]+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@@ -195,7 +197,7 @@ 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+   core = Rule (doAfter f idRule) :*: toCore s    g r | isMajorRule r = doAfter f r          | otherwise     = r        @@ -210,9 +212,3 @@  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 
@@ -1,106 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Common.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
@@ -14,12 +14,16 @@ ----------------------------------------------------------------------------- module Common.Strategy.Combinators where +import qualified Prelude import Prelude hiding (not, repeat, fail, sequence)+import Common.Id import Common.Context import Common.Navigator import Common.Transformation import Common.Strategy.Core import Common.Strategy.Abstract+import Common.Strategy.Configuration+import Data.Maybe  ----------------------------------------------------------- --- Strategy combinators@@ -32,11 +36,21 @@  -- | Put two strategies in sequence (first do this, then do that) (<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a-(<*>) = liftCore2 (:*:)+(<*>) = liftCore2 $ \x y -> +   case (x, y) of+      (Succeed, _) -> y+      (_, Succeed) -> x+      (Fail, _)    -> Fail+      (_, Fail)    -> Fail+      _            -> x :*: y  -- | Choose between the two strategies (either do this or do that) (<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a-(<|>) = liftCore2 (:|:)+(<|>) = liftCore2 $ \x y ->+   case (x, y) of+      (Fail, _) -> y+      (_, Fail) -> x+      _         -> x :|: y  -- | The strategy that always succeeds (without doing anything) succeed :: Strategy a@@ -101,6 +115,18 @@ (|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a (|>) = liftCore2 (:|>:) +-- | Repeat the strategy as long as the predicate holds+while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a+while p s = repeat (check p <*> s)++-- | Repeat the strategy until the predicate holds+until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a+until p = while (Prelude.not . p)++-- | Apply a strategy at least once, but collapse into a single step+multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a+multi s = collapse . label s . repeat1+ -- | Apply the strategies from the list exhaustively (until this is no longer possible) exhaustive :: IsStrategy f => [f a] -> Strategy a exhaustive = repeat . alternatives@@ -110,19 +136,35 @@ -- | 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))+fix f = fromCore (coreFix (toCore . f . fromCore)) +-- | Apply a strategy on (exactly) one of the term's direct children. The+-- function selects which children are visited.+onceWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a)+onceWith n f s = ruleMoveDown <*> s <*> ruleMoveUp+ where+   ruleMoveDown = minorRule $ makeSimpleRuleList ("navigation.down." ++ n) $ \a -> +      concatMap (`down` a) (f a)+   ruleMoveUp = minorRule $ makeSimpleRule "navigation.up" $ \a ->+      Just (fromMaybe a (up a))++-- | Apply a strategy somewhere in the term. The function selects which +-- children are visited+somewhereWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a)+somewhereWith n f s = fix $ \this -> s <|> onceWith n f this+ -- | Apply a strategy on (exactly) one of the term's direct children once :: IsStrategy f => f (Context a) -> Strategy (Context a)-once s = ruleMoveDown <*> s <*> ruleMoveUp- where-   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" allDowns   -   ruleMoveUp   = minorRule $ makeSimpleRule "MoveUp" up+once = onceWith "all" visitAll  -- | Apply a strategy somewhere in the term somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a)-somewhere s = fix $ \this -> s <|> once this+somewhere = somewhereWith "all" visitAll +-- local helper+visitAll :: Context a -> [Int]+visitAll a = [ 0 .. arity a-1 ]+ -- | Search for a suitable location in the term to apply the strategy using a -- top-down approach topDown :: IsStrategy f => f (Context a) -> Strategy (Context a)@@ -131,8 +173,4 @@ -- | 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 -}+bottomUp s = fix $ \this -> once this |> s
src/Common/Strategy/Configuration.hs view
@@ -12,17 +12,18 @@ module Common.Strategy.Configuration     ( -- Types and constructors      StrategyConfiguration, ConfigItem-   , ConfigLocation(..), ConfigAction(..), configActions+   , ConfigLocation, byName, byGroup+   , ConfigAction(..), configActions      --  Configure-  ,  configure+  ,  configure, configureNow      -- Combinators    , remove, reinsert, collapse, expand, hide, reveal    ) where +import Common.Id import Common.Strategy.Abstract import Common.Strategy.Core-import Common.Strategy.Location-import Common.Transformation+import Data.Maybe  --------------------------------------------------------------------- -- Types and constructors@@ -31,9 +32,8 @@ type ConfigItem = (ConfigLocation, ConfigAction)  data ConfigLocation-   = ByName     String-   | ByGroup    String-   | ByLocation StrategyLocation+   = ByName  Id+   | ByGroup Id  deriving Show   data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal@@ -42,31 +42,39 @@ configActions :: [ConfigAction] configActions = [Remove .. ] +byName :: HasId a => a -> ConfigLocation+byName = ByName . getId++byGroup :: HasId a => a -> ConfigLocation+byGroup = ByGroup . getId+ --------------------------------------------------------------------- -- Configure +configureNow :: LabeledStrategy a -> LabeledStrategy a+configureNow = +   let lsToCore = toCore . toStrategy+       coreToLS = fromMaybe err . toLabeledStrategy . toStrategy+       err      = error "configureNow: label disappeared"+   in coreToLS . processLabelInfo id . lsToCore+ configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a configure cfg ls = -   label (strategyName ls) (configureCore cfg (toCore (unlabel ls)))+   label (showId ls) (configureCore cfg (toCore (unlabel ls)))  configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a-configureCore cfg = mapCore f g . addLocation+configureCore cfg = mapLabel (change [])  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+   change groups info = +      let actions = getActions info groups cfg       in foldr doAction info actions    -getActions :: (StrategyLocation, LabelInfo) -> [String] +getActions :: LabelInfo -> [String]             -> StrategyConfiguration -> [ConfigAction]-getActions (loc, info) groups = map snd . filter (select . fst)+getActions 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+   select (ByName a)  = getId info == a+   select (ByGroup s) = showId s `elem` groups  doAction :: ConfigAction -> LabelInfo -> LabelInfo doAction action =
src/Common/Strategy/Core.hs view
@@ -15,18 +15,15 @@ ----------------------------------------------------------------------------- module Common.Strategy.Core     ( Core(..)-   , strategyTree, runTree --, makeTree -   , mapRule, coreVars, noLabels, mapCore, mapCoreM --, catMaybeLabel --, , -   , mapLabel, Translation, ForLabel(..) --, simpleTranslation+   , mapRule, mapLabel, noLabels+   , coreMany, coreRepeat, coreOrElse, coreFix+   , CoreEnv, emptyCoreEnv, insertCoreEnv, lookupCoreEnv, substCoreEnv    ) 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+import Data.Maybe+import qualified Data.IntMap as IM  ----------------------------------------------------------------- -- Strategy (internal) data structure, containing a selection@@ -42,11 +39,11 @@    | Core l a :|>: Core l a    | Many   (Core l a)    | Repeat (Core l a)-   | Not (Core () a) -- proves that there are no labels inside+   | Not (Core l a)    | Label l (Core l a)    | Succeed    | Fail-   | Rule (Maybe l) (Rule a)+   | Rule (Rule a)    | Var Int    | Rec Int (Core l a)  deriving Show@@ -54,9 +51,6 @@ ----------------------------------------------------------------- -- Useful instances -instance Apply (Core l) where -   applyAll core = results . makeTree core- instance Uniplate (Core l a) where    uniplate core =       case core of@@ -67,118 +61,91 @@          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))+         Not a     -> ([a],   \[x]   -> Not x)          _         -> ([],    \_     -> core)  -------------------------------------------------------------------- The strategy tree (static, no term)+-- Core environment -strategyTree :: Translation l a b -> Core l a -> DerivationTree b ()-strategyTree t = grammarTree . toGrammar t+newtype CoreEnv l a = CE (IM.IntMap (Core l a))  -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 ]+emptyCoreEnv :: CoreEnv l a+emptyCoreEnv = CE IM.empty+  +insertCoreEnv :: Int -> Core l a -> CoreEnv l a -> CoreEnv l a+insertCoreEnv n a (CE m) = CE (IM.insert n a m) --------------------------------------------------------------------- Running a strategy+deleteCoreEnv :: Int -> CoreEnv l a -> CoreEnv l a+deleteCoreEnv n (CE m) = CE (IM.delete n m) -makeTree :: Core l a -> a -> DerivationTree (Rule a) a-makeTree c = changeLabel fst . runTree (strategyTree simpleTranslation c)+lookupCoreEnv :: Int -> CoreEnv l a -> Maybe (Core l a)+lookupCoreEnv n (CE m) = IM.lookup n m -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 ]+substCoreEnv :: CoreEnv l a -> Core l a -> Core l a+substCoreEnv env core = +   case core of+      Var i   -> fromMaybe core (lookupCoreEnv i env)+      Rec i a -> Rec i (substCoreEnv (deleteCoreEnv i env) a)+      _       -> descend (substCoreEnv env) core  -------------------------------------------------------------------- Translation to Grammar data type+-- Definitions -type Translation l a b = (l -> ForLabel b, Rule a -> b)+coreMany :: Core l a -> Core l a+coreMany a = Rec n (Succeed :|: (a :*: Var n))+ where n = nextVar a -data ForLabel a = Skip | Before a | After a | Around a a+coreRepeat :: Core l a -> Core l a+coreRepeat a = Many a :*: Not a -simpleTranslation :: Translation l a (Rule a)-simpleTranslation = (const Skip, id)+coreOrElse :: Core l a -> Core l a -> Core l a+coreOrElse a b = a :|: (Not a :*: b) -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+coreFix :: (Core l a -> Core l a) -> Core l a+coreFix f = -- disadvantage: function f is applied twice+   let i = nextVar (f (Var (-1)))+   in Rec i (f (Var i)) -notRule :: Apply f => f a -> Rule a-notRule f = checkRule (not . applicable f)-   +nextVar :: Core l a -> Int+nextVar p+   | null xs   = 0+   | otherwise = maximum xs + 1+ where xs = coreVars p++coreVars :: Core l a -> [Int]+coreVars core = +   case core of+      Var n   -> [n]+      Rec n a -> n : coreVars a+      _       -> concatMap coreVars (children core)+ ----------------------------------------------------------------- -- Utility functions  mapLabel :: (l -> m) -> Core l a -> Core m a-mapLabel f = mapCore (Label . f) (Rule . fmap f)+mapLabel f = mapCore (Label . f) Rule  mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b-mapRule f = mapCore Label (\ml -> Rule ml . f)+mapRule f = mapCore Label (Rule . 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)+noLabels = mapCore (const id) Rule    -mapCore :: (l -> Core m b -> Core m b) -> (Maybe l -> Rule a -> Core m b) +mapCore :: (l -> Core m b -> Core m b) -> (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 +mapCore 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+         a :*: b   -> rec a :*:  rec b+         a :|: b   -> rec a :|:  rec b+         a :|>: b  -> rec a :|>: rec b+         Many a    -> Many   (rec a)+         Repeat a  -> Repeat (rec a)+         Succeed   -> Succeed+         Fail      -> Fail          Label l a -> f l (rec a)-         Rule 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 ]+         Rule r    -> g r+         Var n     -> Var n+         Rec n a   -> Rec n (rec a)+         Not a     -> Not (rec a)
− src/Common/Strategy/Grammar.hs 
@@ -1,367 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)------ 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
@@ -12,109 +12,69 @@ -- ----------------------------------------------------------------------------- module Common.Strategy.Location -   ( StrategyLocation, topLocation, nextLocation, downLocation-   , locationDepth-   , subTaskLocation, nextTaskLocation, parseStrategyLocation-   , StrategyOrRule, strategyLocations, subStrategy, addLocation+   ( subTaskLocation, nextTaskLocation+   , strategyLocations, subStrategy    ) where +import Common.Id 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+import Common.Utils (safeHead)+import Data.Maybe  ----------------------------------------------------------- --- 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)+subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id+subTaskLocation s xs ys = g (rec (f xs) (f 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+   f = fromMaybe [] . toLoc s+   g = fromMaybe (getId s) . fromLoc s+   rec (i:is) (j:js)+      | i == j    = i : rec is js +      | otherwise = []+   rec _ (j:_)    = [j]+   rec _ _        = []  -- old (current) and actual (next major rule) location-nextTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation-nextTaskLocation (SL xs) (SL ys) = SL (rec xs ys)+nextTaskLocation :: LabeledStrategy a -> Id -> Id -> Id+nextTaskLocation s xs ys = g (rec (f xs) (f 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+   f = fromMaybe [] . toLoc s+   g = fromMaybe (getId s) . fromLoc s+   rec (i:is) (j:js)+      | i == j    = i : rec is js+      | otherwise = [j]+   rec _ _        = []  -- | Returns a list of all strategy locations, paired with the labeled --- substrategy or rule at that location--strategyLocations :: LabeledStrategy a -> [(StrategyLocation, StrategyOrRule a)]-strategyLocations = collect . addLocation . toCore . toStrategy- where-   collect core = +-- substrategy at that location+strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)]+strategyLocations s = ([], s) : rec [] (toCore (unlabel s))+ where +   rec is = concat . zipWith make (map (:is) [0..]) . collect+   +   make is (l, core) = +      let ls  = makeLabeledStrategy l (toStrategy core)+      in (is, ls) : rec is core+   +   collect core =       case core of-         Label (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)+         Label l t -> [(l, t)]+         Not _     -> []+         _         -> concatMap collect (children core)  -- | Returns the substrategy or rule at a strategy location. Nothing  -- indicates that the location is invalid-subStrategy :: 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)+subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a)+subStrategy loc = +   fmap snd . safeHead . filter ((==loc) . getId . snd) . strategyLocations++fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id+fromLoc s loc = fmap getId (lookup loc (strategyLocations s))++toLoc :: LabeledStrategy a -> Id -> Maybe [Int]+toLoc s i = +   fmap fst (safeHead (filter ((==i) . getId . snd) (strategyLocations s)))
+ src/Common/Strategy/Parsing.hs view
@@ -0,0 +1,191 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Basic machinery for executing a core strategy expression.+--+-----------------------------------------------------------------------------+module Common.Strategy.Parsing+   ( Step(..)+   , State, makeState, stack, choices, trace, value+   , parseDerivationTree, replay, runCore, runCoreWith+   ) where++import Common.Classes+import Common.Derivation+import Common.Strategy.Core+import Common.Transformation+import Control.Monad++----------------------------------------------------------------------+-- Step data type++data Step l a = Enter l | Exit l | RuleStep (Rule a)+   deriving Show++instance Apply (Step l) where+   applyAll (RuleStep r) = applyAll r+   applyAll _            = return++----------------------------------------------------------------------+-- State data type++data State l a = S+   { stack   :: [Either l (Core l a)]+   , choices :: [Bool]+   , trace   :: [Step l a]+   , value   :: a+   }++makeState :: Core l a -> a -> State l a+makeState core a = push core (S [] [] [] a)++----------------------------------------------------------------------+-- Parse derivation tree++parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a)+parseDerivationTree state = addBranches list node+ where+   xs    = firsts state+   empty = not (null [ () | (Ready, _) <- xs ])+   node  = singleNode state empty+   list  = [ (step, parseDerivationTree s) | (Result step, s) <- xs ] ++firsts :: State l a -> [(Result (Step l a), State l a)]+firsts st =+   case pop st of +      Nothing              -> [(Ready, st)]+      Just (Left l, s)     -> [(Result (Exit l), traceExit l s)]+      Just (Right core, s) -> firstsStep core s+ where+   firstsStep core state =+      case core of+         a :*: b   -> firstsStep a (push b state)+         a :|: b   -> chooseFor True a ++ chooseFor False b+         Rec i a   -> firstsStep (substCoreVar i core a) state+         Var _     -> freeCoreVar "firsts"+         Rule r    -> hasStep (RuleStep r) (useRule r state)+         Label l a -> hasStep (Enter l) [push a (pushExit l state)]+         Not a     -> guard (checkNot a state) >> firsts state+         a :|>: b  -> firstsStep (coreOrElse a b) state+         Many a    -> firstsStep (coreMany a) state+         Repeat a  -> firstsStep (coreRepeat a) state+         Fail      -> []+         Succeed   -> firsts state+    where+      chooseFor b     = flip firstsStep (makeChoice b state)+      hasStep step xs = [ (Result step, traceStep step s) | s <- xs ]++-- helper datatype+data Result a = Result a | Ready++----------------------------------------------------------------------+-- Running the parser++runCore :: Core l a -> a -> [a]+runCore core = runState . makeState core++runCoreWith :: CoreEnv l a -> Core l a -> a -> [a]+runCoreWith env = runCore . substCoreEnv env++runState :: State l a -> [a]+runState st =+   case pop st of+      Nothing              -> [value st]+      Just (Left _, s)     -> runState s+      Just (Right core, s) -> runStep core s+ where+   runStep core state = +      case core of+         a :*: b   -> runStep a (push b state)+         a :|: b   -> runStep a state ++ runStep b state+         Rec i a   -> runStep (substCoreVar i core a) state+         Var _     -> freeCoreVar "runState"+         Rule  r   -> concatMap runState (useRule r state)+         Label _ a -> runStep a state+         Not a     -> guard (checkNot a state) >> runState state+         a :|>: b  -> let xs = runStep a state+                      in if null xs then runStep b state else xs+         Many a    -> runStep (coreMany a) state+         Repeat a  -> runStep (coreRepeat a) state+         Fail      -> []+         Succeed   -> runState state++----------------------------------------------------------------------+-- Replay a parse run++replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a)+replay n0 bs0 = replayState n0 bs0 . flip makeState noValue+ where+   noValue = error "no value in replay"+ +   replayState n bs state = +      case pop state of+         _ | n==0             -> return state+         Nothing              -> return state+         Just (Left l, s)     -> replayState (n-1) bs (traceExit l s)+         Just (Right core, s) -> replayStep n bs core s+             +   replayStep n bs core state =+      case core of+         _ | n==0  -> return state+         a :*: b   -> replayStep n bs a (push b state)+         a :|: b   -> case bs of+                        []   -> fail "replay failed"+                        x:xs -> let new = if x then a else b+                                in replayStep n xs new (makeChoice x state)+         Rec i a   -> replayStep n bs (substCoreVar i core a) state+         Var _     -> freeCoreVar "replay"+         Rule r    -> replayState (n-1) bs (traceRule r state)+         Label l a -> replayStep (n-1) bs a (pushExit l (traceEnter l state))+         Not _     -> replayState n bs state+         a :|>: b  -> replayStep n bs (coreOrElse a b) state+         Many a    -> replayStep n bs (coreMany a) state+         Repeat a  -> replayStep n bs (coreRepeat a) state+         Fail      -> fail "replay failed"+         Succeed   -> replayState n bs state++----------------------------------------------------------------------+-- Local helper functions and instances+   +push :: Core l a -> State l a -> State l a+push core s = s {stack = Right core : stack s}++pushExit :: l -> State l a -> State l a+pushExit l s = s {stack = Left l : stack s}++pop :: State l a -> Maybe (Either l (Core l a), State l a)+pop s = case stack s of+           []   -> Nothing+           x:xs -> Just (x, s {stack = xs})+   +makeChoice :: Bool -> State l a -> State l a+makeChoice b s = s {choices = b : choices s}++checkNot :: Core l a -> State l a -> Bool+checkNot core = null . runCore core . value++useRule :: Rule a -> State l a -> [State l a]+useRule r state = [ state {value = b} | b <- applyAll r (value state) ]++traceEnter, traceExit :: l -> State l a -> State l a+traceEnter = traceStep . Enter+traceExit  = traceStep . Exit++traceRule :: Rule a -> State l a -> State l a+traceRule = traceStep . RuleStep++traceStep :: Step l a -> State l a -> State l a+traceStep step s = s {trace = step : trace s}++substCoreVar :: Int -> Core l a -> Core l a -> Core l a+substCoreVar i a = substCoreEnv (insertCoreEnv i a emptyCoreEnv)++freeCoreVar :: String -> a+freeCoreVar caller = error $ "Free var in core expression: " ++ caller
src/Common/Strategy/Prefix.hs view
@@ -14,18 +14,16 @@ ----------------------------------------------------------------------------- module Common.Strategy.Prefix     ( Prefix, emptyPrefix, makePrefix-   , Step(..), prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix+   , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix    ) where -import Common.Apply import Common.Utils import Common.Strategy.Abstract-import Common.Strategy.Core+import Common.Strategy.Parsing import Common.Transformation import Common.Derivation-import Common.Strategy.Location-import Common.Strategy.BiasedChoice import Data.Maybe+import Control.Monad  ----------------------------------------------------------- --- Prefixes@@ -34,13 +32,22 @@ -- 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) ())+data Prefix a = P (State LabelInfo a) +prefixPair :: Prefix a -> (Int, [Bool])+prefixPair (P s) = (length (trace s), reverse (choices s))++prefixIntList :: Prefix a -> [Int]+prefixIntList = f . prefixPair+ where+   f (0, []) = []+   f (n, bs) = n : map (\b -> if b then 0 else 1) bs+ instance Show (Prefix a) where-   show (P xs _) = show (reverse (map fst xs))+   show = show . prefixIntList  instance Eq (Prefix a) where-   P xs _ == P ys _ = map fst xs == map fst ys+   a == b = prefixPair a == prefixPair b  -- | Construct the empty prefix for a labeled strategy emptyPrefix :: LabeledStrategy a -> Prefix a@@ -48,60 +55,28 @@  -- | 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+makePrefix []     ls = makePrefix [0] ls+makePrefix (i:is) ls = liftM P $ +   replay i (map (==0) is) (mkCore ls)  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+   mkCore = processLabelInfo id . toCore . toStrategy  -- | 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)+prefixTree (P s) a = f (parseDerivationTree s {value = a})  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 ]+   f t = addBranches list (singleNode (value $ root t) (endpoint t))+    where+      list = map g (branches t)+      g (_, st) = (P (root st), f st)++prefixToSteps :: Prefix a -> [Step LabelInfo a]+prefixToSteps (P t) = reverse (trace t)   -- | Retrieves the rules from a list of steps-stepsToRules :: [Step a] -> [Rule a]-stepsToRules steps = [ r | Step r <- steps ]+stepsToRules :: [Step l a] -> [Rule a]+stepsToRules xs = [ r | RuleStep r <- xs ]  -- | Returns the last rule of a prefix (if such a rule exists)-lastStepInPrefix :: Prefix a -> Maybe (Step a)-lastStepInPrefix (P xs _) = safeHead [ step | (_, Normal step) <- xs ]+lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a)+lastStepInPrefix (P t) = safeHead (trace t)
+ src/Common/StringRef.hs view
@@ -0,0 +1,128 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- References to Strings, proving a fast comparison implementation (Eq and
+-- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy 
+-- Virutal Machine (LVM) identifiers.
+--
+-----------------------------------------------------------------------------
+module Common.StringRef (StringRef, stringRef, toString) where
+
+import Data.Bits
+import Data.IORef
+import Data.List 
+import System.IO.Unsafe
+import qualified Data.IntMap as IM
+
+----------------------------------------------------------------
+-- StringRef datatype and instance declarations
+
+data StringRef = S !Int 
+   deriving (Eq, Ord)
+
+instance Show StringRef where
+   show s@(S i) = '#' : show i ++ toString s
+
+----------------------------------------------------------------
+-- Hash table
+
+type HashTable = IM.IntMap [String]
+
+tableRef :: IORef HashTable
+tableRef = unsafePerformIO (newIORef IM.empty)
+
+----------------------------------------------------------------
+-- Conversion to and from strings
+
+stringRef :: String -> StringRef
+stringRef s = unsafePerformIO $ do
+   let hash = hashString s
+   m <- readIORef tableRef
+   case IM.insertLookupWithKey (\_ -> combine) hash [s] m of
+      (Nothing, new) -> do
+         writeIORef tableRef new
+         return (S (encodeIndexZero hash))
+      (Just old, new) -> 
+         case findIndex (==s) old of
+            Just index -> 
+               return (S (encode hash index))
+            Nothing -> do
+               let index = length old
+               writeIORef tableRef new
+               return (S (encode hash index))
+
+toString :: StringRef -> String
+toString (S i) = unsafePerformIO $ do
+   m <- readIORef tableRef
+   case IM.lookup (extractHash i) m of 
+      Just xs -> return (atIndex (extractIndex i) xs)
+      Nothing -> intErr "id not found"
+
+----------------------------------------------------------------
+-- Bit encoding   
+
+encode :: Int -> Int -> Int
+encode hash index = hash + index `shiftL` 12
+
+encodeIndexZero :: Int -> Int
+encodeIndexZero hash = hash
+
+extractHash :: Int -> Int
+extractHash i = i `mod` 4096
+
+extractIndex :: Int -> Int
+extractIndex i = i `shiftR` 12
+
+----------------------------------------------------------------
+-- Hash function
+
+-- simple hash function that performs quite good in practice
+hashString :: String -> Int
+hashString s = (f s `mod` prime) `mod` maxHash
+ where
+   f        = foldl' next 0   -- ' strict fold
+   next n c = n*65599 + fromEnum c
+   prime    = 32537 --65599   -- require: prime < maxHash
+
+maxHash :: Int
+maxHash = 0xFFF -- 12 bits
+
+----------------------------------------------------------------
+-- Utility functions
+
+atIndex :: Int -> [a] -> a
+atIndex 0 (x:_)  = x
+atIndex i (_:xs) = atIndex (i-1) xs
+atIndex _ _      = intErr "corrupt symbol table"
+
+combine :: Eq a => [a] -> [a] -> [a]
+combine [a] = rec
+ where
+   rec [] = [a]
+   rec this@(x:xs) 
+      | a == x    = this
+      | otherwise = x:rec xs
+combine _ = intErr "combine"
+
+intErr :: String -> a
+intErr s = error ("Internal error in Common.StringRef: " ++ s)
+
+----------------------------------------------------------------
+-- Testing and debugging 
+
+{-
+printTable :: IO ()
+printTable = readIORef tableRef >>= print
+
+test1 _ = toString (stringRef "bas") == "bas"
+test2 _ = stringRef "bas" == stringRef "bas"
+test3 _ = stringRef "bas" /= stringRef "je"
+test4 _ = stringRef "arith1.unary_minus" /= stringRef "distribute power"
+-}
+ src/Common/TestSuite.hs view
@@ -0,0 +1,385 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- A lightweight wrapper around the QuickCheck library. It introduces the+-- notion of a test suite, and it stores the test results for later inspection+-- (e.g., for the generation of a test report). A test suite has a monadic+-- interface.+--+-----------------------------------------------------------------------------+module Common.TestSuite +   ( -- * Test Suite Monad+     TestSuite, MonadIO(..)+     -- * Test suite constructors+   , suite, addProperty, addPropertyWith+   , assertTrue, assertTrueMsg, assertNull, assertEquals+   , assertIO, warn+     -- * Running a test suite+   , runTestSuite, runTestSuiteResult+     -- * Test Suite Result+   , TestSuiteResult, subResults+   , makeSummary, printSummary+   , makeTestLog, makeTestLogWith, printTestLog+     -- * Formatting+   , FormatLog(..), formatLog, formatTimeDiff+   ) where++import Control.Arrow+import Data.List+import Data.Monoid+import qualified Data.Sequence as S+import Data.Foldable (toList)+import Test.QuickCheck+import Control.Monad.State+import System.Time hiding (formatTimeDiff)++----------------------------------------------------------------+-- Test Suite Monad++-- Integer corresponds to the number of characters on the current line, and+-- is used for formatting+newtype TestSuiteM a = TSM { unTSM :: M a }++type M a = StateT (Int, ResultTree) IO a+type TestSuite = TestSuiteM ()++instance Monad TestSuiteM where+   return  = TSM . return+   m >>= f = TSM (unTSM m >>= unTSM . f)+   fail s  = do assertTrueMsg "" s False+                return (error "TestSuite.fail: do not bind result")++instance MonadIO TestSuiteM where+   liftIO =  TSM . liftIO++instance Monoid a => Monoid (TestSuiteM a) where+   mempty  = return mempty+   mappend = (>>)++----------------------------------------------------------------+-- Test suite constructors++-- | Construct a (named) test suite containing tests and other suites+suite :: String -> TestSuite -> TestSuite+suite s m = TSM $ do+   newline+   liftIO $ putStrLn s+   reset+   (t, td) <- getDiff (withEmptyTree (unTSM m))+   addTree (labeled (s, td) t)++-- | Add a QuickCheck property to the test suite. The first argument is +-- a label for the property+addProperty :: Testable prop => String -> prop -> TestSuite+addProperty = flip addPropertyWith stdArgs++-- | Add a QuickCheck property to the test suite, also providing a test+-- configuration (Args)+addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite+addPropertyWith s args p = TSM $ do+   newlineIndent+   r <- liftIO $ quickCheckWithResult args p+   reset+   addResult s (toTestResult (maxSuccess args) r)++assertTrue :: String -> Bool -> TestSuite+assertTrue msg = assertIO msg . return++assertTrueMsg :: String -> String -> Bool -> TestSuite+assertTrueMsg s msg = addAssertion (Error msg) s . return++assertNull :: Show a => String -> [a] -> TestSuite+assertNull s xs = addAssertion (f xs) s (return (null xs))+ where f = Error . concat . intersperse "\n" . map show+ +assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite+assertEquals s x y = addAssertion msg s (return (x==y))+ where msg = Error ("Not equal: " ++ show x ++ " and " ++ show y)++assertIO :: String -> IO Bool -> TestSuite+assertIO = addAssertion (Error "Assertion failed")++warn :: String -> TestSuite+warn msg = addAssertion (Warning msg) "" (return False)++-- local helpers+addAssertion :: TestResult -> String -> IO Bool -> TestSuite+addAssertion msg s io = TSM $ do+   b <- liftIO (io `catch` \_ -> return False)+   if b then do +      dot+      addResult s (Ok 1)+    else do+      newlineIndent+      liftIO $ putStrLn (s ++ ": " ++ show msg)+      reset+      addResult s msg++addResult :: String -> TestResult -> M ()+addResult s r = addTree (single (s, r))++addTree :: ResultTree -> M ()+addTree t = modify (second (`mappend` t))++withEmptyTree :: M () -> M ResultTree+withEmptyTree m = do+   t0 <- gets snd+   modify (second (const mempty))+   m+   tr <- gets snd+   modify (second (const t0))+   return tr++-- formatting helpers+newline :: M ()+newline = do+   i <- gets fst+   when (i>0) (liftIO $ putChar '\n')+   reset++newlineIndent :: M ()+newlineIndent = do+   newline+   liftIO $ putStr "   "+   modify (first (const 3))++dot :: M ()+dot = do+   i <- gets fst+   unless (i>0 && i<60) newlineIndent+   liftIO $ putChar '.'+   modify (first (+1))++reset :: M ()+reset = modify (first (const 0))++----------------------------------------------------------------+-- Running a test suite++runTestSuite :: TestSuite -> IO ()+runTestSuite s = runTestSuiteResult s >> return ()++runTestSuiteResult :: TestSuite -> IO TestSuiteResult+runTestSuiteResult s = liftM TSR $ getDiff $ liftM snd $+   execStateT (unTSM s >> newline) (0, mempty)++----------------------------------------------------------------+-- Test Suite Result++newtype TestSuiteResult = TSR (ResultTree, TimeDiff)++type ResultTree = Tree (String, TimeDiff) (String, TestResult)++data TestResult = Ok !Int | Error String | Warning String++instance Show TestResult where+   show (Ok _)        = "Ok"+   show (Error msg)   = "Error: "   ++ msg+   show (Warning msg) = "Warning: " ++ msg++-- one-line summary+instance Show TestSuiteResult where+   show (TSR (tree, diff)) = +      let (n, nf, nw) = collectInfo tree+      in "(tests: " ++ show n ++ ", failures: " ++ show nf +++         ", warnings: " ++ show nw ++ ", " ++ formatTimeDiff diff ++ ")"++subResults :: TestSuiteResult -> [(String, TestSuiteResult)]+subResults (TSR (tree, _)) = +   let f ((s, diff), t) = (s, TSR (t, diff))+   in map f (subtrees tree)++printSummary :: TestSuiteResult -> IO ()+printSummary = putStrLn . makeSummary++makeSummary :: TestSuiteResult -> String+makeSummary result@(TSR (tree, diff)) = unlines $+   [ line+   , "Tests    : " ++ show n+   , "Failures : " ++ show nf+   , "Warnings : " ++ show nw+   , "\nTime     : " ++ formatTimeDiff diff+   , "\nSuites: "+   ] ++ map f (subResults result) +     ++ [line]+ where+   line        = replicate 75 '-'+   (n, nf, nw) = collectInfo tree+   f (name, r) = "   " ++ name ++ "   " ++ show r++printTestLog :: TestSuiteResult -> IO ()+printTestLog = putStrLn . makeTestLog++makeTestLog :: TestSuiteResult -> String+makeTestLog = unlines . makeTestLogWith formatLog++makeTestLogWith :: Monoid a => FormatLog a -> TestSuiteResult -> a+makeTestLogWith fm (TSR (tree, diff)) = formatRoot fm diff (make [] tree)+ where+   make loc = mconcat . map (either forTests forSuite) . treeToList+    where+      treeToList = +         let op (i, ys) y = +                case y of +                   Left b  -> (i, Left b:ys)+                   Right p -> (i+1, Right (loc ++ [i], p):ys)+         in reverse . snd . foldl op (1, []) . collectLevel++      forSuite (nl, ((s, d), t)) = +         formatSuite fm nl s (collectInfo t) d (make nl t)+      +      forTests [] = mempty+      forTests list@((s, result) : rest) = +         case result of            +            Warning msg -> next (formatWarning fm s msg)+            Error msg   -> next (formatFailure fm s msg)+            Ok _        ->+               let (ys, zs) = span (isOk . snd) list+                   sucs     = [ (x, n) | (x, Ok n) <- ys ]+               in formatSuccesses fm sucs `mappend` forTests zs+       where+         next a = a `mappend` forTests rest++data FormatLog a = FormatLog+   { formatRoot      :: TimeDiff -> a -> a+   , formatSuite     :: [Int] -> String -> (Int, Int, Int) -> TimeDiff -> a -> a+   , formatSuccesses :: [(String, Int)] -> a+   , formatFailure   :: String -> String -> a+   , formatWarning   :: String -> String -> a+   }++formatLog :: FormatLog [String]+formatLog = FormatLog+   { formatRoot = \td a -> +        a ++ ["\n(Total time: " ++ formatTimeDiff td ++ ")"]+   , formatSuite = \loc s _ td a -> +        [showLoc loc ++ ". " ++ s] ++ a ++ +        ["  (" ++ formatTimeDiff td ++ " for " ++ s ++ ")"]+   , formatSuccesses = \xs -> +        let f (_, n) = if n==1 then "." else "(" ++ show n ++ " tests)"+        in ["   " ++ concatMap f xs]+   , formatFailure = \s msg ->+        ["   " ++ putLabel s ++ "Error: " ++ msg]+   , formatWarning = \s msg ->+        ["   " ++ putLabel s ++ "Warning: " ++ msg]+   }+ where +   putLabel s = if null s then "" else s ++ ": "++formatTimeDiff :: TimeDiff -> String+formatTimeDiff d@(TimeDiff z1 z2 z3 h m s p)+   | any (/=0) [z1,z2,z3] = timeDiffToString d+   | s >= 60      = formatTimeDiff (timeDiff ((h*60+m)*60+s) p)+   | h==0 && m==0 = show inSec ++ " secs"+   | otherwise    = show (60*h+m) ++ ":" ++ digSec ++ " mins" + where+   milSec = 1000*toInteger s + p `div` 1000000000+   inSec  = fromIntegral milSec / 1000 :: Double+   digSec = (if s < 10 then ('0' :) else id) (show s)+   timeDiff n pc = +      let (rest, sn) = n `divMod` 60+          (hr, mr)   = rest `divMod` 60+      in TimeDiff 0 0 0 hr mr sn pc++-----------------------------------------------------+-- Utility functions++-- A sequence of leafs (Left) or labeled items (Right)+newtype Tree a b = T { unT :: S.Seq (Either b (a, Tree a b)) }++instance Monoid (Tree a b) where+   mempty = T mempty+   mappend (T a) (T b) = T (mappend a b)+  +single :: b -> Tree a b+single = T . S.singleton . Left++labeled :: a -> Tree a b -> Tree a b+labeled a t = T (S.singleton (Right (a, t)))+  +toTestResult :: Int -> Result -> TestResult+toTestResult n result = +   case result of+      Success _           -> Ok n+      Failure _ _ msg _   -> Error msg+      NoExpectedFailure _ -> Error "no expected failure"+      GaveUp i _          -> Warning ("passed only " ++ show i ++ " tests")+            +showLoc :: [Int] -> String+showLoc = concat . intersperse "." . map show++collectInfo :: Tree a (String, TestResult) -> (Int, Int, Int)+collectInfo tree = (length tests, length failures, length warnings)+ where+   tests    = flatten tree+   failures = [ msg | (_, Error msg)   <- tests ]+   warnings = [ msg | (_, Warning msg) <- tests ]++isOk :: TestResult -> Bool+isOk (Ok _) = True+isOk _      = False++subtrees :: Tree a b -> [(a, Tree a b)]+subtrees t = [ p | Right p <- collectLevel t ]++flatten :: Tree a b -> [b]+flatten t = [ b | x <- collectLevel t, b <- either id (flatten . snd) x ]++collectLevel :: Tree a b -> [Either [b] (a, Tree a b)]+collectLevel = combine [] . toList . unT+ where+   combine acc []             = f acc+   combine acc (Left a:rest)  = combine (a:acc) rest+   combine acc (Right b:rest) = f acc ++ (Right b : combine [] rest)+   +   f acc = [ Left (reverse acc) | not (null acc) ] ++getDiff :: MonadIO m => m a -> m (a, TimeDiff)+getDiff action = do+   t0 <- liftIO getClockTime+   a  <- action+   t1 <- liftIO getClockTime+   return (a, diffClockTimes t1 t0)++-- Example+{-+main :: IO ()+main = do+   r <- runTestSuiteResult $ do+      suite "A" $ do+         addProperty "p1" p1+         addProperty "p1" p1+         suite "A1" $ addProperty "p2" p2+         suite "A2" $ return ()+         addProperty "p3" p3+      suite "B" $ do+         addProperty "p4" p4+         addProperty "W" (\xs -> length (xs::[Int]) > 100 ==> True)+      suite "C" $ do+         addProperty "p5" p5+         assertTrue "sorted" (sort [3,2,1] == [1,2,3])+         fail "This is a failure"+         warn "This is a warning"+         assertEquals "eq" (sort [1,2,2]) (nub [1,2,2]) +         assertTrue "yes" True+         +   printSummary r+   printTestLog r+   --print r+   --print (subResults r)+ where      +   p1 xs = sort (xs::[Int]) == sort (sort xs)+   p2 xs = reverse (reverse xs) == (xs::[Int])+   p3 xs = head (sort xs) == minimum (xs::[Int])+   p4 xs = sort (nub xs) == nub (sort (xs::[Int]))+   p5 xs = reverse (sort xs) == sort (reverse (xs :: [Int]))++main = runTestSuite $ suite "A" $ assertIO "B" (return True) >> +   assertIO "D" (fail "boe") >> assertIO "C" (return True) -}
src/Common/Transformation.hs view
@@ -17,29 +17,27 @@ ----------------------------------------------------------------------------- module Common.Transformation     ( -- * Transformations-     Transformation(RewriteRule), makeTrans, makeTransList+     Transformation, makeTrans, makeTransList, makeRewriteTrans      -- * Arguments    , ArgDescr(..), defaultArgDescr, Argument(..)    , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1    , hasArguments, expectedArguments, getDescriptors, useArguments      -- * Rules-   , Rule, name, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule-   , ruleGroups, ruleDescription, ruleSiblings, addRuleToGroup, describe-   , rule, ruleList, ruleListF+   , Rule, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule+   , ruleGroups, ruleSiblings, addRuleToGroup+   , rule, ruleList    , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList    , idRule, checkRule, emptyRule, minorRule, buggyRule, doBefore, doAfter-   , transformations, getRewriteRules, doBeforeTrans+   , siblingOf, transformations, getRewriteRules, doBeforeTrans+   , ruleRecognizer, useRecognizer      -- * Lifting-   , ruleOnce, ruleOnce2, ruleMulti, ruleMulti2, ruleSomewhere    , liftRule, liftTrans, liftRuleIn, liftTransIn      -- * QuickCheck-   , testRule, testRuleSmart+   , testRule, propRuleSmart    ) where -import Common.Apply import Common.Rewriting-import Common.Traversable-import Common.Uniplate (Uniplate, somewhereM)+import Common.Classes import Common.Utils import Common.View import Control.Monad@@ -47,6 +45,7 @@ import Data.Maybe import Data.Ratio import Test.QuickCheck+import Common.Id  ----------------------------------------------------------- --- Transformations@@ -54,17 +53,19 @@ -- | Abstract data type for representing transformations data Transformation a    = Function (a -> [a])-   | RewriteRule (RewriteRule a)+   | RewriteRule (RewriteRule a) (a -> [a])    | Transformation a :*: Transformation a -- sequence    | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a)    | forall b c . LiftView (ViewList a (b, c)) (Transformation b)+   | Recognizer (a -> a -> Bool) (Transformation a)     instance Apply Transformation where    applyAll (Function f)        = f-   applyAll (RewriteRule r)     = rewriteM r+   applyAll (RewriteRule _ f)   = f    applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a)    applyAll (LiftView v t)      = \a -> [ build v (b, c) | (b0, c) <- match v a, b <- applyAll t b0  ]    applyAll (s :*: t)           = \a -> applyAll s a >>= applyAll t+   applyAll (Recognizer _ t)    = applyAll t     -- | Turn a function (which returns its result in the Maybe monad) into a transformation  makeTrans :: (a -> Maybe a) -> Transformation a@@ -74,6 +75,10 @@ makeTransList :: (a -> [a]) -> Transformation a makeTransList = Function +-- | Turn a rewrite rule into a transformation+makeRewriteTrans :: RewriteRule a -> Transformation a+makeRewriteTrans r = RewriteRule r (rewriteM r)+ ----------------------------------------------------------- --- Arguments @@ -158,8 +163,8 @@  -- | Returns a list of argument descriptors getDescriptors :: Rule a -> [Some ArgDescr]-getDescriptors rule =-   case transformations rule of+getDescriptors r =+   case transformations r of       [t] -> rec t       _   -> []  where @@ -167,16 +172,17 @@    rec trans =        case trans of          Abstraction args _ _ -> someArguments args-         LiftView _ t -> rec t-         s :*: t -> rec s ++ rec t+         LiftView _ t   -> rec t+         Recognizer _ t -> rec t+         s :*: t        -> rec s ++ rec t          _ -> []  -- | Returns a list of pretty-printed expected arguments. Nothing indicates that there are no such arguments expectedArguments :: Rule a -> a -> Maybe [String]-expectedArguments rule a =-   case transformations rule of-      [t] -> rec t a-      _   -> Nothing+expectedArguments r =+   case transformations r of+      [t] -> rec t+      _   -> const Nothing  where     rec :: Transformation a -> a -> Maybe [String]     rec trans a =  @@ -188,15 +194,17 @@              rec t b           s :*: t ->               rec s a `mplus` rec t a+          Recognizer _ t ->+             rec t a           _ -> Nothing  -- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are  -- invalid (not parsable), or that the wrong number of arguments was supplied useArguments :: [String] -> Rule a -> Maybe (Rule a)-useArguments list rule =-   case transformations rule of+useArguments list r =+   case transformations r of       [t] -> do new <- make t-                return rule {transformations = [new]}+                return r {transformations = [new]}       _   -> Nothing  where       make :: Transformation a -> Maybe (Transformation a)@@ -204,6 +212,7 @@       case trans of          Abstraction args _ g -> fmap g (parseArguments args list)          LiftView v t         -> fmap (LiftView v) (make t)+         Recognizer f t       -> fmap (Recognizer f) (make t)          s :*: t              -> fmap (:*: t) (make s) `mplus`                                  fmap (s :*:) (make t)          _                    -> Nothing@@ -246,8 +255,8 @@  where    showRatio  r = show (numerator r) ++ if denominator r == 1 then "" else '/' : show (denominator r)    parseRatio s = -      let readDivOp s = -             case dropWhile isSpace s of+      let readDivOp t = +             case dropWhile isSpace t of                 ('/':rest) -> return rest                 [] -> return "1"                 _  -> fail "no (/) operator" @@ -264,26 +273,29 @@  -- | 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+   { ruleId          :: Id  -- ^ Unique identifier of the rule    , transformations :: [Transformation a]    , isBuggyRule     :: Bool -- ^ Inspect whether or not the rule is buggy (unsound)    , isMinorRule     :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system)-   , ruleGroups      :: [String]-   , ruleSiblings    :: [String]+   , ruleGroups      :: [Id]+   , ruleSiblings    :: [Id]    }  instance Show (Rule a) where-   show = name+   show = showId  instance Eq (Rule a) where-   r1 == r2 = name r1 == name r2+   r1 == r2 = ruleId r1 == ruleId r2  instance Apply Rule where    applyAll r a = do        t <- transformations r       applyAll t a +instance HasId (Rule a) where+   getId        = ruleId+   changeId f r = r { ruleId = f (ruleId r) } + -- | Returns whether or not the rule is major (i.e., not minor) isMajorRule :: Rule a -> Bool isMajorRule = not . isMinorRule@@ -291,35 +303,34 @@ isRewriteRule :: Rule a -> Bool 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, Rewrite a) => String -> [f] -> Rule a-ruleList s = makeRuleList s . map (RewriteRule . rewriteRule s)+siblingOf :: HasId b => b -> Rule a -> Rule a +siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r } -ruleListF :: (BuilderList f a, Rewrite a) => String -> f -> Rule a-ruleListF s = makeRuleList s . map RewriteRule . rewriteRules s+addRuleToGroup :: HasId b => b -> Rule a -> Rule a+addRuleToGroup g r = r { ruleGroups = getId g : ruleGroups r } -rule :: (Builder f a, Rewrite a) => String -> f -> Rule a-rule s = makeRule s . RewriteRule . rewriteRule s+ruleList :: (IsId n, RuleBuilder f a, Rewrite a) => n -> [f] -> Rule a+ruleList n = makeRuleList a . map (makeRewriteTrans . rewriteRule a)+ where a = newId n+ +rule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> Rule a+rule n = makeRule a . makeRewriteTrans . rewriteRule a+ where a = newId n  -- | Turn a transformation into a rule: the first argument is the rule's name-makeRule :: String -> Transformation a -> Rule a+makeRule :: IsId n => n -> Transformation a -> Rule a makeRule n = makeRuleList n . return  -- | Turn a list of transformations into a single rule: the first argument is the rule's name-makeRuleList :: String -> [Transformation a] -> Rule a-makeRuleList n ts = Rule n [] ts False False [] []+makeRuleList :: IsId n => n -> [Transformation a] -> Rule a+makeRuleList n ts = Rule (newId n) ts False False [] []  -- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name-makeSimpleRule :: String -> (a -> Maybe a) -> Rule a+makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a makeSimpleRule n = makeRule n . makeTrans  -- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name-makeSimpleRuleList :: String -> (a -> [a]) -> Rule a+makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a makeSimpleRuleList n = makeRule n . makeTransList  -- | A special (minor) rule that always returns the identity@@ -363,76 +374,65 @@    f :: Transformation a -> [(Some RewriteRule, Bool)]    f trans =       case trans of-         RewriteRule rr -> [(Some rr, not $ isBuggyRule r)]      -         LiftView _ t   -> f t-         s :*: t        -> f s ++ f t-         _              -> []----------------------------------------------------------------- Lifting---- | Lift a rule using the Once type class-ruleOnce :: Once f => Rule a -> Rule (f a)-ruleOnce r = makeSimpleRuleList (name r) $ onceM $ applyAll r---- | Apply a rule once (in two functors)-ruleOnce2 :: (Once f, Once g) => Rule a -> Rule (f (g a))-ruleOnce2 = ruleOnce . ruleOnce+         RewriteRule rr _ -> [(Some rr, not $ isBuggyRule r)]      +         LiftView _ t     -> f t+         s :*: t          -> f s ++ f t+         _                -> [] --- | Apply at multiple locations, but at least once-ruleMulti :: (Switch f, Crush f) => Rule a -> Rule (f a)-ruleMulti r = makeSimpleRuleList (name r) $ multi $ applyAll r+ruleRecognizer :: (a -> a -> Bool) -> Rule a -> a -> a -> Bool+ruleRecognizer eq r a b = or +   [ transRecognizer eq t a b | t <- transformations r ] --- | Apply at multiple locations, but at least once (in two functors)-ruleMulti2 :: (Switch f, Crush f, Switch g, Crush g) => Rule a -> Rule (f (g a))-ruleMulti2 = ruleMulti . ruleMulti+transRecognizer :: (a -> a -> Bool) -> Transformation a -> a -> a -> Bool+transRecognizer eq trans a b =+   case trans of+      Recognizer f t -> f a b || transRecognizer eq t a b+      LiftView v t   -> +         any (`eq` b) (applyAll trans a) || or  -- ?? Quick Fix+         [ transRecognizer (\x y -> eq (f x) (f y)) t av bv+         | (av, c) <- match v a +         , (bv, _) <- match v b+         , let f z = build v (z, c)+         ]+      _ -> any (`eq` b) (applyAll trans a) -multi :: (Switch f, Crush f) => (a -> [a]) -> f a -> [f a]-multi f a =-   let g a = case f a of -                [] -> [(False, a)]-                xs -> zip (repeat True) xs-       xs = switch (fmap g a)-       p = any fst . crush-   in map (fmap snd) (filter p xs)+useRecognizer :: (a -> a -> Bool) -> Transformation a -> Transformation a+useRecognizer = Recognizer -ruleSomewhere :: Uniplate a => Rule a -> Rule a-ruleSomewhere r = makeSimpleRuleList (name r) $ somewhereM $ applyAll r+-----------------------------------------------------------+--- Lifting  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 :: (Crush m, Monad m) => ViewM m a (b, c) -> Transformation b -> Transformation a liftTransIn = LiftView . viewList  liftRule :: View a b -> Rule b -> Rule a liftRule v = liftRuleIn (v &&& identity)  -liftRuleIn :: Crush m => ViewM m a (b, c) -> Rule b -> Rule a+liftRuleIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Rule b -> Rule a liftRuleIn v r = r-   { transformations = map (liftTransIn v) (transformations r)-   }+   { transformations = map (liftTransIn v) (transformations r) }  ----------------------------------------------------------- --- QuickCheck  -- | Check the soundness of a rule: the equality function is passed explicitly testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO ()-testRule eq rule = -   quickCheck (propRule eq rule arbitrary)+testRule eq r = +   quickCheck (propRule eq r arbitrary)  -- | Check the soundness of a rule and use a "smart generator" for this. The smart generator  -- behaves differently on transformations constructed with a (|-), and for these transformations, -- the left-hand side patterns are used (meta variables are instantiated with random terms)-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))+propRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property+propRuleSmart eq r = propRule eq r . smartGen r    propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property-propRule eq rule gen = +propRule eq r gen =     forAll gen $ \a -> -   forAll (smartApplyRule rule a) $ \ma -> +   forAll (smartApplyRule r a) $ \ma ->        isJust ma ==> (a `eq` fromJust ma)  smartGen :: Rule a -> Gen a -> Gen a@@ -444,7 +444,7 @@ smartGenTrans :: a -> Transformation a -> [Gen a] smartGenTrans a trans =    case trans of-      RewriteRule r -> return (smartGenerator r)+      RewriteRule r _ -> return (smartGenerator r)       LiftView v t -> do          (b, c) <- match v a          gen    <- smartGenTrans b t
− src/Common/Traversable.hs 
@@ -1,135 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Common.Traversable -   ( Once(..), Switch(..), Crush(..), OnceJoin(..), useOnceJoin-   ) where--import Control.Monad.Identity-import qualified Data.IntMap as IM-import qualified Data.Map as M--{- Examples:--once (^2) [1..3]-   ~>  [[1,2,3],[1,4,3],[1,2,9]]--onceM (\x -> [x+1, x^2]) [1..3]-   ~>  [[2,2,3],[1,2,3],[1,3,3],[1,4,3],[1,2,4],[1,2,9]]--onceJoin (\x -> [x+1, x^2]) [1..3]-   ~>  [[2,1,2,3],[1,3,4,3],[1,2,4,9]]--onceJoinM (\x -> [[x+1], [x^2, x^3]]) [1..3]-   ~>  [[2,2,3],[1,1,2,3],[1,3,3],[1,4,8,3],[1,2,4],[1,2,9,27]]--}---------------------------------------------------------------- * Type class |Once|--class Functor f => Once f where-   -- | Apply a function once in a given structure-   once :: (a -> a) -> f a -> [f a]-   -- | Apply a monadic function once in a given structure-   onceM :: MonadPlus m => (a -> m a) -> f a -> m (f a)-   -   -- default definition-   once f = onceM (return . f)--instance Once [] where-   onceM = useOnceJoin-   -instance Once Maybe where-   onceM = useOnceJoin-   -instance Once Identity where-   onceM = useOnceJoin--instance Eq a => Once (M.Map a) where-   onceM f m = liftM M.fromAscList (onceM g (M.toList m))-    where g (a, b) = liftM (\c -> (a, c)) (f b)--instance Once IM.IntMap where-   onceM f m = liftM IM.fromAscList (onceM g (IM.toList m))-    where g (a, b) = liftM (\c -> (a, c)) (f b)--useOnceJoin :: (OnceJoin f, MonadPlus m) => (a -> m a) -> f a -> m (f a)-useOnceJoin f = onceJoinM (liftM return . f)---------------------------------------------------------------- * Type class |Switch|--class Functor f => Switch f where-   switch :: Monad m => f (m a) -> m (f a)-         -instance Switch [] where-   switch = sequence--instance Switch Maybe where-   switch = maybe (return Nothing) (liftM Just)--instance Switch Identity where-   switch (Identity m) = liftM Identity m--instance Eq a => Switch (M.Map a) where-   switch m = do-      let (ns, ms) = unzip (M.toList m)-      as <- sequence ms -      return $ M.fromAscList $ zip ns as--instance Switch IM.IntMap where-   switch m = do-      let (ns, ms) = unzip (IM.toList m)-      as <- sequence ms -      return $ IM.fromAscList $ zip ns as---------------------------------------------------------------- * Type class |Crush|--class Functor f => Crush f where-   crush :: f a -> [a]--instance Crush [] where-   crush = id--instance Crush Maybe where-   crush = maybe [] return--instance Crush Identity where-   crush = return . runIdentity--instance Crush (M.Map a) where-   crush = M.elems--instance Crush IM.IntMap where-   crush = IM.elems---------------------------------------------------------------- * Type class |OnceJoin|--class (Once f, Monad f) => OnceJoin f where-   -- | Apply a function once in a given structure, join the result afterwards-   onceJoin :: (a -> f a) -> f a -> [f a]-   -- | Apply a monadic function once in a given structure, join the result afterwards-   onceJoinM :: MonadPlus m => (a -> m (f a)) -> f a -> m (f a)--   -- default definition-   onceJoin f = onceJoinM (return . f)--instance OnceJoin [] where-   onceJoinM _ []     = mzero -   onceJoinM f (x:xs) = liftM (++xs) (f x) `mplus` liftM (x:) (onceJoinM f xs)--instance OnceJoin Maybe where-   onceJoinM = maybe mzero-   -instance OnceJoin Identity where-   onceJoinM f = f . runIdentity
src/Common/Uniplate.hs view
@@ -8,26 +8,30 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) ----- This module defines the Uniplate type class, and some utility functions. It--- should be replaced in future by the original Uniplate library.+-- Exports a subset of Data.Generics.Uniplate -- ------------------------------------------------------------------------------module Common.Uniplate (-     -- * Uniplate type class and utility functions-     Uniplate(..)-   , universe, subtermsAt, children, child-   , getTermAt, applyTo, applyToM, applyAt, applyAtM-   , transform, transformM, transformTD, rewrite, rewriteM-   , somewhere, somewhereM-   , compos+module Common.Uniplate+   ( -- * Uniplate type class and utility functions+     Uniplate(..), universe, children, holes+   , transform, transformM, descend, descendM, rewrite, rewriteM+     -- * Additional functions+   , leafs    ) where-   ++import Data.Generics.Uniplate++leafs :: Uniplate a => a -> [a]+leafs a = case children a of+             [] -> [a]+             xs -> concatMap leafs xs++{- --------------------------------------------------------- -- Uniplate class for generic traversals  import Common.Utils (safeHead) import Control.Monad- -- | The Uniplate type class offers some light-weight functions for generic traversals. Only -- a minimal set of operations are supported class Uniplate a where@@ -37,21 +41,50 @@ universe :: Uniplate a => a -> [a] universe a = a : [ c | b <- children a, c <- universe b ] --- | Like universe, but also returns the location of the subterm-subtermsAt :: Uniplate a => a -> [([Int], a)]-subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ]- -- | Returns all the immediate children of a term children :: Uniplate a => a -> [a] children = fst . uniplate --- | Selects one immediate child of a term. Nothing indicates that the child does not exist-child :: Uniplate a => Int -> a -> Maybe a-child n = safeHead . drop n . children -               +-- | A bottom-up transformation+transform :: Uniplate a => (a -> a) -> a -> a+transform g a = g $ f $ map (transform g) cs+ where+   (cs, f) = uniplate a++-- | Monadic variant of transform+transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a+transformM g a = mapM (transformM g) cs >>= (g . f)+ where+   (cs, f) = uniplate a++-- | Applies a function to its immediate children+descend :: Uniplate a => (a -> a) -> a -> a+descend g a = +   let (cs, f) = uniplate a+   in f (map g cs)++-- | Applies the function at a position until this is no longer possible+rewrite :: Uniplate a => (a -> Maybe a) -> a -> a+rewrite f = transform g+    where g x = maybe x (rewrite f) (f x)++-- | Monadic variant of rewrite+rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a+rewriteM f = transformM g+    where g x = f x >>= maybe (return x) (rewriteM f)++---------------------------------------------------------+-- Additional functions++-- | Like universe, but also returns the location of the subterm+subtermsAt :: Uniplate a => a -> [([Int], a)]+subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ]+          -- | Selects a child based on a path. Nothing indicates that the path is invalid getTermAt :: Uniplate a => [Int] -> a -> Maybe a getTermAt is a = foldM (flip child) a is+ where+   child n = safeHead . drop n . children   -- | Apply a function to one immediate child. applyTo :: Uniplate a => Int -> (a -> a) -> a -> a@@ -75,34 +108,6 @@ applyAtM :: (Monad m, Uniplate a) => [Int] -> (a -> m a) -> a -> m a applyAtM is f = foldr applyToM f is --- | A bottom-up transformation-transform :: Uniplate a => (a -> a) -> a -> a-transform g a = g $ f $ map (transform g) cs- where-   (cs, f) = uniplate a---- | Monadic variant of transform-transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a-transformM g a = mapM (transformM g) cs >>= (g . f)- where-   (cs, f) = uniplate a---- | A top-down transformation-transformTD :: Uniplate a => (a -> a) -> a -> a-transformTD g a = -   let (cs, f) = uniplate (g a)-   in f (map (transformTD g) cs)-   --- | Applies the function at a position until this is no longer possible-rewrite :: Uniplate a => (a -> Maybe a) -> a -> a-rewrite f = transform g-    where g x = maybe x (rewrite f) (f x)---- | Monadic variant of rewrite-rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a-rewriteM f = transformM g-    where g x = f x >>= maybe (return x) (rewriteM f)- somewhere :: Uniplate a => (a -> a) -> a -> [a] somewhere f = somewhereM (return . f) @@ -111,7 +116,4 @@  where     n   = length (children a)    g i = applyToM i (somewhereM f) a---- | The compos function-compos :: Uniplate b => a -> (a -> a -> a) -> (b -> a) -> b -> a-compos zero combine f = foldr (combine . f) zero . children+-}
src/Common/Utils.hs view
@@ -20,7 +20,6 @@ import Data.Ratio import System.Random import Test.QuickCheck-import qualified Data.Map as M  data Some f = forall a . Some (f a) @@ -30,9 +29,6 @@ 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@@ -47,7 +43,7 @@ stringToHex :: String -> Maybe Int stringToHex = foldl op (Just 0)  where-   op (Just i) c = fmap (\j -> i*16 + j) (charToHex c)+   op (Just i) c = fmap (i*16+) (charToHex c)    op Nothing  _ = Nothing  charToHex :: Char -> Maybe Int@@ -70,6 +66,10 @@ distinct []     = True distinct (x:xs) = all (/=x) xs && distinct xs  +allsame :: Eq a => [a] -> Bool+allsame []     = True+allsame (x:xs) = all (==x) xs+ safeHead :: [a] -> Maybe a safeHead (x:_) = return x safeHead _     = Nothing@@ -99,56 +99,30 @@       Just (xs, ys) -> xs : splitsWithElem c ys       Nothing       -> [s] +splitAtSequence :: Eq a => [a] -> [a] -> Maybe ([a], [a])+splitAtSequence cs = f []+ where+   f _   [] = Nothing+   f acc list@(x:xs)+      | cs `isPrefixOf` list = Just (reverse acc, drop (length cs) list)+      | otherwise            = f (x:acc) xs+ -- | Use a fixed standard "random" number generator. This generator is -- accessible by calling System.Random.getStdGen useFixedStdGen :: IO () useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} +fst3 :: (a, b, c) -> a fst3 (x, _, _) = x++snd3 :: (a, b, c) -> b snd3 (_, x, _) = x++thd3 :: (a, b, c) -> c thd3 (_, _, x) = x  commaList :: [String] -> String commaList = concat . intersperse ", "--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 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--}  -- | Prevents a bias towards small numbers ratioGen :: Integral a => Int -> Int -> Gen (Ratio a)
src/Common/View.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -8,12 +9,13 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) ----- This module defines views on data-types+-- This module defines views on data-types, as described in "Canonical Forms+-- in Interactive Exercise Assistants" -- ----------------------------------------------------------------------------- module Common.View     ( -- * Generalized monadic views-     ViewM, match, build, makeView, biArr, identity, (>>>)+     ViewM, match, build, newView, makeView, biArr, identity, (>>>)    , canonical, canonicalWith    , Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)      -- * Simple views@@ -21,13 +23,14 @@    , simplify, simplifyWith, viewEquivalent, viewEquivalentWith    , isCanonical, isCanonicalWith, matchM, canonicalM, viewList      -- * Some combinators-   , listView, switchView, ( #> ), associativeView+   , swapView, listView, switchView, associativeView      -- * Properties on views    , propIdempotence, propSoundness, propNormalForm    ) where -import Common.Traversable-import Control.Arrow hiding ((>>>))+import Common.Id+import Common.Classes+import Control.Arrow import Control.Monad import Data.Maybe import Test.QuickCheck@@ -36,81 +39,82 @@ ---------------------------------------------------------------------------------- -- 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  ---         (but only for b that have at least one "a")------ Derived property: simplification is idempotent--data ViewM m a b = ViewM-   { match :: a -> m b-   , build :: b -> a-   }--makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b-makeView = ViewM--biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b-biArr f g = makeView (return . f) g--canonical :: Monad m => ViewM m a b -> a -> m a-canonical = canonicalWith id--canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a-canonicalWith f view = liftM (build view . f) . match view-------------------------------------------------------------------- Arrow combinators--identity :: Monad m => ViewM m a a -identity = makeView return id--(>>>) :: 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)+data ViewM m a b where+   Prim    :: Id -> (a -> m b) -> (b -> a) -> ViewM m a b+   (:>>>:) :: ViewM m a b -> ViewM m b c -> ViewM m a c +   First   :: ViewM m a b -> ViewM m (a, c) (b, c)+   Second  :: ViewM m b c -> ViewM m (a, b) (a, c)+   (:***:) :: ViewM m a c -> ViewM m b d -> ViewM m (a, b) (c, d)+   (:&&&:) :: ViewM m a b -> ViewM m a c -> ViewM m a (b, c)+   VLeft   :: ViewM m a b -> ViewM m (Either a c) (Either b c)+   VRight  :: ViewM m b c -> ViewM m (Either a b) (Either a c)+   (:+++:) :: ViewM m a c -> ViewM m b d -> ViewM m (Either a b) (Either c d)+   (:|||:) :: ViewM m a c -> ViewM m b c -> ViewM m (Either a b) c  instance Monad m => C.Category (ViewM m) where    id    = identity-   v . w = w >>> v-   +   v . w = w :>>>: v+ instance Monad m => Arrow (ViewM m) where-   arr f = biArr f (error "Control.View.arr: function is not invertible")+   arr f  = Prim (newId "views.arr") (return . f) (error "Control.View.arr: function is not invertible")+   first  = First+   second = Second+   (***)  = (:***:)+   (&&&)  = (:&&&:) -   first v = makeView -      (\(a, c) -> match v a >>= \b -> return (b, c)) -      (first (build v))+instance Monad m => ArrowChoice (ViewM m) where+   left  = VLeft+   right = VRight+   (+++) = (:+++:)+   (|||) = (:|||:) -   second v = makeView -      (\(a, b) -> match v b >>= \c -> return (a, c)) -      (second (build v))+----------------------------------------------------------------------------------+-- Operations on a view -   v *** w = makeView -      (\(a, c) -> liftM2 (,) (match v a) (match w c)) -      (build v *** build w)+-- The preferred way of constructing a view+newView :: (IsId n, Monad m) => n -> (a -> m b) -> (b -> a) -> ViewM m a b+newView = Prim . newId -   -- left-biased builder-   v &&& w = makeView -      (\a -> liftM2 (,) (match v a) (match w a)) -      (\(b, _) -> build v b)+makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b+makeView = newView "views.makeView" -instance Monad m => ArrowChoice (ViewM m) where-   left v = makeView -      (either (liftM Left . match v) (return . Right)) -      (either (Left . build v) Right)+biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b+biArr f = makeView (return . f) -   right v = makeView -      (either (return . Left) (liftM Right . match v)) -      (either Left (Right . build v))+match :: Monad m => ViewM m a b -> a -> m b+match view =+   case view of+      Prim _ f _ -> f+      v :>>>: w  -> \a      -> match v a >>= match w+      First v    -> \(a, c) -> match v a >>= \b -> return (b, c)+      Second v   -> \(a, b) -> match v b >>= \c -> return (a, c)+      v :***: w  -> \(a, c) -> liftM2 (,) (match v a) (match w c)+      v :&&&: w  -> \a      -> liftM2 (,) (match v a) (match w a)+      VLeft v    -> either (liftM Left . match v) (return . Right)+      VRight v   -> either (return . Left) (liftM Right . match v)+      v :+++: w  -> either (liftM Left . match v) (liftM Right . match w)+      v :|||: w  -> either (match v) (match w) -   v +++ w = makeView -      (either (liftM Left . match v) (liftM Right . match w))  -      (either (Left . build v) (Right . build w))+build :: ViewM m a b -> b -> a+build view = +   case view of+      Prim _ _ f -> f+      v :>>>: w  -> build v . build w+      First v    -> first (build v)+      Second v   -> second (build v)+      v :***: w  -> build v *** build w+      v :&&&: _  -> build v . fst -- left-biased+      VLeft v    -> either (Left . build v) Right+      VRight v   -> either Left (Right . build v)+      v :+++: w  -> either (Left . build v) (Right . build w)+      v :|||: _  -> Left . build v -- left-biased -   -- left-biased builder-   v ||| w = makeView -      (either (match v) (match w))-      (Left . build v)+canonical :: Monad m => ViewM m a b -> a -> m a+canonical = canonicalWith id +canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a+canonicalWith f view = liftM (build view . f) . match view+ --------------------------------------------------------------- -- Simple views (based on a particular monad) @@ -150,23 +154,27 @@ 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 :: (Crush m, Monad m) => ViewM m a b -> ViewList a b viewList v = makeView (crush . match v) (build v)  --------------------------------------------------------------- -- Some combinators +identity :: Monad m => ViewM m a a +identity = newView "views.identity" return id++swapView :: View (a, b) (b, a)+swapView = +   let swap (a, b) = (b, a)+   in newView "views.swap" (return . swap) swap+ listView :: Monad m => ViewM m a b -> ViewM m [a] [b] listView v = makeView (mapM (match v)) (map (build v))  switchView :: (Monad m, Switch f) => ViewM m a b -> ViewM m (f a) (f b) switchView v = makeView (switch . fmap (match v)) (fmap (build v))--( #> ) :: 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 :: View a (a, a) -> ViewList a (a, a) associativeView v = makeView (reverse . f) (build v)  where f a =           case matchM v a of@@ -189,3 +197,21 @@     propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property propNormalForm g v = forAll g $ \a -> a == simplify v a++{- proving a parameterized view equivalent to one with a "context"++abstr1 :: (a -> View b c) -> View (a, b) (a, c)+abstr1 fun = makeView f g+ where+   f (a, b) = do+      c <- match (fun a) b+      return (a, c)+   g (a, c) = (a, build (fun a) c)+   +abstr2 :: View (a, b) (a, c) -> (a -> View b c)+abstr2 v a = makeView f g+ where+   f b = do +      (_, c) <- match v (a, b)+      return c+   g c = snd (build v (a, c)) -}
src/Documentation/DefaultPage.hs view
@@ -11,17 +11,14 @@ ----------------------------------------------------------------------------- module Documentation.DefaultPage where -import Common.Context import Common.Exercise-import Common.Transformation import Control.Monad import Service.DomainReasoner-import Service.ServiceList+import Service.Types 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@@ -45,19 +42,18 @@       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"+header level = do +   divClass "menu" $ do+      make exerciseOverviewPageFile  "Exercises"+      make "services.html"           "Services"+      make "tests.html"              "Tests"+      make "coverage/hpc_index.html" "Coverage"+      make "api/index.html"          "API"    hr-+ where+   make target s = f $ link (up level ++ target) $ text s+   f m = spaces 3 >> text "[" >> space >> m >> space >> text "]" >> spaces 3+    footer :: String -> HTMLBuilder footer version = do     hr @@ -69,62 +65,33 @@ findTitle :: HTMLBuilder -> String findTitle = maybe "" XML.getData . XML.findChild "h1" . XML.makeXML "page" +filePathId :: HasId a => a -> FilePath+filePathId a = foldr (\x y -> x ++ "/" ++ y) (unqualified a) (qualifiers a)+ ------------------------------------------------------------ -- Paths and files -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"+exerciseOverviewPageFile, exerciseOverviewAllPageFile, +   serviceOverviewPageFile, testsPageFile :: String -exerciseOverviewAllPageFile :: String+exerciseOverviewPageFile    = "exercises.html" 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"+serviceOverviewPageFile     = "services.html"+testsPageFile               = "tests.html" -exerciseDerivationsFile :: ExerciseCode -> String-exerciseDerivationsFile code = -   exercisePagePath code-   ++ filter (not . isSpace) (identifier code)-   ++ "-derivations.html"+exercisePageFile, exerciseDerivationsFile, exerciseStrategyFile,+   exerciseDiagnosisFile, ruleFile :: HasId a => a -> FilePath+exercisePageFile        a = filePathId a ++ ".html"+exerciseDerivationsFile a = filePathId a ++ "-derivations.html"+exerciseStrategyFile    a = filePathId a ++ "-strategy.html"+exerciseDiagnosisFile   a = filePathId a ++ "-diagnosis.html"+ruleFile                a = filePathId ("rule" # getId a) ++ ".html"  servicePageFile :: Service -> String-servicePageFile srv = servicePagePath ++ serviceName srv ++ ".html"+servicePageFile srv = "services/" ++ filePathId srv ++ ".html"++diagnosisExampleFile :: Id -> String+diagnosisExampleFile a = "examples/" ++ showId a ++ ".txt"  ------------------------------------------------------------ -- Utility functions
+ src/Documentation/DerivationUnitTests.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------
+-- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Documentation.DerivationUnitTests (main) where
+
+import Control.Monad
+import Common.Exercise
+import Text.XML
+import Domain.Math.Power.Exercises
+
+base = "test/dwo-derivations"
+
+main = make powerOfAExercise
+
+make :: Exercise a -> IO ()
+make ex = zipWithM_ (makeTest ex) [1 ..] (examples ex)
+
+makeTest :: Exercise a -> Int -> a -> IO ()
+makeTest ex n a = do
+   let file = base ++ "/" ++ show (exerciseCode ex) ++ show n ++ ".xml"
+   putStrLn $ "Writing " ++ file
+   writeFile file $ showXML $ makeRequest a ex
+
+makeRequest :: a -> Exercise a -> XML
+makeRequest a ex = makeXML "request" $ do
+   "service"    .=. "derivation"
+   "exerciseid" .=. show (exerciseCode ex)
+   "encoding"   .=. "string"
+   element "state" $ 
+      element "expr" $
+         text $ prettyPrinter ex a
src/Documentation/ExercisePage.hs view
@@ -11,73 +11,89 @@ ----------------------------------------------------------------------------- module Documentation.ExercisePage (makeExercisePage) where +import Common.Context import Common.Exercise+import Common.Derivation import Common.Strategy hiding (not, replicate) import Common.Transformation-import Service.ExercisePackage-import Service.StrategyInfo-import Service.DomainReasoner-import Service.TypedAbstractService hiding (exercise)+import Common.Utils (Some(..), splitAtSequence) import Control.Monad+import Data.Char import Data.List-import Common.Utils (commaList, Some(..)) import Data.Maybe+import Documentation.DefaultPage+import Documentation.RulePresenter+import Service.BasicServices+import Service.Diagnose+import Service.DomainReasoner+import Service.ExercisePackage+import Service.State+import Service.StrategyInfo+import System.Directory import System.Random-import 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)+   let ex       = exercise pkg+       make     = makeId pkg+       makeId a = generatePageAt (length (qualifiers a)) dir . ($ (getId a))+       exFile   = dir ++ "/" ++ diagnosisExampleFile (getId ex)++   exampleFileExists <- liftIO (doesFileExist exFile)++   make exercisePageFile     (exercisePage exampleFileExists pkg)    make exerciseStrategyFile (strategyPage ex)-   make exerciseRulesFile    (rulesPage ex)    unless (null (examples (exercise pkg))) $        make exerciseDerivationsFile (derivationsPage ex)+   when (exampleFileExists) $ do+      xs <- liftIO (readFile exFile)+      make exerciseDiagnosisFile (diagnosisPage xs pkg)+    `catchError` \_ -> return () -exercisePage :: ExercisePackage a -> HTMLBuilder-exercisePage pkg = do-   h1 (description ex)+exercisePage :: Bool -> ExercisePackage a -> HTMLBuilder+exercisePage exampleFileExists pkg = do+   idboxHTML "strategy" (getId pkg)        h2 "1. General information"-   table -      [ [bold $ text "Code",   ttText (show $ exerciseCode ex)]-      , [bold $ text "Status", text (show $ status ex)]-      , [ bold $ text "OpenMath support"++   let bolds (x:xs) = bold x:xs+       bolds []     = []++   table $ map bolds+      [ [ text "Code",   ttText (showId ex)]+      , [ text "Status", text (show $ status ex)]+      , [ text "Strategy"+        , link (up level ++ exerciseStrategyFile exid) $+             text (showId $ strategy ex)+        ]+      , [ text "OpenMath support"         , text $ showBool $ withOpenMath pkg         ]-      , [ bold $ text "Textual feedback"+      , [ text "Textual feedback"         , text $ showBool $ isJust $ getExerciseText pkg         ]-      , [ bold $ text "Restartable strategy"+      , [ text "Restartable strategy"         , text $ showBool $ canBeRestarted ex         ] -      , [ bold $ text "Exercise generator"+      , [ text "Exercise generator"         , text $ showBool $ isJust $ randomExercise ex         ]-      , [ bold $ text "Examples"+      , [ 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)+   let rs  = rulesInStrategy (strategy ex)+       ups = up (length (qualifiers pkg)) +       f r = [ link (ups ++ ruleFile r) $ ttText (showId r)              , text $ showBool $ isBuggyRule r              , text $ showBool $ hasArguments r              , text $ showBool $ r `elem` rs-             , text $ concat $ intersperse "," (ruleGroups r)+             , text $ concat $ intersperse "," $ map showId $ ruleGroups r              , when (isRewriteRule r) $-                  image (ruleImageFileHere ex r)+                  ruleToHTML (Some ex) r              ]    table ( [bold $ text "Rule name", bold $ text "Buggy"            , bold $ text "Args" @@ -86,95 +102,107 @@            ]          : map f (ruleset ex)          )-   para $ link (up 2 ++ exerciseRulesFile code) $-      text "See rule details"-   -   +   when exampleFileExists $ do+      para $ link (up level ++ exerciseDiagnosisFile exid) $ do+         br+         text "See diagnosis examples"+    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")+   let state = generateWith (mkStdGen 0) pkg 5+   derivationHTML ex (stateTerm state)+   para $ unless (null (examples ex)) $ +      link (up level ++ exerciseDerivationsFile exid) (text "More examples")  where-   ex   = exercise pkg-   code = exerciseCode ex+   ex    = exercise pkg+   exid  = getId ex+   level = length (qualifiers pkg)  strategyPage :: Exercise a -> HTMLBuilder strategyPage ex = do    h1 title    h2 "1. Representation in XML"-   preText (XML.showXML (strategyToXML (strategy ex)))+   highlightXML True (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) '.')+   let f (loc, a) = +          [text (show loc), indent (length loc) >> text (showId a)]+       indent n = text (replicate (3*n) '.')    table ( [bold $ text "Location", bold $ text "Label"]           : map f (strategyLocations (strategy ex))          )  where-   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+   title = "Strategy for " ++ showId 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+   forM_ (zip [1::Int ..] (examples ex)) $ \(i, a) -> do       h2 (show i ++ ".")-      preText d+      derivationHTML ex a++derivationHTML :: Exercise a -> a -> HTMLBuilder+derivationHTML ex a = divClass "derivation" $ do +   pre $ derivationM (forStep ups) (forTerm ex) der+   unless (ok der) $+      divClass "error" $ text "<<not ready>>"  where-   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+   ups = length (qualifiers ex)+   der = derivationDiffEnv (defaultDerivation ex a)+   ok  = maybe False (isReady ex) . fromContext . last . terms++idboxHTML :: String -> Id -> HTMLBuilder+idboxHTML kind i = divClass "idbox" $ do+   font "id" $ ttText (showId i)+   spaces 3+   text $ "(" ++ kind ++ ")"+   unless (null $ description i) $ do+      br+      italic (text (description i))++diagnosisPage :: String -> ExercisePackage a -> HTMLBuilder+diagnosisPage xs pkg = do+   h1 ("Diagnosis examples for " ++ showId pkg)+   forM_ (zip [1::Int ..] (mapMaybe f (lines xs))) $ \(i, (t0, t1, expl)) -> do +      h2 (show i ++ ".")+      preText (t0 ++ "\n  =>\n" ++ t1)+      para $ do+         unless (null expl) $ do +            bold $ text "Description:"+            space+            text expl+            br+            bold $ text "Diagnosis:"+            space+            text (getDiagnosis t0 t1)+ where+   ex  = exercise pkg+   f a = do +      (x, b) <- splitAtSequence "==>" a+      let (y, z) = fromMaybe (b, "") (splitAtSequence ":::" b)+          trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+      return (trim x, trim y, trim z)+      +   getDiagnosis t0 t1 = +      case (parser ex t0, parser ex t1) of+         (Left msg, _) -> "parse error (before): " ++ msg+         (_, Left msg) -> "parse error (afterr): " ++ msg+         (Right a, Right b) -> show (diagnose (emptyState pkg a) b)+       +forStep :: HasId a => Int -> (a, Environment) -> HTMLBuilder  +forStep n (i, env) = do +      spaces 3+      text "=>"+      space+      let target = up n ++ ruleFile i+          make | null (description i) = link target+               | otherwise = linkTitle target (description i)+      make (text (unqualified i))+      br+      unless (nullEnv env) $ do+         spaces 6+         text (show env)+         br++forTerm :: Exercise a -> Context a -> HTMLBuilder+forTerm ex ca = do+   text (prettyPrinterContext ex ca)+   br
− src/Documentation/LatexRules.hs 
@@ -1,140 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module 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
@@ -11,27 +11,51 @@ -----------------------------------------------------------------------------
 module Documentation.Make (DocItem(..), makeDocumentation) where
 
+import Common.TestSuite
 import Common.Utils (Some(..))
+import Control.Monad
+import Data.Maybe
 import Service.DomainReasoner
 import Documentation.SelfCheck
-import Documentation.LatexRules
 import Documentation.ExercisePage
+import Documentation.RulePage
+import Documentation.TestsPage
 import Documentation.ServicePage
 import Documentation.OverviewPages
 
-data DocItem = Pages String | LatexRules String | SelfCheck String
+data DocItem = Pages | SelfCheck | BlackBox (Maybe 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+makeDocumentation :: String -> String -> DocItem -> DomainReasoner ()
+makeDocumentation docDir testDir item =
+   case item of
+      Pages -> do 
+         report "Generating overview pages"
+         makeOverviewExercises docDir
+         makeOverviewServices  docDir
+         report "Generating exercise pages"
+         pkgs <- getPackages
+         forM_ pkgs $ \(Some pkg) -> 
+            makeExercisePage docDir pkg
+         report "Generating rule pages"
+         makeRulePages docDir
+         report "Generating service pages"
+         getServices >>= mapM_ (makeServicePage docDir)
+         report "Running tests"
+         makeTestsPage docDir testDir
+      SelfCheck -> do
+         checks <- selfCheck testDir
+         result <- liftIO (runTestSuiteResult checks)
+         liftIO (printSummary result)
+      BlackBox mdir -> do
+         run    <- runWithCurrent
+         checks <- liftIO $ blackBoxTests run (fromMaybe testDir mdir)
+         result <- liftIO $ runTestSuiteResult checks
+         liftIO (printSummary result)
+         
+report :: String -> DomainReasoner ()
+report s = liftIO $ do
+   let line = replicate 75 '-'
+   putStrLn line
+   putStrLn ("--- " ++ s)
+   putStrLn line
src/Documentation/OverviewPages.hs view
@@ -16,11 +16,12 @@ import Documentation.DefaultPage import Data.Char import Data.List+import Data.Maybe import Control.Monad-import Common.Utils (Some(..))+import Common.Utils (Some(..), safeHead) import Common.Exercise-import Service.ServiceList import Service.DomainReasoner+import Service.Types import Text.HTML  makeOverviewExercises :: String -> DomainReasoner ()@@ -47,40 +48,40 @@          text "all exercises"       text ", including the ones under development"       -   forM_ (zip [1..] groupedList) $ \(i, (dom, xs)) -> do+   forM_ (zip [1::Int ..] (grouping list)) $ \(i, (dom, xs)) -> do       h2 (show i ++ ". " ++ dom)-      noBorderTable (map makeRow xs) +      table (map makeRow xs)   where    title | showAll   = "All exercises"          | otherwise = "Exercises"      makeRow (Some ex) = -      [ do tt bullet >> space-           link (exercisePageFile code) $ ttText (show code)+      [ link (exercisePageFile code) $ ttText (show code)       , do spaces 10            f (status ex)            spaces 10       , text $ description ex       ]     where-      code = exerciseCode ex+      code = getId ex       f st = italic $ text ("(" ++ map toLower (show st) ++ ")") -   groupedList = process list+   grouping = map g . groupBy eq . sortBy cmp . filter p     where-      process = map g . groupBy eq . sortBy cmp . filter p-    -      cmp (Some a) (Some b) = exerciseCode a `compare` exerciseCode b+      cmp (Some a) (Some b) = compareId (exerciseId a) (exerciseId b)       eq a b      = f a == f b-      f (Some ex) = domain (exerciseCode ex)-      g xs = (f (head xs), xs)+      f (Some ex) = safeHead (qualifiers (exerciseId ex))+      g xs        = (fromMaybe "" (f (head xs)), xs)       p (Some ex) = showAll || isPublic ex  serviceOverviewPage :: [Service] -> HTMLBuilder serviceOverviewPage list = do    h1 "Services"-   let 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)"+   let (xs, ys) = partition serviceDeprecated (sortBy compareId list)+       make s   = link (servicePageFile s) (ttText (showId s))+   ul $ map make ys+   unless (null xs) $ do+      h2 "Deprecated"+      ul $ map make xs++
+ src/Documentation/RulePage.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Documentation.RulePage (makeRulePages) where++import Common.Context+import Common.Exercise+import Common.Transformation+import Common.Utils (commaList, Some(..))+import Control.Monad+import Data.List+import Documentation.DefaultPage+import Documentation.RulePresenter+import Service.DomainReasoner+import Service.ExercisePackage+import Service.RulesInfo (rewriteRuleToFMP, collectExamples, ExampleMap)+import Text.HTML+import Text.OpenMath.FMP+import Text.OpenMath.Object+import qualified Data.Map as M+import qualified Text.XML as XML++data ExItem a = EI (ExercisePackage a) (ExampleMap a)++makeRulePages :: String -> DomainReasoner ()+makeRulePages dir = do+   pkgs <- getPackages +   let exMap = M.fromList +          [ (getId pkg, Some (EI pkg (collectExamples (exercise pkg))))+          | Some pkg <- pkgs+          ]+       ruleMap = M.fromListWith (++)+          [ (getId r, [Some pkg]) +          | Some pkg <- pkgs+          , r <- ruleset (exercise pkg) +          ]+   forM_ (M.toList ruleMap) $ \(ruleId, list@(Some pkg:_)) -> do+      let noExamples = Some (EI pkg M.empty) +          level      = length (qualifiers ruleId) + 1+          usedIn     = sortBy compareId [ getId pkg1 | Some pkg1 <- list ]+      case M.findWithDefault noExamples (getId pkg) exMap of+         Some (EI pkg1 e) -> do+            let ex = exercise pkg1+            forM_ (getRule ex ruleId) $ \r ->+               generatePageAt level dir (ruleFile ruleId) $+                  rulePage ex e usedIn r++rulePage :: Exercise a -> ExampleMap a -> [Id] ->  Rule (Context a) -> HTMLBuilder+rulePage ex exMap usedIn r = do+   idboxHTML "rule" (getId r)+   let idList = text . commaList . map showId+   para $ table +      [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)]+      , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)]+      , [bold $ text "Groups", idList $ ruleGroups r]+      , [bold $ text "Siblings", idList $ ruleSiblings r] +      ]+   when (isRewriteRule r) $ para $+      ruleToHTML (Some ex) r++   h3 "Used in exercises"+   let f a = link (up ups ++ exercisePageFile a) (tt $ text $ show a)+       ups = length (qualifiers r) + 1+   ul $ map f usedIn++   -- Examples+   let ys  = M.findWithDefault [] (getId r) exMap+   unless (null ys) $ do+      h3 "Examples"+      forM_ (take 3 ys) $ \(a, b) -> para $ divClass "step" $ pre $ do +         forTerm ex (inContext ex a)+         forStep ups (getId r, emptyEnv)+         forTerm ex (inContext ex b)+         +   -- FMPS+   let xs = getRewriteRules r+   unless (null xs) $ do+      h3 "Formal Mathematical Properties"+      forM_ xs $ \(Some rr, b) -> para $ do+         let fmp = rewriteRuleToFMP b rr+         highlightXML False $ XML.makeXML "FMP" $ +            XML.builder (omobj2xml (toObject fmp))++idboxHTML :: String -> Id -> HTMLBuilder+idboxHTML kind i = divClass "idbox" $ do+   para $ do +      font "id" $ ttText (showId i)+      spaces 3+      text $ "(" ++ kind ++ ")"+   unless (null $ description i) $+      para $ italic $ text (description i)++forStep :: Int -> (Id, Environment) -> HTMLBuilder  +forStep n (i, env) = do +      spaces 3+      text "=>"+      space+      let target = up n ++ ruleFile i+          make | null (description i) = link target+               | otherwise = linkTitle target (description i)+      make (text (unqualified i))+      br+      unless (nullEnv env) $ do+         spaces 6+         text (show env)+         br++forTerm :: Exercise a -> Context a -> HTMLBuilder+forTerm ex ca = do+   text (prettyPrinterContext ex ca)+   br
+ src/Documentation/RulePresenter.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Documentation.RulePresenter (ruleToHTML) where
+
+import Common.Library
+import Control.Monad
+import Common.Utils (Some(..), safeHead)
+import Common.Rewriting.Term
+import Data.List
+import Text.HTML
+
+ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder
+ruleToHTML ex r = 
+   forM_ (getRewriteRules r) $ \(Some rr, b) -> 
+      rewriteRuleToHTML b ex rr
+
+rewriteRuleToHTML :: Bool -> Some Exercise -> RewriteRule a -> HTMLBuilder
+rewriteRuleToHTML sound ex r = do
+   let lhs :~> rhs = ruleSpecTerm r
+   -- showRuleName (unqualified r)
+   -- spaces 3
+   showTerm ex lhs
+   spaces 3
+   showLeadsTo sound
+   spaces 3
+   showTerm ex rhs
+   br
+
+{-     
+showRuleName :: String -> HTMLBuilder
+showRuleName s = text ("[" ++ s ++ "]")
+-}
+
+showLeadsTo :: Bool -> HTMLBuilder
+showLeadsTo sound = text (if sound then "\x21D2" else "\x21CF")
+
+showTerm :: Some Exercise -> Term -> HTMLBuilder
+showTerm (Some ex) = text . rec
+ where
+   rec term =
+      case term of
+         Var s   -> s
+         Num i   -> show i
+         Float a -> show a
+         Meta n  -> showMeta ex n
+         _ -> concatMap (either id recp) $  
+            case getSpine term of
+               (Con s, xs) -> 
+                  case specialSymbol s xs of
+                     Just ys -> ys
+                     Nothing -> spaced (Left (show s) : map Right xs)
+               (x, xs) -> spaced (map Right (x:xs))
+   
+   recp term = parIf (isApply term) (rec term)
+   spaced    = intersperse (Left " ")
+      
+   isApply (Apply _ _) = True
+   isApply _           = False
+      
+   parIf b s = if b then "(" ++ s ++ ")" else s           
+         
+specialSymbol :: Symbol -> [Term] -> Maybe [Either String Term]
+-- constants
+specialSymbol s [] 
+   | sameSymbol s "logic1.true"     = con "T"
+   | sameSymbol s "logic1.false"    = con "F"
+   | sameSymbol s "relalg.universe" = con "V" -- universe
+   | sameSymbol s "relalg.ident"    = con "I" -- identity
+ where
+   con x = return [Left x]
+-- unary symbols
+specialSymbol s [a]
+   | sameSymbol s "logic1.not"         = pref "\172" -- "~"
+   | sameSymbol s "arith1.unary_minus" = pref "-"
+   | sameSymbol s "relalg.not"         = post "\x203E"
+   | sameSymbol s "relalg.inv"         = post "~"
+ where
+   pref x  = return [Left x, Right a]
+   post x = return [Right a, Left x]
+-- binary symbols
+specialSymbol s [a, b]
+   | sameSymbol s "logic1.or"         = bin " \8744 " -- "||"
+   | sameSymbol s "logic1.and"        = bin " \8743 " -- "&&"
+   | sameSymbol s "logic1.implies"    = bin " \8594 " -- "->"
+   | sameSymbol s "logic1.equivalent" = bin " \8596 " -- "<->"
+   | sameSymbol s "relation1.eq"      = bin " = "
+   | sameSymbol s "arith1.plus"       = bin "+"
+   | sameSymbol s "arith1.minus"      = bin "-"
+   | sameSymbol s "arith1.power"      = bin "^"
+   | sameSymbol s "arith1.times"      = bin "\x00B7" -- "*"
+   | sameSymbol s "arith1.divide"     = bin "/"
+   | sameSymbol s "relalg.conj"       = bin " \x2229 " -- intersect
+   | sameSymbol s "relalg.disj"       = bin " \x222A " -- union
+   | sameSymbol s "relalg.comp"       = bin " ; " -- composition
+   | sameSymbol s "relalg.add"        = bin " \x2020 " -- relative addition/dagger
+ where
+   bin x = return [Right a, Left x, Right b]
+specialSymbol s1 [Apply (Apply (Con s2) x) a] 
+   | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" = 
+        return [Left "D(", Right x, Left ") ", Right a] 
+specialSymbol _ _ = Nothing
+
+sameSymbol :: Symbol -> String -> Bool
+sameSymbol = (==) . show 
+
+showMeta :: Exercise a -> Int -> String
+showMeta ex n
+   | safeHead (qualifiers ex) == Just "logic" = [ [c] | c <- ['p'..] ] !! n
+   | safeHead (qualifiers ex) == Just "relationalgebra" = [ [c] | c <- ['r'..] ] !! n
+   | otherwise = [ [c] | c <- ['a'..] ] !! n
src/Documentation/SelfCheck.hs view
@@ -9,87 +9,87 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Documentation.SelfCheck (performSelfCheck) where+module Documentation.SelfCheck (selfCheck, blackBoxTests) where -import Control.Monad.Trans import System.Directory-import Common.Utils (reportTest, useFixedStdGen, Some(..), snd3)+import Common.TestSuite+import Common.Utils (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.OpenMath.Tests as OpenMath 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+selfCheck :: String -> DomainReasoner TestSuite+selfCheck dir = do+   pkgs        <- getPackages+   domainSuite <- getTestSuite+   run         <- runWithCurrent    +   return $ do+      suite "Framework checks" $ do+         suite "Text encodings" $ do+            addProperty "UTF8 encoding" UTF8.propEncoding+            addProperty "JSON encoding" JSON.propEncoding+            addProperty "OpenMath encoding" OpenMath.propEncoding+         +      suite "Domain checks" domainSuite+      +      suite "Exercise checks" $+         forM_ pkgs $ \(Some pkg) ->+            exerciseTestSuite (exercise pkg)+      +      suite "Black box tests" $ do +         liftIO (blackBoxTests run dir) >>= id+ -- Returns the number of tests performed-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)+blackBoxTests :: (DomainReasoner Bool -> IO Bool) -> String -> IO TestSuite+blackBoxTests run path = do+   putStrLn ("Scanning " ++ path)+   -- analyse content+   xs0 <- getDirectoryContents path+   let (xml,  xs1) = partition (".xml"  `isSuffixOf`) xs0+       (json, xs2) = partition (".json" `isSuffixOf`) xs1+   -- perform tests+   ts1 <- forM json $ \x ->+             doBlackBoxTest run JSON (path ++ "/" ++ x)+   ts2 <- forM xml $ \x ->+             doBlackBoxTest run XML (path ++ "/" ++ x)+   -- recursively visit subdirectories+   ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do+             let p = path ++ "/" ++ x+             valid <- doesDirectoryExist p+             if not valid +                then return (return ())+                else liftM (suite $ "Directory " ++ simplerDirectory p) +                           (blackBoxTests run p)+   return $ +      sequence_ (ts1 ++ ts2 ++ ts3) -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)+doBlackBoxTest :: (DomainReasoner Bool -> IO Bool) -> DataFormat -> FilePath -> IO TestSuite+doBlackBoxTest run format path = do+   b <- doesFileExist expPath+   return $ if not b +      then warn $ expPath ++ " does not exist"+      else assertIO (stripDirectoryPart path) $ run $ do +         -- Comparing output with expected output+         liftIO useFixedStdGen -- fix the random number generator+         txt  <- liftIO $ readFile path+         expt <- liftIO $ readFile expPath+         out  <- case format of +                    JSON -> liftM snd3 (processJSON txt)+                    XML  -> liftM snd3 (processXML txt)+         -- Conditional forces evaluation of the result, to make sure that+         -- all file handles are closed afterwards.+         if out ~= expt then return True else return False+       `catchError` +         \_ -> return False  where    expPath = baseOf path ++ ".exp"    baseOf  = reverse . drop 1 . dropWhile (/= '.') . reverse@@ -118,33 +118,3 @@    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
@@ -1,3 +1,4 @@+{-# OPTIONS -XRankNTypes #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -13,29 +14,25 @@  import Documentation.DefaultPage import Service.ExercisePackage-import Service.ServiceList import Service.TypedExample import Service.Types import Service.DomainReasoner-import Service.TypedAbstractService (emptyState)+import Service.State 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 Text.XML (XML) import Control.Monad-import Common.Utils (ShowString(..))+import Common.Exercise+import Common.Utils (Some(..))  makeServicePage :: String -> Service -> DomainReasoner () makeServicePage dir s = do-   xs <- examplesFor (serviceName s)+   xs <- examplesFor (showId s)    generatePageAt 1 dir (servicePageFile s)  (servicePage xs s)  servicePage :: [Example] -> Service -> HTMLBuilder-servicePage examples s = do-   h1 (serviceName s)+servicePage xs s = do+   h1 (showId s)     para $ do       bold $ text "Signature:"@@ -45,20 +42,20 @@    para $ do       bold $ text "Description: "       br-      text $ serviceDescription s+      text $ description 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) $ +   unless (null xs) $ do+      h2 $ "XML examples (" ++ show (length xs) ++ ")"+      forM_ (zip [1::Int ..] xs) $           \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do             h2 $ show i ++ ". " ++ msg             bold $ text "Request:"-            preText $ showXML xmlRequest+            highlightXML True xmlRequest             bold $ text "Reply:"-            preText $ showXML xmlReply+            highlightXML True xmlReply             unless xmlTest $                 XML.element "font" $ do                   "color" XML..=. "red"@@ -70,30 +67,53 @@ type Example = (String, (XML, XML, Bool))  examplesFor :: String -> DomainReasoner [Example]-examplesFor s = sequence [ m | (t, m) <- list, s == t ]+examplesFor s = tryAll [ f t | (t, f) <- 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]+      [ ("derivation",   makeExample "logic.dnf"  (noCfg +++ logic1))+      , ("derivation",   makeExample "math.lineq" (noCfg +++ lineq1))+      , ("allfirsts",    makeExample "logic.dnf"  logic2)+      , ("allfirsts",    makeExample "math.lineq" lineq2)+      , ("onefirst",     makeExample "logic.dnf"  logic2)+      , ("onefirst",     makeExample "math.lineq" lineq2)+      , ("rulesinfo",    makeExample "math.lineq" noArgs)+      , ("rulelist",     makeExample "math.lineq" exArgs)+      , ("strategyinfo", makeExample "math.lineq" exArgs)+      , ("examples",     makeExample "math.lineq" exArgs)       ]-   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)+   logic1, logic2 :: Args+   logic1 pkg = newState pkg "~(p /\\ ~q)"+   logic2 pkg = newState pkg "~~p /\\ T"+   +   lineq1, lineq2 :: Args+   lineq1 pkg = newState pkg "5*(x+1) == 11"+   lineq2 pkg = newState pkg "5*(x+1) == (x-1)/2"+   +   (f +++ g) pkg = f pkg ++ g pkg+   +   noCfg _    = [Nothing ::: maybeTp StrategyCfg]+   noArgs _   = []+   exArgs pkg = [pkg ::: ExercisePkg]++tryAll :: [DomainReasoner a] -> DomainReasoner [a]+tryAll xs = +   let f m = liftM return m `catchError` const (return [])+   in liftM concat (mapM f xs)       -   make msg pkg fs args = (fs, do-      srv <- findService fs-      tr  <- typedExample pkg srv args-      return (msg, tr))+newState :: Monad m => ExercisePackage a -> String -> m (TypedValue a)+newState pkg s = do+   let ex = exercise pkg+   case parser ex s of+      Left msg -> fail ("newState: " ++ msg)+      Right a  -> return (emptyState pkg a ::: stateTp)+      +type Args = forall a . ExercisePackage a -> [TypedValue a]++makeExample :: String -> Args -> String -> DomainReasoner Example+makeExample pkgName f srvName = do+   let a = newId pkgName+   Some pkg <- findPackage a+   srv      <- findService srvName+   tr       <- typedExample pkg srv (f pkg)+   return (showId pkg, tr)
src/Documentation/TestsPage.hs view
@@ -9,80 +9,68 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Documentation.TestsPage (main) where+module Documentation.TestsPage (makeTestsPage) where -import Control.Monad-import Data.Char-import Data.List+import Common.TestSuite import Documentation.DefaultPage+import Documentation.SelfCheck 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 ++ ")"+makeTestsPage :: String -> String -> DomainReasoner ()+makeTestsPage docDir testDir = do+   checks <- selfCheck testDir+   result <- liftIO (runTestSuiteResult checks)+   generatePage docDir testsPageFile (testsPage result) -testsPage :: String -> HTMLBuilder-testsPage input = do +testsPage :: TestSuiteResult -> HTMLBuilder+testsPage result = do +   h1 "Summary"+   preText (makeSummary result)    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)+   makeTestLogWith formatHTML result+   +formatHTML :: FormatLog HTMLBuilder+formatHTML = FormatLog+   { formatRoot = \_ -> id+   , formatSuite = \loc s _ _ a -> +        showHeader loc s >> a +   , formatSuccesses = \xs -> +        let f (_, n) = if n==1 then "." else "(passed " ++ show n ++ " tests)"+        in mapM_ (\s -> ttText s >> br) (breakLine (concatMap f xs))+   , formatFailure = \s msg -> colorRed $ do+        bold (ttText ("Error" ++ putLabel s))+        tt space+        ttText msg+        br+   , formatWarning = \s msg -> colorOrange $ do+        ttText ("Warning" ++ putLabel s)+        tt space+        ttText msg+        br+   }+ where +   putLabel s = if null s then ":" else " (" ++ s ++ "):" -fromString :: String -> HTMLBuilder-fromString = f []+breakLine :: String -> [String]+breakLine xs+   | null xs   = []+   | otherwise = ys : breakLine zs  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+   (ys, zs) = splitAt 80 xs -errorLine :: HTMLBuilder -> HTMLBuilder-errorLine b = XML.element "font" $ do+showHeader :: [Int] -> String -> HTMLBuilder+showHeader [a]   s = h2 (show a ++ ". " ++ s)+showHeader [a,b] s = h3 (show a ++ "." ++ show b ++ ". " ++ s)+showHeader _     s = para (bold (text s))++colorRed :: HTMLBuilder -> HTMLBuilder+colorRed body = XML.element "font" $ do    "color" XML..=. "red"-   bold b+   body    -okLine :: HTMLBuilder -> HTMLBuilder-okLine b = XML.element "font" $ do-   "color" XML..=. "gray"-   b+colorOrange :: HTMLBuilder -> HTMLBuilder+colorOrange body = XML.element "font" $ do+   "color" XML..=. "#FE9A2E"+   body
src/Domain/LinearAlgebra/Checks.hs view
@@ -11,10 +11,10 @@ -----------------------------------------------------------------------------
 module Domain.LinearAlgebra.Checks (checks) where
 
-import Common.Apply
+import Common.Classes
 import Common.Context
 import Common.Exercise
-import Common.Utils
+import Common.TestSuite
 import Domain.LinearAlgebra hiding (getSolution)
 import Domain.Math.Expr
 import Domain.Math.Simplification (simplify)
@@ -23,13 +23,13 @@ -----------------------------------------------------------
 --- QuickCheck properties
 
-checks :: IO ()
-checks = do
-   putStrLn "** Linear algebra"
-   thoroughCheck propEchelon
-   thoroughCheck propReducedEchelon
-   thoroughCheck propSound
-   thoroughCheck propSolution
+checks :: TestSuite
+checks = suite "Linear algebra" $ do
+   let thorough = stdArgs {maxSize = 500, maxSuccess = 500}
+   addPropertyWith "echelon"         thorough propEchelon
+   addPropertyWith "reduced echelon" thorough propReducedEchelon
+   addPropertyWith "sound"           thorough propSound
+   addPropertyWith "solution"        thorough propSolution
 
 propEchelon :: Matrix Rational -> Bool
 propEchelon =
src/Domain/LinearAlgebra/EquationsRules.hs view
@@ -16,6 +16,7 @@ import Common.Transformation import Common.Utils import Common.Navigator+import Common.Id import Common.View hiding (simplify) import Control.Monad import Data.List hiding (repeat)@@ -37,7 +38,8 @@    ]  ruleExchangeEquations :: Rule (Context (LinearSystem Expr))-ruleExchangeEquations = simplifySystem $ makeRule "Exchange" $ +ruleExchangeEquations = describe "Exchange two equations" $ +   simplifySystem $ makeRule "linearalgebra.linsystem.exchange" $     supplyLabeled2 descr args (\x y -> liftTransContext $ exchange x y)  where    descr = ("equation 1", "equation 2")@@ -49,7 +51,8 @@       return (cov, cov + i)  ruleEliminateVar :: Rule (Context (LinearSystem Expr))-ruleEliminateVar = simplifySystem $ makeRule "Eliminate variable" $ +ruleEliminateVar = describe "Eliminate a variable (using addition)" $+   simplifySystem $ makeRule "linearalgebra.linsystem.eliminate" $     supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z)  where    descr = ("equation 1", "equation 2", "scale factor")@@ -64,20 +67,23 @@       return (i + cov + 1, cov, v)  ruleDropEquation :: Rule (Context (LinearSystem Expr))-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)+ruleDropEquation = describe "Drop trivial equations (such as 0=0)" $+   simplifySystem $ makeSimpleRule "linearalgebra.linsystem.trivial" $ withCM $ \ls -> do+      i   <- findIndexM (fromMaybe False . testConstants (==)) ls+      modifyVar covered (\n -> if i < n then n-1 else n)+      return (deleteIndex i ls)  ruleInconsistentSystem :: Rule (Context (LinearSystem Expr))-ruleInconsistentSystem = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ withCM $ \ls -> do-   let stop = [0 :==: 1]-   guard (invalidSystem ls && ls /= stop)-   writeVar covered 1-   return stop+ruleInconsistentSystem = describe "Inconsistent system (0=1)" $+   simplifySystem $ makeSimpleRule "linearalgebra.linsystem.inconsistent" $ withCM $ \ls -> do+      let stop = [0 :==: 1]+      guard (invalidSystem ls && ls /= stop)+      writeVar covered 1+      return stop  ruleScaleEquation :: Rule (Context (LinearSystem Expr))-ruleScaleEquation = simplifySystem $ makeRule "Scale equation to one" $ +ruleScaleEquation = describe "Scale equation to one" $ +   simplifySystem $ makeRule "linearalgebra.linsystem.scale" $     supplyLabeled2 descr args (\x y -> liftTransContext $ scaleEquation x y)  where    descr = ("equation", "scale factor")@@ -91,7 +97,8 @@       return (cov, coef)     ruleBackSubstitution :: Rule (Context (LinearSystem Expr))-ruleBackSubstitution = simplifySystem $ makeRule "Back substitution" $ +ruleBackSubstitution = describe "Back substitution" $+   simplifySystem $ makeRule "linearalgebra.linsystem.subst" $     supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z)  where    descr = ("equation 1", "equation 2", "scale factor")@@ -99,29 +106,33 @@       cov <- readVar covered       eq  <- maybeCM $ safeHead $ drop cov ls       let expr = leftHandSide eq-      mv <- maybeCM $ safeHead (getVars expr)+      mv <- maybeCM $ safeHead (vars expr)       i  <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls)       let coef = negate $ coefficientOf mv (leftHandSide (ls !! i))       return (i, cov, coef)  ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a))-ruleIdentifyFreeVariables = 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+ruleIdentifyFreeVariables = describe "Identify free variables" $ +   minorRule $ makeSimpleRule "linearalgebra.linsystem.freevars" $ withCM $ \ls ->+   let vs = [ head ys | ys <- map (vars . leftHandSide) ls, not (null ys) ]+       f eq =+          let (e1, e2) = splitLinearExpr (`notElem` vs) (leftHandSide eq) -- constant ends up in e1           in e2 :==: rightHandSide eq - e1-   in return (map change ls)+   in return (map f ls)  ruleCoverUpEquation :: Rule (Context (LinearSystem a))-ruleCoverUpEquation = minorRule $ makeRule "Cover up first equation" $ changeCover (+1)+ruleCoverUpEquation = describe "Cover up first equation" $ +   minorRule $ makeRule "linearalgebra.linsystem.coverup" $ changeCover succ  ruleUncoverEquation :: Rule (Context (LinearSystem a))-ruleUncoverEquation = minorRule $ makeRule "Uncover one equation" $ changeCover (\x -> x-1)+ruleUncoverEquation = describe "Uncover one equation" $ +   minorRule $ makeRule "linearalgebra.linsystem.uncover" $ changeCover pred  ruleCoverAllEquations :: Rule (Context (LinearSystem a))-ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ withCM $ \ls -> do-   writeVar covered (length ls)-   return ls+ruleCoverAllEquations = describe "Cove all equations" $ +   minorRule $ makeSimpleRule "linearalgebra.linsystem.coverall" $ withCM $ \ls -> do+      writeVar covered (length ls)+      return ls  -- local helper functions deleteIndex :: Int -> [a] -> [a]@@ -130,7 +141,7 @@  testConstants :: IsLinear a => (a -> a -> Bool) -> Equation a -> Maybe Bool testConstants f (lhs :==: rhs)-   | isConstant lhs && isConstant rhs = Just (f lhs rhs)+   | hasNoVar lhs && hasNoVar rhs = Just (f lhs rhs)    | otherwise = Nothing  -- simplify a linear system
src/Domain/LinearAlgebra/Exercises.hs view
@@ -14,7 +14,7 @@    , gaussianElimExercise, systemWithMatrixExercise
    ) where
 
-import Common.Apply
+import Common.Classes
 import Common.Context
 import Common.Exercise
 import Common.Transformation
@@ -34,8 +34,8 @@ 
 gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr))
 gramSchmidtExercise = makeExercise
-   { description    = "Gram-Schmidt"
-   , exerciseCode   = makeCode "linalg" "gramschmidt"
+   { exerciseId     = describe "Gram-Schmidt" $
+                         newId "linearalgebra.gramschmidt"
    , status         = Alpha
    , parser         = \s -> case parseVectorSpace s of
                               Right a  -> Right (fmap simplified a)
@@ -52,8 +52,8 @@ 
 linearSystemExercise :: Exercise (Equations Expr)
 linearSystemExercise = makeExercise
-   { description    = "Solve Linear System"
-   , exerciseCode   = makeCode "linalg" "linsystem"
+   { exerciseId     = describe "Solve Linear System" $
+                         newId "linearalgebra.linsystem"
    , status         = Stable
    , parser         = \s -> case parseSystem s of
                                Right a  -> Right (simplify a)
@@ -65,6 +65,7 @@                                     (Just a, Just b) -> getSolution a == getSolution b
                                     _ -> False 
    , extraRules     = equationsRules
+   , ruleOrdering   = ruleOrderingWithId [getId ruleScaleEquation]
    , isReady        = inSolvedForm
    , strategy       = linearSystemStrategy
    , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix)
@@ -72,8 +73,8 @@    
 gaussianElimExercise :: Exercise (Matrix Expr)
 gaussianElimExercise = makeExercise
-   { description    = "Gaussian Elimination"
-   , exerciseCode   = makeCode "linalg" "gaussianelim"
+   { exerciseId     = describe "Gaussian Elimination" $ 
+                         newId "linearalgebra.gaussianelim"
    , status         = Stable
    , parser         = \s -> case parseMatrix s of
                                Right a  -> Right (simplify a)
@@ -88,8 +89,8 @@  
 systemWithMatrixExercise :: Exercise Expr
 systemWithMatrixExercise = makeExercise
-   { description    = "Solve Linear System with Matrix"
-   , exerciseCode   = makeCode "linalg" "systemwithmatrix"
+   { exerciseId     = describe "Solve Linear System with Matrix" $ 
+                         newId "linearalgebra.systemwithmatrix"
    , status         = Provisional
    , parser         = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of
                                (Right ok, _) -> Right $ toExpr ok
@@ -106,7 +107,7 @@                               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))])
+   , extraRules     = map useC equationsRules ++ map useC (matrixRules :: [Rule (Context (Matrix Expr))])
    , isReady        = inSolvedForm . (fromExpr :: Expr -> Equations Expr)
    , strategy       = systemWithMatrixStrategy
    , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr)))
@@ -115,36 +116,10 @@  
 --------------------------------------------------------------
 -- Other stuff (to be cleaned up)
-                  
-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
-   arbitrary = do
-      i <- choose (0, 3) -- too many vectors "disables" prime factorization
-      j <- choose (0, 10 `div` i)
-      xs <- replicateM i (liftM fromList $ replicateM j arbitrary)
-      return $ makeVectorSpace xs
-instance CoArbitrary a => CoArbitrary (VectorSpace a) where
-   coarbitrary = coarbitrary . vectors
-
 arbMatrix :: Num a => Gen (Matrix a)
 arbMatrix = fmap (fmap fromInteger) arbNiceMatrix
-
-instance Arbitrary a => Arbitrary (Matrix a) where
-   arbitrary = do
-      (i, j) <- arbitrary
-      arbSizedMatrix (i `mod` 5, j `mod` 5)
-instance CoArbitrary a => CoArbitrary (Matrix a) where
-   coarbitrary = coarbitrary . rows
    
-arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
-arbSizedMatrix (i, j) = 
-   do rows <- replicateM i (vector j)
-      return (makeMatrix rows)
-
 arbUpperMatrix :: (Enum a, Num a) => Gen (Matrix a)
 arbUpperMatrix = do
    a <- oneof $ map return [-5 .. 5]
src/Domain/LinearAlgebra/LinearSystem.hs view
@@ -16,41 +16,44 @@ import Domain.LinearAlgebra.LinearView
 import Data.List
 import Data.Maybe
+import Common.Classes
 import Control.Monad
 import Common.Utils
 import Common.Uniplate
+import Common.Rewriting
+import qualified Data.Set as S
 
 type LinearSystem a = Equations a
 
 getVarsSystem :: IsLinear a => LinearSystem a -> [String]
-getVarsSystem = foldr (\(lhs :==: rhs) xs -> getVars lhs `union` getVars rhs `union` xs) []
+getVarsSystem = S.toList . S.unions . map varSet . concatMap crush
 
 evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool
 evalSystem f = 
-   let eval (x :==: y) = x==y
-   in all (eval . fmap (evalLinearExpr f))
+   let evalEq (x :==: y) = x==y
+   in all (evalEq . fmap (evalLinearExpr f))
 
 invalidSystem :: IsLinear a => LinearSystem a -> Bool
 invalidSystem = any invalidEquation
 
 invalidEquation :: IsLinear a => Equation a -> Bool
-invalidEquation (lhs :==: rhs) = null (getVars lhs ++ getVars rhs) && getConstant lhs /= getConstant rhs
+invalidEquation (lhs :==: rhs) = hasNoVar lhs && hasNoVar rhs && getConstant lhs /= getConstant rhs
 
 getSolution :: IsLinear a => LinearSystem a -> Maybe [(String, a)]
 getSolution xs = do
-   guard (distinct vars)
-   guard (null (vars `intersect` frees))
+   guard (distinct vs)
+   guard (null (vs `intersect` frees))
    mapM make xs
  where
-   vars  = concatMap (getVars . leftHandSide) xs
-   frees = concatMap (getVars . rightHandSide) xs
+   vs    = concatMap (vars . leftHandSide) xs
+   frees = concatMap (vars . rightHandSide) xs
    make (lhs :==: rhs) = do
-      v <- isVar lhs
+      v <- getVariable lhs
       return (v, rhs)
       
 -- No constant on the left, no variables on the right
 inStandardForm :: IsLinear a => Equation a -> Bool
-inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && null (getVars rhs)
+inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && hasNoVar rhs
 
 toStandardForm :: IsLinear a => Equation a -> Equation a
 toStandardForm (lhs :==: rhs) =
@@ -66,11 +69,11 @@ 
 -- Conversions
 systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String])
-systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vars)
+systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vs)
  where
-   vars = getVarsSystem system
+   vs = getVarsSystem system
    makeRow (lhs :==: rhs) =
-      map (`coefficientOf` lhs) vars ++ [getConstant rhs]
+      map (`coefficientOf` lhs) vs ++ [getConstant rhs]
 
 matrixToSystem :: IsLinear a => Matrix a -> LinearSystem a
 matrixToSystem = matrixToSystemWith variables
@@ -81,7 +84,7 @@    varList = vs ++ (variables \\ vs)
    makeEquation [] = 0 :==: 0
    makeEquation xs = 
-      let lhs = sum (zipWith (\v a -> a * var v) varList (init xs))  
+      let lhs = sum (zipWith (\v a -> a * variable v) varList (init xs))  
           rhs = last xs
       in lhs :==: rhs
src/Domain/LinearAlgebra/LinearView.hs view
@@ -10,16 +10,16 @@ --
 -----------------------------------------------------------------------------
 module Domain.LinearAlgebra.LinearView
-   ( IsLinear(..), var, isVar, isConstant, renameVariables
+   ( IsLinear(..), LinearMap, renameVariables
    , splitLinearExpr, evalLinearExpr, linearView
-   , LinearMap
    ) where
 
 import Control.Monad
 import Data.List
+import Common.Rewriting
 import Common.Uniplate
-import Common.View hiding (simplify)
-import Domain.Math.Expr hiding (isVariable)
+import Common.View
+import Domain.Math.Expr
 import qualified Data.Map as M
 
 data LinearMap a = LM { lmMap :: M.Map String a, lmConstant :: a }
@@ -73,73 +73,35 @@    guard (M.null m)
    return $ LM M.empty (sqrt c)
 
-symLM :: Symbolic a => Symbol -> [LinearMap a] -> Maybe (LinearMap a)
+symLM :: WithFunctions a => Symbol -> [LinearMap a] -> Maybe (LinearMap a)
 symLM f ps = do
    guard (all (M.null . lmMap) ps)
    return $ LM M.empty (function f (map lmConstant ps))
 
-class (Fractional a, Symbolic a) => IsLinear a where
-   isLinear :: a -> Bool
-   isVariable :: a -> Maybe String
-   getVars  :: a -> [String]
-   getConstant     :: a -> a
-   coefficientOf   :: String -> a -> a
+class (Fractional a, Uniplate a, WithVars a) => IsLinear a where
+   isLinear      :: a -> Bool
+   getConstant   :: a -> a
+   coefficientOf :: String -> a -> a
 
 instance IsLinear Expr where
-
-   isLinear expr = belongsTo expr linearView
-         
-   isVariable expr =
-      case expr of 
-         Var s -> Just s
-         _     -> Nothing
-   
-   getVars = collectVars
-   
-   getConstant expr = 
-      case match linearView expr of
-         Just (LM _ c) -> c
-         _             -> 0
-
-   coefficientOf s expr = 
-      case match linearView expr of
-         Just (LM m _) -> M.findWithDefault 0 s m
-         _             -> 0
-
-{- instance IsLinear SExpr where
-   isLinear = isLinear . toExpr
-   isVariable = isVariable . toExpr
-   getVars    = getVars . toExpr
-   getConstant = simplifyExpr . getConstant . toExpr
-   coefficientOf s = simplifyExpr . coefficientOf s . toExpr  -}
+   isLinear        = (`belongsTo` linearView)
+   getConstant     = maybe 0 lmConstant . match linearView
+   coefficientOf s = maybe 0 (M.findWithDefault 0 s . lmMap) . match linearView
 
 splitLinearExpr :: IsLinear a => (String -> Bool) -> a -> (a, a)
 splitLinearExpr f a = (make (getConstant a) xs, make 0 ys)
  where
-   (xs, ys) = partition f (getVars a)
-   make = foldr (\v r -> coefficientOf v a * var v + r)
+   (xs, ys) = partition f (vars a)
+   make = foldr (\v r -> coefficientOf v a * variable v + r)
 
-evalLinearExpr :: (IsLinear a, Uniplate a) => (String -> a) -> a -> a
+evalLinearExpr :: IsLinear a => (String -> a) -> a -> a
 evalLinearExpr f a =
-   case isVariable a of
+   case getVariable a of
       Just s  -> f s
-      Nothing -> g $ map (evalLinearExpr f) cs
- where
-   (cs, g) = uniplate a
+      Nothing -> descend (evalLinearExpr f) a
 
-renameVariables :: (IsLinear a, Uniplate a) => (String -> String) -> a -> a
+renameVariables :: IsLinear a => (String -> String) -> a -> a
 renameVariables f a = 
-   case isVariable a of
+   case getVariable a of
       Just s  -> variable (f s)
-      Nothing -> g $ map (renameVariables f) cs
- where
-   (cs, g) = uniplate a
-
-isConstant :: IsLinear a => a -> Bool
-isConstant = null . getVars
-
-var :: IsLinear a => String -> a
-var = variable
-
-isVar :: IsLinear a => a -> Maybe String
-isVar = isVariable+      Nothing -> descend (renameVariables f) a
src/Domain/LinearAlgebra/Matrix.hs view
@@ -21,10 +21,15 @@    , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular
    ) where
 
+import Common.Classes
+import Common.Rewriting hiding (inverse)
 import Control.Monad
-import Data.Maybe
 import Data.List hiding (transpose)
-import Common.Traversable
+import Data.Maybe
+import Domain.Math.Simplification
+import Domain.Math.Expr.Symbols (openMathSymbol)
+import Test.QuickCheck
+import qualified Text.OpenMath.Dictionary.Linalg2 as OM
 import qualified Data.List as L
 import qualified Data.Map as M
 
@@ -36,16 +41,42 @@ type Column a = [a]
 
 instance Functor Matrix where 
-   fmap f (M rows) = M (map (map f) rows)
-
-instance Once Matrix where 
-   onceM f (M xss) = do 
-      yss <- onceM (onceM f) xss
-      return (M yss)
+   fmap f (M rs) = M (map (map f) rs)
 
 instance Switch Matrix where
    switch (M xss) = liftM M (mapM sequence xss)
 
+instance IsTerm a => IsTerm (Matrix a) where
+   toTerm = 
+      let f = function matrixrowSymbol . map toTerm
+      in function matrixSymbol . map f . rows
+   fromTerm a = do
+      rs  <- isFunction matrixSymbol a
+      xss <- mapM (isFunction matrixrowSymbol) rs
+      yss <- mapM (mapM fromTerm) xss
+      guard (isRectangular yss)
+      return (makeMatrix yss)
+
+instance Arbitrary a => Arbitrary (Matrix a) where
+   arbitrary = do
+      (i, j) <- arbitrary
+      arbSizedMatrix (i `mod` 5, j `mod` 5)
+
+instance CoArbitrary a => CoArbitrary (Matrix a) where
+   coarbitrary = coarbitrary . rows
+
+arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
+arbSizedMatrix (i, j) = 
+   do rs <- replicateM i (vector j)
+      return (makeMatrix rs)
+
+matrixSymbol, matrixrowSymbol :: Symbol
+matrixSymbol    = openMathSymbol OM.matrixSymbol
+matrixrowSymbol = openMathSymbol OM.matrixrowSymbol
+
+instance Simplify a => Simplify (Matrix a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
 -- Check whether the table is rectangular
 isRectangular :: [[a]] -> Bool
 isRectangular xss =
@@ -55,10 +86,10 @@ 
 -- Constructor function that checks whether the table is rectangular
 makeMatrix :: [Row a] -> Matrix a
-makeMatrix rows
-   | null (concat rows) = M []
-   | isRectangular rows = M rows
-   | otherwise          = error "makeMatrix: not rectangular"
+makeMatrix rs
+   | null (concat rs) = M []
+   | isRectangular rs = M rs
+   | otherwise        = error "makeMatrix: not rectangular"
 
 identity :: Num a => Int -> Matrix a
 identity n = M $ map f [0..n-1]
@@ -68,7 +99,7 @@ isEmpty (M xs) = null xs
 
 rows :: Matrix a -> [Row a]
-rows (M rows) = rows
+rows (M rs) = rs
 
 row :: Int -> Matrix a -> Row a
 row n = (!!n) . rows
@@ -86,7 +117,7 @@ entry (i, j) m = row i m !! j
 
 mapWithPos :: ((Int, Int) -> a -> b) -> Matrix a -> Matrix b
-mapWithPos f (M rows) = M $ zipWith g [0..] rows
+mapWithPos f (M rs) = M $ zipWith g [0..] rs
  where g y = zipWith (\x -> f (y, x)) [0..]
 
 changeEntries :: M.Map (Int, Int) (a -> a) -> Matrix a -> Matrix a
@@ -176,7 +207,7 @@ -------------------------------------------------------
 
 transpose :: Matrix a -> Matrix a
-transpose (M rows) = M (L.transpose rows)
+transpose (M rs) = M (L.transpose rs)
 
 -------------------------------------------------------
 
@@ -195,30 +226,30 @@ checkRow i m = i >= 0 && i < fst (dimensions m)
 
 switchRows :: Int -> Int -> Matrix a -> Matrix a
-switchRows i j m@(M rows)
+switchRows i j m@(M rs)
    | i == j = m
    | i >  j = switchRows j i m
    | checkRow i m && checkRow j m = 
-        let (before, r1:rest)  = splitAt i       rows
+        let (before, r1:rest)  = splitAt i       rs
             (middle, r2:after) = splitAt (j-i-1) rest
         in M $ before ++ [r2] ++ middle ++ [r1] ++ after
    | otherwise = 
         error "switchRows: invalid rows"
 
 scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a
-scaleRow i a m@(M rows)
+scaleRow i a m@(M rs)
    | checkRow i m = 
         let f y = if y==i then map (*a) else id
-        in M $ zipWith f [0..] rows
+        in M $ zipWith f [0..] rs
    | otherwise = 
         error "scaleRow: invalid row"
 
 addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a
-addRow i j a m@(M rows) 
+addRow i j a m@(M rs) 
    | checkRow i m && checkRow j m = 
         let rj  = map (*a) (row j m)
             f y = if y==i then zipWith (+) rj else id
-        in M $ zipWith f [0..] rows
+        in M $ zipWith f [0..] rs
    | otherwise = 
         error "addRow: invalid row"
 
@@ -233,9 +264,9 @@  where check n = all (==0) . take n
 
 inRowEchelonForm :: Num a => Matrix a -> Bool
-inRowEchelonForm (M rows) =
-   null (filter nonZero (dropWhile nonZero rows)) &&
-   increasing (map (length . takeWhile (==0)) (filter nonZero rows))
+inRowEchelonForm (M rs) =
+   null (filter nonZero (dropWhile nonZero rs)) &&
+   increasing (map (length . takeWhile (==0)) (filter nonZero rs))
  where
    increasing (x:ys@(y:_)) = x < y && increasing ys
    increasing _ = True
@@ -245,10 +276,10 @@ 
 -- or row canonical form
 inRowReducedEchelonForm :: Num a => Matrix a -> Bool
-inRowReducedEchelonForm m@(M rows) =
+inRowReducedEchelonForm m@(M rs) =
    inRowEchelonForm m && 
-   all (==1) (mapMaybe pivot rows) &&
-   all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rows)
+   all (==1) (mapMaybe pivot rs) &&
+   all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs)
 
 pivot :: Num a => Row a -> Maybe a
 pivot r = case dropWhile (==0) r of
src/Domain/LinearAlgebra/MatrixRules.hs view
@@ -13,7 +13,6 @@ 
 import Domain.Math.Simplification
 import Domain.LinearAlgebra.Matrix
-import Domain.LinearAlgebra.Symbols ()
 import Common.Context
 import Common.Navigator
 import Common.Transformation
@@ -29,7 +28,7 @@       ]
 
 ruleFindColumnJ :: Num a => Rule (Context (Matrix a))
-ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ withCM $ \m -> do
+ruleFindColumnJ = minorRule $ makeSimpleRule "linearalgebra.gaussianelim.FindColumnJ" $ withCM $ \m -> do
    cols <- liftM columns (subMatrix m)
    i    <- findIndexM nonZero cols
    writeVar columnJ i
@@ -76,24 +75,24 @@    return (k, cov, v)
 
 ruleCoverRow :: Rule (Context (Matrix a))
-ruleCoverRow = minorRule $ makeRule "CoverRow" $ changeCover (+1)
+ruleCoverRow = minorRule $ makeRule "linearalgebra.gaussianelim.CoverRow" $ changeCover succ
 
 ruleUncoverRow :: Rule (Context (Matrix a))
-ruleUncoverRow = minorRule $ makeRule "UncoverRow" $ changeCover (\x -> x-1)
+ruleUncoverRow = minorRule $ makeRule "linearalgebra.gaussianelim.UncoverRow" $ changeCover pred
 
 ---------------------------------------------------------------------------------
 -- Parameterized rules
 
 ruleScaleRow :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, a)) -> Rule (Context (Matrix a))
-ruleScaleRow f = makeRule "Scale" (supplyLabeled2 descr f rowScale)
+ruleScaleRow f = makeRule "linearalgebra.gaussianelim.scale" (supplyLabeled2 descr f rowScale)
  where descr  = ("row", "scale factor")
       
 ruleExchangeRows :: Num a => (Context (Matrix a) -> Maybe (Int, Int)) -> Rule (Context (Matrix a))
-ruleExchangeRows f = makeRule "Exchange" (supplyLabeled2 descr f rowExchange)
+ruleExchangeRows f = makeRule "linearalgebra.gaussianelim.exchange" (supplyLabeled2 descr f rowExchange)
  where descr = ("row 1", "row 2")
 
 ruleAddMultiple :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, Int, a)) -> Rule (Context (Matrix a))
-ruleAddMultiple f = makeRule "Add" (supplyLabeled3 descr f  rowAdd)
+ruleAddMultiple f = makeRule "linearalgebra.gaussianelim.add" (supplyLabeled3 descr f  rowAdd)
  where descr  = ("row 1", "row2", "scale factor")
       
 ---------------------------------------------------------------------------------
@@ -141,7 +140,7 @@ subMatrix :: Matrix a -> ContextMonad (Matrix a)
 subMatrix m = do 
    cov <- readVar covered
-   return $ makeMatrix $ drop cov $ rows $ m
+   return $ makeMatrix $ drop cov $ rows m
    
 findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int
 findIndexM p = maybe mzero return . findIndex p
src/Domain/LinearAlgebra/Strategies.hs view
@@ -13,24 +13,20 @@    ( gaussianElimStrategy, linearSystemStrategy
    , gramSchmidtStrategy, systemWithMatrixStrategy
    , forwardPass
-   , 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
+import Common.Id
 import Domain.LinearAlgebra.Vector
 
 gaussianElimStrategy :: LabeledStrategy (Context (Matrix Expr))
@@ -92,11 +88,11 @@ 
 systemWithMatrixStrategy :: LabeledStrategy (Context Expr)
 systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $
-       repeat (mapRules liftExpr dropEquation) 
+       repeat (mapRules useC dropEquation) 
    <*> conv1 
-   <*> mapRules liftExpr gaussianElimStrategy 
+   <*> mapRules useC gaussianElimStrategy 
    <*> conv2 
-   <*> repeat (mapRules liftExpr dropEquation)
+   <*> repeat (mapRules useC dropEquation)
 
 gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr)))
 gramSchmidtStrategy =
@@ -105,29 +101,24 @@    <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal)) 
    <*> label "Normalize"              (try ruleNormalize)
 
-vars :: Var [String]
-vars = newVar "variables" []
+varVars :: Var [String]
+varVars = newVar "variables" []
 
 simplifyFirst :: Rule (Context (LinearSystem Expr))
 simplifyFirst = simplifySystem idRule
 
 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)))
+conv1 = describe "Convert linear system to matrix" $
+   makeSimpleRule "linearalgebra.linsystem.tomatrix" $ withCM $ \expr -> do
+      ls <- fromExpr expr
+      let (m, vs) = systemToMatrix ls
+      writeVar varVars vs
+      return (toExpr (simplify (m :: Matrix Expr)))
  
 conv2 :: Rule (Context Expr)
-conv2 = 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
-
-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+conv2 = describe "Convert matrix to linear system" $ 
+   makeSimpleRule "linearalgebra.linsystem.frommatrix" $ withCM $ \expr -> do
+      vs <- readVar varVars
+      m  <- fromExpr expr
+      let linsys = matrixToSystemWith vs (m :: Matrix Expr)
+      return $ simplify $ toExpr linsys
− src/Domain/LinearAlgebra/Symbols.hs 
@@ -1,65 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Domain.LinearAlgebra.Symbols () where--import Domain.Math.Expr.Symbolic-import Domain.Math.Simplification-import Domain.LinearAlgebra.Matrix-import Domain.LinearAlgebra.Vector-import Control.Monad-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 IsTerm a => IsTerm (Matrix a) where-   toTerm = -      let f = function matrixrowSymbol . map toTerm-      in function matrixSymbol . map f . rows-   fromTerm a = do-      rs  <- isSymbol matrixSymbol a-      xss <- mapM (isSymbol matrixrowSymbol) rs-      yss <- mapM (mapM fromTerm) xss-      guard (isRectangular yss)-      return (makeMatrix yss)--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 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
@@ -18,8 +18,13 @@    ) where
 
 import Control.Monad
-import Common.Traversable
+import Common.Classes
+import Common.Rewriting
 import Data.List
+import Domain.Math.Simplification
+import Domain.Math.Expr.Symbols (openMathSymbol) 
+import Test.QuickCheck
+import qualified Text.OpenMath.Dictionary.Linalg2 as OM
 
 -------------------------------------------------------------------------------
 -- Data types
@@ -36,9 +41,6 @@ instance Functor Vector where
    fmap f (V xs) = V (map f xs)
 
-instance Once Vector where
-   onceM f (V xs) = liftM V (onceM f xs)
-
 instance Switch Vector where
    switch (V xs) = liftM V (switch xs)
 
@@ -54,12 +56,50 @@    signum = liftV signum
    fromInteger = fromList . return . fromInteger
 
+instance IsTerm a => IsTerm (Vector a) where
+   toTerm = function vectorSymbol . map toTerm . toList
+   fromTerm a = do
+      xs <- isFunction vectorSymbol a
+      ys <- mapM fromTerm xs
+      return (fromList ys)
+
+instance Arbitrary a => Arbitrary (Vector a) where
+   arbitrary   = liftM fromList $ oneof $ map vector [0..2]
+
+instance CoArbitrary a => CoArbitrary (Vector a) where
+   coarbitrary = coarbitrary . toList
+
+vectorSymbol :: Symbol
+vectorSymbol = openMathSymbol OM.vectorSymbol
+
+instance Simplify a => Simplify (Vector a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
 instance Functor VectorSpace where
    fmap f (VS xs) = VS (map (fmap f) xs)
 
 instance Show a => Show (VectorSpace a) where
    show = show . vectors
 
+instance IsTerm a => IsTerm (VectorSpace a) where
+   toTerm = toTerm . vectors
+   fromTerm a = do
+      xs <- fromTerm a
+      guard (sameDimension xs)
+      return (makeVectorSpace xs)
+      
+instance Simplify a => Simplify (VectorSpace a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
+instance Arbitrary a => Arbitrary (VectorSpace a) where
+   arbitrary = do
+      i <- choose (0, 3) -- too many vectors "disables" prime factorization
+      j <- choose (0, 10 `div` i)
+      xs <- replicateM i (liftM fromList $ replicateM j arbitrary)
+      return $ makeVectorSpace xs
+instance CoArbitrary a => CoArbitrary (VectorSpace a) where
+   coarbitrary = coarbitrary . vectors
+
 -------------------------------------------------------------------------------
 -- Vector Space operations
 
@@ -125,7 +165,7 @@ orthonormalList :: Floating a => [Vector a] -> Bool
 orthonormalList xs = all isUnit xs && all (uncurry orthogonal) pairs
  where
-   pairs = [ (a, b) | (i, a) <- zip [0..] xs, (j, b) <- zip [0..] xs, i < j ] 
+   pairs = [ (a, b) | (i, a) <- zip [0::Int ..] xs, (j, b) <- zip [0..] xs, i < j ] 
 
 -- length of the vector (also called norm)
 norm :: Floating a => Vector a -> a
src/Domain/Logic.hs view
@@ -10,22 +10,21 @@ --
 -----------------------------------------------------------------------------
 module Domain.Logic
-   ( module Domain.Logic.Formula
+   ( module Domain.Logic.BuggyRules
+   , module Domain.Logic.Exercises
+   , module Domain.Logic.Formula
+   , module Domain.Logic.GeneralizedRules
    , module Domain.Logic.Generator
    , module Domain.Logic.Parser
-   , module Domain.Logic.Strategies
    , module Domain.Logic.Rules
-   , module Domain.Logic.BuggyRules
-   , module Domain.Logic.GeneralizedRules
-   , module Domain.Logic.Exercises
+   , module Domain.Logic.Strategies
    ) where
-   
+
+import Domain.Logic.BuggyRules hiding (rule, ruleList)
+import Domain.Logic.Exercises
 import Domain.Logic.Formula
+import Domain.Logic.GeneralizedRules
 import Domain.Logic.Generator
 import Domain.Logic.Parser
-import Domain.Logic.Strategies
-import Domain.Logic.Rules
-import Domain.Logic.BuggyRules
-import Domain.Logic.GeneralizedRules
-import Domain.Logic.Exercises
-
+import Domain.Logic.Rules      hiding (rule, ruleList)
+import Domain.Logic.Strategies
src/Domain/Logic/BuggyRules.hs view
@@ -15,13 +15,15 @@  import Domain.Logic.Formula import Domain.Logic.Generator()-import Domain.Logic.Rules (makeGroup)+import Domain.Logic.Rules (makeGroup, logic)+import Common.Id import Common.Rewriting-import Common.Transformation+import Common.Transformation (Rule, buggyRule)+import qualified Common.Transformation as Rule  -- Collection of all known buggy rules buggyRules :: [Rule SLogic]-buggyRules = makeGroup "Common misconceptions"+buggyRules = snd $ makeGroup "Common misconceptions"    [ buggyRuleCommImp, buggyRuleAssImp, buggyRuleIdemImp, buggyRuleIdemEqui    , buggyRuleEquivElim1, buggyRuleImplElim2, buggyRuleEquivElim2, buggyRuleEquivElim3    , buggyRuleImplElim, buggyRuleImplElim1, buggyRuleDeMorgan1, buggyRuleDeMorgan2, buggyRuleDeMorgan3@@ -31,6 +33,12 @@    , buggyRuleTrueProp, buggyRuleFalseProp, buggyRuleDistr, buggyRuleDistrNot    ] +rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a+rule = Rule.rule . logic . ( "buggy" # )++ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a+ruleList = Rule.ruleList . logic . ( "buggy" # )+ ----------------------------------------------------------------------------- -- Buggy rules @@ -39,7 +47,7 @@    \x -> x :&&: x  :~>  T  buggyRuleAndCompl :: Rule SLogic-buggyRuleAndCompl = buggyRule $ ruleList "AndComplBuggy"+buggyRuleAndCompl = buggyRule $ ruleList "AndCompl"    [ \x -> x :&&: Not x  :~>  T    , \x -> Not x :&&: x  :~>  T    , \x -> x :&&: Not x  :~>  x@@ -51,7 +59,7 @@    \x -> x :||: x  :~>  T  buggyRuleOrCompl :: Rule SLogic-buggyRuleOrCompl = buggyRule $ ruleList "OrComplBuggy"+buggyRuleOrCompl = buggyRule $ ruleList "OrCompl"    [ \x -> x :||: Not x  :~>  F    , \x -> Not x :||:  x :~>  F    , \x -> x :||: Not x  :~>  x@@ -93,7 +101,7 @@    \x -> x :<->: x  :~>  x   buggyRuleEquivElim1 :: Rule SLogic-buggyRuleEquivElim1 = buggyRule $ ruleList "BuggyEquivElim1"+buggyRuleEquivElim1 = buggyRule $ ruleList "EquivElim1"     [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y)     , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&:  y)     , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y)@@ -102,7 +110,7 @@     ]      buggyRuleEquivElim2 :: Rule SLogic-buggyRuleEquivElim2 = buggyRule $ ruleList "BuggyEquivElim2"+buggyRuleEquivElim2 = buggyRule $ ruleList "EquivElim2"     [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y)     , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y)     , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y)@@ -113,22 +121,22 @@      \x y -> x :<->: y :~> Not x :||: y      buggyRuleImplElim :: Rule SLogic-buggyRuleImplElim = buggyRule $ ruleList "BuggyImplElim" +buggyRuleImplElim = buggyRule $ ruleList "ImplElim"     [\x y -> x :->: y :~> Not (x :||: y)    ,\x y -> x :->: y :~> (x :||: y)    ,\x y -> x :->: y :~> Not (x :&&: y)    ]    buggyRuleImplElim1 :: Rule SLogic-buggyRuleImplElim1 = buggyRule $ rule "BuggyImplElim1"  $  +buggyRuleImplElim1 = buggyRule $ rule "ImplElim1"  $        \x y -> x :->: y :~> Not x :&&: y  buggyRuleImplElim2 :: Rule SLogic-buggyRuleImplElim2 = buggyRule $ rule "BuggyImplElim2" $ +buggyRuleImplElim2 = buggyRule $ rule "ImplElim2" $       \x y -> x :->: y :~>  (x :&&: y) :||: (Not x :&&: Not y)        buggyRuleDeMorgan1 :: Rule SLogic-buggyRuleDeMorgan1 = buggyRule $ ruleList "BuggyDeMorgan1"+buggyRuleDeMorgan1 = buggyRule $ ruleList "DeMorgan1"     [ \x y -> Not (x :&&: y) :~>  Not x :||: y     , \x y -> Not (x :&&: y) :~>  x :||: Not y     , \x y -> Not (x :&&: y) :~>  x :||: y@@ -138,20 +146,20 @@     ]      buggyRuleDeMorgan2 :: Rule SLogic-buggyRuleDeMorgan2 = buggyRule $ ruleList "BuggyDeMorgan2"+buggyRuleDeMorgan2 = buggyRule $ ruleList "DeMorgan2"     [ \x y -> Not (x :&&: y) :~>  Not (Not x :||: Not y)     , \x y -> Not (x :||: y) :~>  Not (Not x :&&: Not y) --note the firstNot in both formulas!       ] buggyRuleDeMorgan3 :: Rule SLogic    -buggyRuleDeMorgan3 = buggyRule $  rule "BuggyDeMorgan3" $+buggyRuleDeMorgan3 = buggyRule $  rule "DeMorgan3" $     \x y -> Not (x :&&: y) :~>  Not x :&&: Not y  buggyRuleDeMorgan4 :: Rule SLogic    -buggyRuleDeMorgan4 = buggyRule $  rule "BuggyDeMorgan4" $   +buggyRuleDeMorgan4 = buggyRule $  rule "DeMorgan4" $         \x y -> Not (x :||: y) :~>  Not x :||: Not y       buggyRuleDeMorgan5 :: Rule SLogic-buggyRuleDeMorgan5 = buggyRule $ ruleList "BuggyDeMorgan5"+buggyRuleDeMorgan5 = buggyRule $ ruleList "DeMorgan5"     [ \x y z -> Not (Not (x :&&: y) :||: z) :~>  Not (Not x :||: Not y):||: z     , \x y z -> Not (Not (x :&&: y) :&&: z) :~>  Not (Not x :||: Not y):&&: z     , \x y z -> Not (Not (x :||: y) :||: z) :~>  Not (Not x :&&: Not y):||: z@@ -159,21 +167,21 @@     ]       buggyRuleNotOverImpl :: Rule SLogic-buggyRuleNotOverImpl = buggyRule $ rule "BuggyNotOverImpl" $+buggyRuleNotOverImpl = buggyRule $ rule "NotOverImpl" $     \x y -> Not (x :->: y) :~> Not x :->: Not y      buggyRuleParenth1 :: Rule SLogic-buggyRuleParenth1 = buggyRule $ ruleList "BuggyParenth1"+buggyRuleParenth1 = buggyRule $ ruleList "Parenth1"     [ \x y -> Not (x :&&: y)     :~> Not x :&&: y     , \x y -> Not (x :||: y)     :~> Not x :||: y     ]  buggyRuleParenth2 :: Rule SLogic-buggyRuleParenth2 = buggyRule $ rule "BuggyParenth2" $+buggyRuleParenth2 = buggyRule $ rule "Parenth2" $     \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y)      buggyRuleParenth3 :: Rule SLogic-buggyRuleParenth3 = buggyRule $ ruleList "BuggyParenth3"    +buggyRuleParenth3 = buggyRule $ ruleList "Parenth3"         [ \x y -> Not (Not x :&&: y)  :~> x :&&: y      , \x y -> Not (Not x :||: y)  :~> x :||: y     , \x y -> Not (Not x :->: y)  :~> x :->: y@@ -182,7 +190,7 @@              buggyRuleAssoc :: Rule SLogic-buggyRuleAssoc = buggyRule $ ruleList "BuggyAssoc"+buggyRuleAssoc = buggyRule $ ruleList "Assoc"     [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z     , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z)     , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z)@@ -190,7 +198,7 @@     ]   buggyRuleAbsor :: Rule SLogic-buggyRuleAbsor = buggyRule $ ruleList "BuggyAbsor"+buggyRuleAbsor = buggyRule $ ruleList "Absor"     [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y)      , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y)      , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y) @@ -198,7 +206,7 @@     ]      buggyRuleDistr :: Rule SLogic-buggyRuleDistr = buggyRule $ ruleList "BuggyDistr"+buggyRuleDistr = buggyRule $ ruleList "Distr"    [ \x y z -> x :&&: (y :||: z)  :~>  (x :&&: y) :&&: (x :&&: z)    , \x y z -> (x :||: y) :&&: z  :~>  (x :&&: z) :&&: (y :&&: z)    , \x y z -> x :&&: (y :||: z)  :~>  (x :||: y) :&&: (x :||: z)@@ -210,7 +218,7 @@    ]      buggyRuleDistrNot :: Rule SLogic-buggyRuleDistrNot = buggyRule $ ruleList "BuggyDistrNot"+buggyRuleDistrNot = buggyRule $ ruleList "DistrNot"    [ \x y z -> Not x :&&: (y :||: z)  :~>  (Not x :&&: y) :||: (x :&&: z)    , \x y z -> Not x :&&: (y :||: z)  :~>  (x :&&: y) :||: (Not x :&&: z)    , \x y z -> (x :||: y) :&&: Not z  :~>  (x :&&: Not z) :||: (y :&&: z)
+ src/Domain/Logic/Examples.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  josje.lodder@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A set of example proofs
+--
+-----------------------------------------------------------------------------
+module Domain.Logic.Examples 
+   ( exampleProofs
+   ) where
+
+
+import Domain.Logic.Formula
+import Common.Utils (ShowString(..))
+
+
+
+
+
+exampleProofs :: [(SLogic, SLogic)]
+exampleProofs = [(Not(p :||: (Not p :&&: q)), Not(p :||: q)),
+                ((p :->:q):||: Not p, (p :->: q) :||: q),
+                ((p :&&: Not q):||:(q :&&: Not p), (p :||:q):&&:Not(p :&&: q)),
+                (Not(p :||: Not(p :||: Not q)), Not(p :||: q)),
+                (p :<->: q, (p :->: q) :&&: (q :->: p)),
+                ((p :&&: q) :->: p, T),
+                ((p :->: q) :||: (q :->: p), T),
+                ((q :->: (Not p :->: q)) :->: p, Not p :->: (q :&&: ((p :&&: q) :&&: q))),
+                ((p :->: Not q):->:q, (s :||:(s :->:(q :||: p))) :&&: q),
+                (p :->: (q :->: r), (p :->: q) :->: (p :->:r)),
+                (Not((p :->: q) :->: Not(q :->: p)), p :<->: q),
+                 ((p :->: q):->: (p :->: s), (Not q :->: Not p) :->: (Not s :->: Not p)),
+                (Not((p :->:q) :->: (p:&&:q)), (p :->: q) :&&: (Not p :||: Not q)),
+                (Not((p :<->: q) :->: (p :||: (p :<->: q))), F)]
+                
+ where
+   p = Var (ShowString "p")
+   q = Var (ShowString "q")
+   s = Var (ShowString "s")
+   r = Var (ShowString "r")
+
+
+
src/Domain/Logic/Exercises.hs view
@@ -34,8 +34,8 @@ -- Currently, we use the DWA strategy
 dnfExercise :: Exercise SLogic
 dnfExercise = makeExercise
-   { description    = "Proposition to DNF"
-   , exerciseCode   = makeCode "logic" "dnf"
+   { exerciseId     = describe "Proposition to DNF" $
+                         newId "logic.propositional.dnf"
    , status         = Stable
    , parser         = parseLogicPars
    , prettyPrinter  = ppLogicPars
@@ -54,8 +54,8 @@ -- Direct support for unicode characters
 dnfUnicodeExercise :: Exercise SLogic
 dnfUnicodeExercise = dnfExercise
-   { description   = description dnfExercise ++ " (unicode support)"
-   , exerciseCode  = makeCode "logic" "dnf-unicode"
+   { exerciseId    = describe "Proposition to DNF (unicode support)" $
+                        newId "logic.propositional.dnf.unicode"
    , parser        = parseLogicUnicodePars
    , prettyPrinter = ppLogicUnicodePars
    }
@@ -66,8 +66,8 @@           | n == 1    = generateLevel Easy
           | n == 3    = generateLevel Difficult 
           | otherwise = generateLevel Normal 
-       ok p = let n = fromMaybe maxBound (stepsRemaining maxStep p)
-              in countEquivalences p <= 2 && n >= minStep && n <= maxStep
+       ok p = let i = fromMaybe maxBound (stepsRemaining maxStep p)
+              in countEquivalences p <= 2 && i >= minStep && i <= maxStep
    in restrictGenerator ok gen
 
 suitable :: SLogic -> Bool
src/Domain/Logic/FeedbackText.hs view
@@ -16,13 +16,14 @@  import Data.List import Data.Maybe+import Common.Id import Common.Transformation import Domain.Logic.Rules import Domain.Logic.BuggyRules  feedbackSyntaxError :: String -> String  feedbackSyntaxError msg-   | take 1 msg == "("               = "Syntax error at " ++ msg+   | "(" `isPrefixOf` msg            = "Syntax error at " ++ msg    | "Syntax error" `isPrefixOf` msg = msg    | otherwise                       = "Syntax error: " ++ msg @@ -104,7 +105,7 @@ feedbackDetour :: Bool -> Maybe (Rule a) -> [Rule a] -> (String, Bool) feedbackDetour True _ [one] = (appliedRule one ++ " " ++ feedbackFinished, True) feedbackDetour True _ _     = (feedbackMultipleSteps ++ " " ++ feedbackFinished, True)-feedbackDetour _ _ [one] | one `inGroup`"Commutativity" =+feedbackDetour _ _ [one] | one `inGroup` groupCommutativity =    ("You have applied one of the commutativity rules correctly. This step is not mandatory, but sometimes helps to simplify the formula.", True) feedbackDetour _ mexp [one] =     let however = case mexp >>= ruleText of@@ -134,15 +135,15 @@    | r ~= ruleNotNot  = return "double negation"     | r ~= ruleDefImpl  = return "implication elimination"     | r ~= ruleDefEquiv  = return "equivalence elimination" -   | r `inGroup`"Commutativity" = return "commutativity"-   | r `inGroup`"Aasociativity" = return "associativity"-   | r `inGroup`"DistributionOrOverAnd" = return "distribution of or over and"-   | r `inGroup`"DistributionAndOverOr" = return "distribution of and over or"-   | r `inGroup`"Idempotency" = return "idempotency"-   | r `inGroup`"Absorption" = return "absorption"-   | r `inGroup`"De Morgan" = return "De Morgan"-   | r `inGroup`"InverseDeMorgan" = return "De Morgan"-   | r `inGroup`"InverseDistr" = return "distributivity"+   | r `inGroup` groupCommutativity = return "commutativity"+   | r `inGroup` groupAssociativity = return "associativity"+   | r `inGroup` groupDistributionOrOverAnd = return "distribution of or over and"+   | r `inGroup` groupDistributionAndOverOr = return "distribution of and over or"+   | r `inGroup` groupIdempotency = return "idempotency"+   | r `inGroup` groupAbsorption = return "absorption"+   | r `inGroup` groupDeMorgan = return "De Morgan"+   | r `inGroup` groupInverseDeMorgan = return "De Morgan"+   | r `inGroup` groupInverseDistr = return "distributivity"     -- TODO Josje: aanvullen met alle regels (ook die ook in de DWA strategie voorkomen)    | otherwise = Nothing -------------------------------------------------------------------------@@ -162,10 +163,10 @@ -- Helper functions  (~=) :: Rule a -> Rule b -> Bool-r1 ~= r2 = name r1 == name r2+r1 ~= r2 = getId r1 == getId r2  -- Quick and dirty fix!-inGroup :: Rule a -> String -> Bool+inGroup :: Rule a -> (Id, b) -> Bool inGroup r n =     let rs = filter (~= r) (logicRules ++ buggyRules)-   in n `elem` concatMap ruleGroups rs+   in fst n `elem` concatMap ruleGroups rs
src/Domain/Logic/Formula.hs view
@@ -11,14 +11,17 @@ ----------------------------------------------------------------------------- module Domain.Logic.Formula where -import Domain.Math.Expr.Symbolic-import Text.OpenMath.Dictionary.Logic1-import Common.Uniplate (Uniplate(..), universe)+import Common.Classes+import Common.Id import Common.Rewriting-import Common.Traversable+import Common.Uniplate (Uniplate(..), universe) import Common.Utils (ShowString, subsets)-import Data.List+import Common.View import Control.Monad+import Data.List+import Data.Maybe+import Domain.Math.Expr.Symbols (openMathSymbol)+import qualified Text.OpenMath.Dictionary.Logic1 as OM  infixr 2 :<->: infixr 3 :->: @@ -61,16 +64,16 @@  -- | foldLogic is the standard fold for Logic. foldLogic :: LogicAlg b a -> Logic b -> a-foldLogic (var, impl, equiv, and, or, not, true, false) = rec+foldLogic (var, impl, equiv, conj, disj, neg, true, false) = rec  where    rec logic =        case logic of          Var x     -> var x          p :->: q  -> rec p `impl`  rec q          p :<->: q -> rec p `equiv` rec q-         p :&&: q  -> rec p `and`   rec q-         p :||: q  -> rec p `or`    rec q-         Not p     -> not (rec p)+         p :&&: q  -> rec p `conj`  rec q+         p :||: q  -> rec p `disj`  rec q+         Not p     -> neg (rec p)          T         -> true           F         -> false @@ -79,8 +82,10 @@ 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 ""+ppLogicPrio = (\f s -> f s "") . flip (foldLogic alg)  where+   alg = ( pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\"+         , binop 1 "||", nott, pp "T", pp "F")    binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio)    pp s      = const (s++)    nott p _  = ("~"++) . p 4@@ -105,13 +110,6 @@    xs = varsLogic p `union` varsLogic q    fs = map (flip elem) (subsets xs)  --- | Functions noNot, noOr, and noAnd determine whether or not a Logic --- | expression contains a not, or, and and constructor, respectively.-noNot, noOr, noAnd :: Logic a -> Bool-noNot = foldLogic (const True, (&&), (&&), (&&), (&&), const False, True, True)-noOr  = foldLogic (const True, (&&), (&&), (&&), \_ _ -> False, id, True, True)-noAnd = foldLogic (const True, (&&), (&&), \_ _ -> False, (&&), id, True, True)- -- | A Logic expression is atomic if it is a variable or a constant True or False. isAtomic :: Logic a -> Bool isAtomic logic = @@ -131,56 +129,30 @@ -- | Function disjunctions returns all Logic expressions separated by an or -- | operator at the top level. disjunctions :: Logic a -> [Logic a]-disjunctions = collectWithOperator orOperator+disjunctions p = fromMaybe [p] $ match (magmaListView orMonoid) p  -- | Function conjunctions returns all Logic expressions separated by an and -- | operator at the top level. conjunctions :: Logic a -> [Logic a]-conjunctions = collectWithOperator andOperator---- | Count the number of implicationsations :: Logic -> Int-countImplications :: Logic a -> Int-countImplications p = length [ () | _ :->: _ <- universe p ] +conjunctions p = fromMaybe [p] $ match (magmaListView andMonoid) p   -- | Count the number of equivalences countEquivalences :: Logic a -> Int countEquivalences p = length [ () | _ :<->: _ <- universe p ] --- | Count the number of binary operators-countBinaryOperators :: Logic a -> Int-countBinaryOperators = foldLogic (const 0, binop, binop, binop, binop, id, 0, 0)- where binop x y = x + y + 1---- | Count the number of double negations -countDoubleNegations :: Logic a -> Int-countDoubleNegations p = length [ () | Not (Not _) <- universe p ] - -- | Function varsLogic returns the variables that appear in a Logic expression. varsLogic :: Eq a => Logic a -> [a] varsLogic p = nub [ s | Var s <- universe p ]     instance Uniplate (Logic a) where-   uniplate p =-      case p of +   uniplate this =+      case this of           p :->: q  -> ([p, q], \[a, b] -> a :->:  b)          p :<->: q -> ([p, q], \[a, b] -> a :<->: b)          p :&&: q  -> ([p, q], \[a, b] -> a :&&:  b)          p :||: q  -> ([p, q], \[a, b] -> a :||:  b)          Not p     -> ([p], \[a] -> Not a)-         _         -> ([], \[] -> p)--instance Eq a => ShallowEq (Logic a) where-   shallowEq expr1 expr2 =-      case (expr1, expr2) of-         (Var a, Var b)         -> a==b-         (_ :->: _ , _ :->: _ ) -> True-         (_ :<->: _, _ :<->: _) -> True-         (_ :&&: _ , _ :&&: _ ) -> True-         (_ :||: _ , _ :||: _ ) -> True-         (Not _    , Not _    ) -> True-         (T        , T        ) -> True-         (F        , F        ) -> True-         _                      -> False+         _         -> ([], \[] -> this)  instance Different (Logic a) where    different = (T, F)@@ -189,7 +161,7 @@    toTerm = foldLogic       ( toTerm, binary impliesSymbol, binary equivalentSymbol       , binary andSymbol, binary orSymbol, unary notSymbol-      , nullary trueSymbol, nullary falseSymbol+      , symbol trueSymbol, symbol falseSymbol       )     fromTerm a = @@ -203,23 +175,57 @@       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 s xs@(_:_)+         | s == andSymbol        = return (foldr1 (:&&:) xs)+         | s == orSymbol         = return (foldr1 (:||:) xs)       f _ _ = fail "fromTerm" -logicOperators :: Operators (Logic a)-logicOperators = [andOperator, orOperator]+trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol,+   andSymbol, orSymbol :: Symbol++trueSymbol       = openMathSymbol OM.trueSymbol+falseSymbol      = openMathSymbol OM.falseSymbol+notSymbol        = openMathSymbol OM.notSymbol+impliesSymbol    = openMathSymbol OM.impliesSymbol+equivalentSymbol = openMathSymbol OM.equivalentSymbol+andSymbol        = openMathSymbol OM.andSymbol+orSymbol         = openMathSymbol OM.orSymbol++logicOperators :: [Magma (Logic a)]+logicOperators = map toMagma [andMonoid, orMonoid]++andMonoid :: Monoid (Logic a)+andMonoid = monoid andOperator (makeConstant (getId trueSymbol) T isT)+ where+   isT T = True+   isT _ = False     --- The "and" operator is also commutative, but not (yet) in the equational theory-andOperator :: Operator (Logic a)-andOperator = associativeOperator (:&&:) isAnd+orMonoid :: Monoid (Logic a)+orMonoid = monoid orOperator (makeConstant (getId falseSymbol) F isF)  where+   isF F = True+   isF _ = False++andOperator:: BinaryOp (Logic a)+andOperator = makeBinary (getId andSymbol) (:&&:) isAnd+ where     isAnd (p :&&: q) = Just (p, q)    isAnd _          = Nothing --- The "or" operator is also commutative, but not (yet) in the equational theory-orOperator :: Operator (Logic a)-orOperator = associativeOperator (:||:) isOr+orOperator :: BinaryOp (Logic a)+orOperator = makeBinary (getId orSymbol) (:||:) isOr  where    isOr (p :||: q) = Just (p, q)    isOr _          = Nothing++implOperator :: BinaryOp (Logic a)   +implOperator = makeBinary (getId impliesSymbol) (:->:) isImpl+ where+   isImpl (p :->: q) = Just (p, q)+   isImpl _           = Nothing+   +equivOperator :: BinaryOp (Logic a)   +equivOperator = makeBinary (getId equivalentSymbol) (:<->:) isEquiv+ where+   isEquiv (p :<->: q) = Just (p, q)+   isEquiv _           = Nothing
src/Domain/Logic/GeneralizedRules.hs view
@@ -22,7 +22,8 @@ -- Note: the generalized rules do not take AC-unification into account, -- and perhaps they should. import Domain.Logic.Formula-import Common.Transformation+import Common.Transformation (Rule)+import qualified Common.Transformation as Rule import Control.Monad  generalRules :: [Rule SLogic]@@ -36,6 +37,9 @@    [ inverseDeMorganOr, inverseDeMorganAnd    , inverseAndOverOr, inverseOrOverAnd    ]++makeSimpleRule :: String -> (a -> Maybe a) -> Rule a+makeSimpleRule s = Rule.makeSimpleRule ("logic.propositional." ++ s)  ----------------------------------------------------------------------------- -- Inverse rules
src/Domain/Logic/Generator.hs view
@@ -21,20 +21,24 @@ import Test.QuickCheck
 import Common.Rewriting
 import Common.Uniplate
-import Domain.Math.Expr.Symbolic
-import Text.OpenMath.Dictionary.Logic1
+import Common.View
 
 -------------------------------------------------------------
 -- Code that doesn't belong here, but the arbitrary instance
 -- is needed for the Rewrite instance.
 
 instance Rewrite SLogic where
-   operators      = logicOperators
-   associativeOps = const $ map toSymbol [andSymbol, orSymbol]
+   operators = logicOperators
 
 -- | Equality modulo associativity of operators
 equalLogicA:: SLogic -> SLogic -> Bool
-equalLogicA = equalWith operators
+equalLogicA p q = rec p == rec q
+ where
+   make  = simplifyWith (map rec) . magmaListView
+   rec a = case a of
+              _ :&&: _ -> make andMonoid a
+              _ :||: _ -> make orMonoid  a
+              _        -> descend rec a
 
 -----------------------------------------------------------
 -- Logic generator
@@ -61,18 +65,16 @@ -- Use the propositions with 4-12 steps
 normalGenerator :: Gen SLogic
 normalGenerator = do
-   n  <- return 4 -- oneof [return 4, return 8]
-   p0 <- sizedGen False varGen n
+   p0 <- sizedGen False varGen 4
    p1 <- preventSameVar varList p0
    return (removePartsInDNF p1)
 
 -- Use the propositions with 7-18 steps
 difficultGenerator :: Gen SLogic
 difficultGenerator = do
-   let vars = ShowString "s" : varList
-   n  <- return 4 -- oneof [return 4, return 8]
-   p0 <- sizedGen False (oneof $ map return vars) n
-   p1 <- preventSameVar vars p0
+   let vs = ShowString "s" : varList
+   p0 <- sizedGen False (oneof $ map return vs) 4
+   p1 <- preventSameVar vs p0
    return (removePartsInDNF p1)
 
 varList :: [ShowString]
@@ -104,12 +106,13 @@ -- Simple tricks for creating for "nice" logic propositions
 
 preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a)
-preventSameVar xs = transformM $ \p -> 
-   case uniplate p of
-      ([Var a, Var b], f) | a==b -> do
-         c <- oneof $ map return $ filter (/=a) xs
-         return $ f [Var a, Var c]
-      _ -> return p
+preventSameVar xs = rec 
+ where
+   rec p = case holes p of
+              [(Var a, _), (Var b, update)] | a==b -> do
+                 c <- oneof $ map return $ filter (/=a) xs
+                 return $ update (Var c)
+              _ -> descendM rec p
 
 removePartsInDNF :: SLogic -> SLogic
 removePartsInDNF = buildOr . filter (not . simple) . disjunctions
@@ -127,14 +130,15 @@ 
 instance Arbitrary SLogic where
    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 (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
-         p :||: q  -> variant 4 . coarbitrary p . coarbitrary q
-         Not p     -> variant 5 . coarbitrary p
-         T         -> variant 6  
-         F         -> variant 7+         Var x     -> variant (0 :: Int) . coarbitrary (map ord (fromShowString x))
+         p :->: q  -> variant (1 :: Int) . coarbitrary p . coarbitrary q
+         p :<->: q -> variant (2 :: Int) . coarbitrary p . coarbitrary q
+         p :&&: q  -> variant (3 :: Int) . coarbitrary p . coarbitrary q
+         p :||: q  -> variant (4 :: Int) . coarbitrary p . coarbitrary q
+         Not p     -> variant (5 :: Int) . coarbitrary p
+         T         -> variant (6 :: Int)  
+         F         -> variant (7 :: Int)
src/Domain/Logic/Parser.hs view
@@ -10,11 +10,12 @@ --
 -----------------------------------------------------------------------------
 module Domain.Logic.Parser
-   ( parseLogic, parseLogicPars, parseLogicUnicodePars
+   ( parseLogic, parseLogicPars, parseLogicUnicodePars, parseLogicProof
    , ppLogicPars, ppLogicUnicodePars
    ) where
 
 import Common.Utils (ShowString(..))
+import Control.Monad.Error (liftM2)
 import Text.Parsing
 import Control.Arrow
 import Domain.Logic.Formula
@@ -75,18 +76,20 @@        | [c] == equivUSym = equivASym
        | otherwise        = [c]
 
-pLogicGen (impl, equiv, and, or, nt, tr, fl) = pLogic
+pLogicGen :: SymbolTuple -> TokenParser SLogic
+pLogicGen (impl, equiv, conj, disj, neg, tr, fl) = pLogic
  where
    pLogic = flip ($) <$> basic <*> optional composed id
-   basic     =  basicWithPosGen (nt, tr, fl) pLogic
+   basic     =  basicWithPosGen (neg, tr, fl) pLogic
    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)
+            <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey conj *> basic)
+            <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey disj  *> basic)
  
-basicWithPos :: Parser Token SLogic -> Parser Token SLogic
+basicWithPos :: TokenParser SLogic -> TokenParser SLogic
 basicWithPos = basicWithPosGen ("~", "T", "F")
 
+basicWithPosGen :: (String, String, String) -> TokenParser SLogic -> TokenParser SLogic 
 basicWithPosGen t@(nt, tr, fl) p = 
        (Var . ShowString) <$> pVarid
    <|> pParens p
@@ -94,11 +97,23 @@    <|> F  <$ pKey fl
    <|> Not <$ pKey nt <*> basicWithPosGen t p
 
+parseLogicProof :: String -> Either String (SLogic, SLogic)
+parseLogicProof s
+   = either Left susp
+   $ left (ambiguousOperators parseLogic s)
+   $ analyseAndParse pProof
+   $ scanWith extScanner s
+ where
+   pProof = (,) <$> pLogicGen asciiTuple <* pKey "==" <*> pLogicGen asciiTuple
+   susp (p, q) = liftM2 (,) (suspiciousVariable p) (suspiciousVariable q)
+   extScanner = logicScanner 
+      {keywordOperators = "==" : keywordOperators logicScanner}
+
 -----------------------------------------------------------
 --- Helper-functions for syntax warnings
 
 -- analyze parentheses
-analyseAndParse :: Parser Token a -> [Token] -> Either String a
+analyseAndParse :: TokenParser a -> [Token] -> Either String a
 analyseAndParse p ts =
    case checkParentheses ts of
       Just err -> Left (show err)
@@ -133,21 +148,27 @@ ppLogicUnicodePars :: SLogic -> String
 ppLogicUnicodePars = ppLogicParsGen unicodeTuple
 
-ppLogicParsGen (impl, equiv, and, or, nt, tr, fl) p = foldLogic alg p 0 ""
+ppLogicParsGen :: SymbolTuple -> SLogic -> String
+ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) = 
+   (\f -> f 0 "") . foldLogic alg
  where
-   alg = (pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 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)
+   alg = ( pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 conj
+         , binop 2 disj, nott, pp tr, pp fl
+         )
+   binop :: Int -> String -> (Int -> String -> String) -> (Int -> String -> String) -> Int -> String -> String
+   binop prio op p q n = 
+      parIf (n/=0 && (n==3 || prio/=n)) 
+            (p prio . ((" "++op++" ")++) . q prio)
    pp s = const (s++)
-   nott  p _ = (nt++) . p 3
+   nott  p _ = (neg++) . p 3
    parIf b f = if b then ("("++) . f . (")"++) else f
 
 -----------------------------------------------------------
 --- Ascii symbols
 
---asciiSyms :: [String]
---asciiSyms = [implASym, equivASym, andASym, orASym, notASym]
+type SymbolTuple = (String, String, String, String, String, String, String)
 
+asciiTuple :: SymbolTuple
 asciiTuple = (implASym, equivASym, andASym, orASym, notASym, "T", "F")
 
 implASym, equivASym, andASym, orASym, notASym :: String
@@ -163,6 +184,7 @@ unicodeSyms :: [String]
 unicodeSyms = [implUSym, equivUSym, andUSym, orUSym, notUSym]
 
+unicodeTuple :: SymbolTuple
 unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F")
 
 implUSym, equivUSym, andUSym, orUSym, notUSym :: String
+ src/Domain/Logic/Proofs.hs view
@@ -0,0 +1,319 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Exercise for the logic domain: to prove two propositions equivalent
+--
+-----------------------------------------------------------------------------
+module Domain.Logic.Proofs (proofExercise) where
+
+import Prelude hiding (repeat)
+import Common.Context
+import Common.Rewriting
+import Common.Rewriting.AC
+import Common.Strategy hiding (fail, not)
+import Common.Exercise
+import Common.Utils
+import Common.View
+import Common.Transformation
+import Common.Navigator
+import Data.List hiding (repeat)
+import Control.Monad
+import Data.Maybe
+import Domain.Logic.Formula
+import Domain.Logic.Generator (equalLogicA)
+import Domain.Logic.Parser
+import Domain.Logic.Rules
+import Domain.Logic.GeneralizedRules
+import Domain.Logic.Strategies (somewhereOr)
+import Domain.Logic.Examples 
+import Domain.Math.Expr ()
+import Common.Uniplate
+
+see :: Int -> IO ()
+see n = printDerivation proofExercise (examples proofExercise !! n)
+
+-- Currently, we use the DWA strategy
+proofExercise :: Exercise [(SLogic, SLogic)]
+proofExercise = makeExercise
+   { exerciseId     = describe "Prove two propositions equivalent" $
+                         newId "logic.proof"
+   , status         = Experimental
+--   , parser         = parseLogicProof
+   , prettyPrinter  = let f (p, q) = ppLogicPars p ++ " == " ++ ppLogicPars q
+                      in commaList . map f
+--   , equivalence    = \(p, _) (r, s) -> eqLogic p r && eqLogic r s
+--   , similarity     = \(p, q) (r, s) -> equalLogicA p r && equalLogicA q s
+   , isSuitable     = all (uncurry eqLogic)
+   , isReady        = all (uncurry equalLogicA)
+   , strategy       = proofStrategy
+   , navigation     = termNavigator
+   , examples       = map return $ exampleProofs ++
+                      let p = Var (ShowString "p") 
+                          q = Var (ShowString "q")
+                      in [(q :&&: p, p :&&: (q :||: q))]
+   }
+
+instance (IsTerm a, IsTerm b) => IsTerm (a, b) where
+   toTerm (a, b) = binary tupleSymbol (toTerm a) (toTerm b)
+   fromTerm term = do
+      (a, b) <- isBinary tupleSymbol term
+      liftM2 (,) (fromTerm a) (fromTerm b)
+   
+tupleSymbol :: Symbol
+tupleSymbol = newSymbol "basic.tuple"
+
+proofStrategy :: LabeledStrategy (Context [(SLogic, SLogic)])
+proofStrategy = label "proof equivalent" $
+   repeat (
+         somewhere (useC commonExprAtom)
+      |> somewhere splitTop
+      |> somewhere rest
+      ) <*>
+   repeat (somewhere (use normLogicRule))
+ where
+   splitTop =  use topIsNot  <|> use topIsAnd <|> use topIsOr
+           <|> use topIsImpl <|> use topIsEquiv
+   rest =  use notDNF <*> mapRulesS useC (repeat dnfStrategyDWA)
+       <|> simpler
+
+   simpler :: Strategy (Context [(SLogic, SLogic)])
+   simpler =
+      use tautologyOr <|> use idempotencyAnd <|> use contradictionAnd
+      <|> use absorptionSubset <|> use fakeAbsorption <|> use fakeAbsorptionNot
+      <|> alternatives (map use list)
+            
+   list = [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
+          , ruleAbsorpOr, ruleComplOr
+          ]
+
+   notDNF :: Rule SLogic
+   notDNF = minorRule $ makeSimpleRule "not-dnf" $ \p ->
+      if isDNF p then Nothing else Just p
+
+-----------------------------------------------------------------------------
+-- To DNF, with priorities (the "DWA" approach)
+
+dnfStrategyDWA :: Strategy (Context SLogic)
+dnfStrategyDWA =
+   toplevel <|> somewhereOr
+      (  label "Simplify"                            simplify
+      |> label "Eliminate implications/equivalences" eliminateImplEquiv
+      |> label "Eliminate nots"                      eliminateNots
+      |> label "Move ors to top"                     orToTop
+      )
+ where
+    toplevel = useRules 
+       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
+       , ruleAbsorpOr, ruleComplOr
+       ]
+    simplify = somewhere $ useRules
+       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
+       , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse
+       , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd
+       , ruleComplOr, ruleComplAnd
+       ]
+    eliminateImplEquiv = somewhere $ useRules
+       [ ruleDefImpl, ruleDefEquiv
+       ]
+    eliminateNots = somewhere $ useRules
+       [ generalRuleDeMorganAnd, generalRuleDeMorganOr
+       , ruleDeMorganAnd, ruleDeMorganOr
+       ]
+    orToTop = somewhere $ useRules 
+       [ generalRuleAndOverOr, ruleAndOverOr ]
+
+useRules :: [Rule SLogic] -> Strategy (Context SLogic)
+useRules = alternatives . map liftToContext
+
+onceLeft :: IsStrategy f => f (Context a) -> Strategy (Context a)
+onceLeft s = ruleMoveDown <*> s <*> ruleMoveUp
+ where
+   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 1)   
+   ruleMoveUp   = minorRule $ makeSimpleRule "MoveUp" safeUp
+   
+   safeUp a = Just (fromMaybe a (up a))
+   
+onceRight :: IsStrategy f => f (Context a) -> Strategy (Context a)
+onceRight s = ruleMoveDown <*> s <*> ruleMoveUp
+ where
+   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 2)   
+   ruleMoveUp   = minorRule $ makeSimpleRule "MoveUp" safeUp
+   
+   safeUp a = Just (fromMaybe a (up a))
+
+testje :: Rule (Context SLogic)
+testje = makeSimpleRule "testje" $ \a -> error $ show a
+
+go n = printDerivation proofExercise [exampleProofs !! n] --(p :||: Not p, Not F)
+ --where p = Var (ShowString "p") 
+ 
+normLogicRule :: Rule (SLogic, SLogic)
+normLogicRule = makeSimpleRule "Normalize" $ \tuple@(p, q) -> do
+   guard (p /= q)
+   let xs  = sort (varsLogic p `union` varsLogic q)
+       new = (normLogicWith xs p, normLogicWith xs q)
+   guard (tuple /= new)
+   return new
+
+-- Find a common subexpression that can be treated as a box
+commonExprAtom :: Rule (Context (SLogic, SLogic))
+commonExprAtom = makeSimpleRule "commonExprAtom" $ withCM $ \(p, q) -> do 
+   let f  = filter same . filter ok . nub . sort . universe 
+       xs = f p `intersect` f q -- todo: only largest common sub expr
+       ok (Var _) = False
+       ok T       = False
+       ok F       = False
+       ok (Not a) = ok a
+       ok _       = True
+       same cse = eqLogic (sub cse p) (sub cse q)
+       new = head (logicVars \\ (varsLogic p `union` varsLogic q))
+       sub a this
+          | a == this = Var new
+          | otherwise = descend (sub a) this
+   case xs of 
+      hd:_ -> do modifyVar substVar ((show new, show hd):)
+                 return (sub hd p, sub hd q)
+      _ -> fail "not applicable"
+   
+substVar :: Var [(String, String)]
+substVar = newVar "subst" []
+   
+logicVars :: [ShowString]
+logicVars = [ ShowString [c] | c <- ['a'..] ]
+
+normLogic :: Ord a => Logic a -> Logic a
+normLogic p = normLogicWith (sort (varsLogic p)) p 
+   
+normLogicWith :: Eq a => [a] -> Logic a -> Logic a
+normLogicWith xs p = make (filter keep (subsets xs))
+ where
+   keep ys = evalLogic (`elem` ys) p
+   make = makeOrs . map atoms
+   atoms ys = makeAnds [ f (x `elem` ys) (Var x) | x <- xs ]
+   f b = if b then id else Not
+   
+makeOrs  xs = if null xs then F else foldr1 (:||:) xs
+makeAnds xs = if null xs then T else foldr1 (:&&:) xs
+
+
+-- p \/ q \/ ~p     ~> T           (propageren)
+tautologyOr :: Rule SLogic 
+tautologyOr = makeSimpleRule "tautologyOr" $ \p -> do
+   let xs = disjunctions p
+   guard (any (\x -> Not x `elem` xs) xs)
+   return T
+
+-- p /\ q /\ p      ~> p /\ q
+idempotencyAnd :: Rule SLogic
+idempotencyAnd = makeSimpleRule "idempotencyAnd" $ \p -> do
+   let xs = conjunctions p
+       ys = nub xs
+   guard (length ys < length xs)
+   return (makeAnds ys)
+
+-- p /\ q /\ ~p     ~> F           (propageren)
+contradictionAnd :: Rule SLogic
+contradictionAnd = makeSimpleRule "contradictionAnd" $ \p -> do
+   let xs = conjunctions p
+   guard (any (\x -> Not x `elem` xs) xs)
+   return F
+
+-- (p /\ q) \/ ... \/ (p /\ q /\ r)    ~> (p /\ q) \/ ...
+--    (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes)
+absorptionSubset :: Rule SLogic
+absorptionSubset = makeSimpleRule "absorptionSubset" $ \p -> do
+   let xss = map conjunctions (disjunctions p)
+       yss = nub $ filter (\xs -> all (ok xs) xss) xss
+       ok xs ys = not (ys `isSubsetOf` xs) || xs == ys
+   guard (length yss < length xss)
+   return $ makeOrs (map makeAnds yss)
+   
+-- p \/ ... \/ (~p /\ q /\ r)  ~> p \/ ... \/ (q /\ r)
+--    (p is hier een losse variabele)
+fakeAbsorption :: Rule SLogic
+fakeAbsorption = makeSimpleRuleList "fakeAbsorption" $ \p -> do
+   let xs = disjunctions p
+   v <- [ a | a@(Var _) <- xs ]
+   let ys  = map (makeAnds . filter (/= Not v) . conjunctions) xs
+       new = makeOrs ys
+   guard (p /= new)
+   return new
+
+-- ~p \/ ... \/ (p /\ q /\ r)  ~> ~p \/ ... \/ (q /\ r)
+--   (p is hier een losse variabele)
+fakeAbsorptionNot :: Rule SLogic
+fakeAbsorptionNot = makeSimpleRuleList "fakeAbsorptionNot" $ \p -> do
+   let xs = disjunctions p
+   v <- [ a | Not a@(Var _) <- xs ]
+   let ys  = map (makeAnds . filter (/= v) . conjunctions) xs
+       new = makeOrs ys
+   guard (p /= new)
+   return new
+
+topIsNot :: Rule (SLogic, SLogic)
+topIsNot = makeSimpleRule "top-is-not" f
+ where
+   f (Not p, Not q) = Just (p, q)
+   f _ = Nothing
+
+acTopRuleFor :: IsId a => a -> BinaryOp SLogic -> Rule [(SLogic, SLogic)]
+acTopRuleFor s op = makeSimpleRuleList s f
+ where
+   f [(lhs, rhs)] = do
+      let myView = magmaListView (semiGroup op)
+          make   = build myView
+      xs <- matchM myView lhs
+      ys <- matchM myView rhs
+      guard (length xs > 1 && length ys > 1)
+      list <- liftM (map (make *** make)) (pairingsAC False xs ys)
+      guard (all (uncurry eqLogic) list)
+      return list
+   f _ = []
+
+topIsAnd :: Rule [(SLogic, SLogic)]
+topIsAnd = acTopRuleFor "top-is-and" andOperator
+
+topIsOr :: Rule [(SLogic, SLogic)]
+topIsOr = acTopRuleFor "top-is-or" orOperator
+
+topIsEquiv :: Rule [(SLogic, SLogic)]
+topIsEquiv = acTopRuleFor "top-is-equiv" equivOperator
+
+topIsImpl :: Rule [(SLogic, SLogic)]
+topIsImpl = makeSimpleRule "top-is-impl" f
+ where
+   f [(p :->: q, r :->: s)] = do
+      guard (eqLogic p r && eqLogic q s)
+      return [(p, r), (q, s)]
+   f _ = Nothing
+   
+{- Strategie voor sterke(?) normalisatie
+
+(prioritering)
+ 
+1. p \/ q \/ ~p     ~> T           (propageren)
+   p /\ q /\ p      ~> p /\ q
+   p /\ q /\ ~p     ~> F           (propageren)
+
+2. (p /\ q) \/ ... \/ (p /\ q /\ r)    ~> (p /\ q) \/ ...
+         (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes)
+   p \/ ... \/ (~p /\ q /\ r)  ~> p \/ ... \/ (q /\ r)
+         (p is hier een losse variabele)
+   ~p \/ ... \/ (p /\ q /\ r)  ~> ~p \/ ... \/ (q /\ r)
+         (p is hier een losse variabele)
+
+3. a) elimineren wat aan een kant helemaal niet voorkomt (zie regel hieronder)
+   b) rijtjes sorteren
+   c) rijtjes aanvullen
+   
+Twijfelachtige regel bij stap 3: samennemen in plaats van aanvullen:
+   (p /\ q /\ r) \/ ... \/ (~p /\ q /\ r)   ~> q /\ r
+          (p is hier een losse variable)
+-}
src/Domain/Logic/Rules.hs view
@@ -15,13 +15,15 @@ module Domain.Logic.Rules where
 
 import Domain.Logic.Formula
-import Common.Transformation
+import Common.Id
+import Common.Transformation (Rule, addRuleToGroup, minorRule)
 import Common.Rewriting
 import Domain.Logic.Generator()
 import Domain.Logic.GeneralizedRules
+import qualified Common.Transformation as Rule
  
 logicRules :: [Rule SLogic]
-logicRules = concat 
+logicRules = concatMap snd
    [ groupCommutativity, groupAssociativity, groupIdempotency
    , groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation
    , groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, groupAdditional
@@ -29,21 +31,33 @@    , groupInverseDeMorgan,groupInverseDistr
    ]
 
+logic :: IsId a => a -> Id
+logic = ( # ) "logic.propositional" 
+
+rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+rule = Rule.rule . logic
+
+ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+ruleList = Rule.ruleList . logic
+
 -----------------------------------------------------------------------------
 -- Grouping DWA rules
 
-makeGroup :: String -> [Rule SLogic] -> [Rule SLogic]
-makeGroup = map . addRuleToGroup
+makeGroup :: String -> [Rule SLogic] -> (Id, [Rule SLogic])
+makeGroup s rs =  
+   let a = logic s
+   in (a, map (addRuleToGroup a) rs)
 
-groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, groupDistributionAndOverOr,groupIdempotency, 
-   groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation,
-   groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination :: [Rule SLogic]
+groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, 
+   groupDistributionAndOverOr,groupIdempotency, groupAbsorption, 
+   groupTrueProperties, groupFalseProperties, groupDoubleNegation,
+   groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination,
+   groupInverseDeMorgan, groupInverseDistr :: (Id, [Rule SLogic])
 
 groupCommutativity = makeGroup "Commutativity" 
    [ruleCommOr, ruleCommAnd]
 groupAssociativity = makeGroup "Associativity"
    [ruleAssocOr, ruleAssocAnd]
-
 groupIdempotency = makeGroup "Idempotency"
    [ruleIdempOr, ruleIdempAnd]
 groupAbsorption = makeGroup "Absorption"
@@ -65,9 +79,9 @@ groupDistributionAndOverOr = makeGroup "DistributionAndOverOr"
    [generalRuleAndOverOr, ruleAndOverOr ]
 groupInverseDeMorgan = makeGroup "InverseDeMorgan" 
-    [ inverseDeMorganOr, inverseDeMorganAnd]
+   [inverseDeMorganOr, inverseDeMorganAnd]
 groupInverseDistr = makeGroup "InverseDistr"
-    [ inverseAndOverOr, inverseOrOverAnd]
+   [inverseAndOverOr, inverseOrOverAnd]
    
 -----------------------------------------------------------------------------
 -- Commutativity
@@ -218,7 +232,7 @@ -----------------------------------------------------------------------------
 -- Additional rules, not in the DWA course
 
-groupAdditional :: [Rule SLogic]
+groupAdditional :: (Id, [Rule SLogic])
 groupAdditional = makeGroup "Additional rules"
    [ ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
    , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame
src/Domain/Logic/Strategies.hs view
@@ -1,101 +1,103 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic.Strategies 
-   ( dnfStrategy, dnfStrategyDWA) where
-
-import Prelude hiding (repeat)
-import Domain.Logic.Rules
-import Domain.Logic.GeneralizedRules
-import Domain.Logic.Formula
-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)
-
-dnfStrategyDWA :: LabeledStrategy (Context SLogic)
-dnfStrategyDWA =  label "Bring to dnf (DWA)" $ 
-   repeat $ toplevel <|> somewhereOr
-      (  label "Simplify"                            simplify
-      |> label "Eliminate implications/equivalences" eliminateImplEquiv
-      |> label "Eliminate nots"                      eliminateNots
-      |> label "Move ors to top"                     orToTop
-      )
- where
-    toplevel = useRules 
-       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
-       , ruleAbsorpOr, ruleComplOr
-       ]
-    simplify = somewhere $ useRules
-       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
-       , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse
-       , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd
-       , ruleComplOr, ruleComplAnd
-       ]
-    eliminateImplEquiv = somewhere $ useRules
-       [ ruleDefImpl, ruleDefEquiv
-       ]
-    eliminateNots = somewhere $ useRules
-       [ generalRuleDeMorganAnd, generalRuleDeMorganOr
-       , ruleDeMorganAnd, ruleDeMorganOr
-       ]
-    orToTop = somewhere $ useRules 
-       [ generalRuleAndOverOr, ruleAndOverOr ]
-
--- A specialized variant of the somewhere traversal combinator. Apply 
--- the strategy only at (top-level) disjuncts 
-somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic)
-somewhereOr s =
-   let isOr = 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
-
-dnfStrategy :: LabeledStrategy (Context SLogic)
-dnfStrategy =  label "Bring to dnf"
-      $  label "Eliminate constants"                 eliminateConstants
-     <*> label "Eliminate implications/equivalences" eliminateImplEquiv
-     <*> label "Eliminate nots"                      eliminateNots 
-     <*> label "Move ors to top"                     orToTop
- where
-   eliminateConstants = repeat $ topDown $ useRules
-      [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
-      , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv
-      , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
-      ]
-   eliminateImplEquiv = repeat $ bottomUp $ useRules
-      [ ruleDefImpl, ruleDefEquiv 
-      ] 
-   eliminateNots = repeat $ topDown $ 
-      useRules
-         [ generalRuleDeMorganAnd, generalRuleDeMorganOr ]
-      |> useRules
-         [ ruleDeMorganAnd, ruleDeMorganOr
-         , ruleNotNot
-         ]
-   orToTop = repeat $ somewhere $  
-      liftToContext generalRuleAndOverOr |> 
-      liftToContext ruleAndOverOr
-      
--- local helper function
-useRules :: [Rule SLogic] -> Strategy (Context SLogic)
+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Domain.Logic.Strategies +   ( dnfStrategy, dnfStrategyDWA, somewhereOr+   ) where++import Prelude hiding (repeat)+import Domain.Logic.Rules+import Domain.Logic.GeneralizedRules+import Domain.Logic.Formula+import Common.Context (Context, liftToContext)+import Common.Transformation+import Common.Strategy+import Common.Navigator++-----------------------------------------------------------------------------+-- To DNF, with priorities (the "DWA" approach)++dnfStrategyDWA :: LabeledStrategy (Context SLogic)+dnfStrategyDWA =  label "Bring to dnf (DWA)" $ +   repeat $ toplevel <|> somewhereOr+      (  label "Simplify"                            simplify+      |> label "Eliminate implications/equivalences" eliminateImplEquiv+      |> label "Eliminate nots"                      eliminateNots+      |> label "Move ors to top"                     orToTop+      )+ where+    toplevel = useRules +       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr+       , ruleAbsorpOr, ruleComplOr+       ]+    simplify = somewhere $ useRules+       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd+       , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse+       , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd+       , ruleComplOr, ruleComplAnd+       ]+    eliminateImplEquiv = somewhere $ useRules+       [ ruleDefImpl, ruleDefEquiv+       ]+    eliminateNots = somewhere $ useRules+       [ generalRuleDeMorganAnd, generalRuleDeMorganOr+       , ruleDeMorganAnd, ruleDeMorganOr+       ]+    orToTop = somewhere $ useRules +       [ generalRuleAndOverOr, ruleAndOverOr ]++-- A specialized variant of the somewhere traversal combinator. Apply +-- the strategy only at (top-level) disjuncts +somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic)+somewhereOr s =+   let isOr a = case current a of+                   Just (_ :||: _) -> True+                   _               -> False+   in fix $ \this -> check (Prelude.not . isOr) <*> s +                 <|> check isOr <*> once this++--check1, check2 :: (a -> Bool) -> Rule a+--check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing+--check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing+++-----------------------------------------------------------------------------+-- To DNF, in four steps++dnfStrategy :: LabeledStrategy (Context SLogic)+dnfStrategy =  label "Bring to dnf"+      $  label "Eliminate constants"                 eliminateConstants+     <*> label "Eliminate implications/equivalences" eliminateImplEquiv+     <*> label "Eliminate nots"                      eliminateNots +     <*> label "Move ors to top"                     orToTop+ where+   eliminateConstants = repeat $ topDown $ useRules+      [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd+      , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv+      , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl+      ]+   eliminateImplEquiv = repeat $ bottomUp $ useRules+      [ ruleDefImpl, ruleDefEquiv +      ] +   eliminateNots = repeat $ topDown $ +      useRules+         [ generalRuleDeMorganAnd, generalRuleDeMorganOr ]+      |> useRules+         [ ruleDeMorganAnd, ruleDeMorganOr+         , ruleNotNot+         ]+   orToTop = repeat $ somewhere $  +      liftToContext generalRuleAndOverOr |> +      liftToContext ruleAndOverOr+      +-- local helper function+useRules :: [Rule SLogic] -> Strategy (Context SLogic) useRules = alternatives . map liftToContext
+ src/Domain/Logic/Views.hs view
@@ -0,0 +1,96 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Domain.Logic.Views where++import Common.View+import Domain.Logic.Formula++------------------------------------------------------------+-- Smart constructors++infixr 2 .<->.+infixr 3 .->. +infixr 4 .||. +infixr 5 .&&.++(.<->.) :: Logic a -> Logic a -> Logic a+T .<->. q = q+F .<->. q = nott q+p .<->. T = p+p .<->. F = nott p+p .<->. q = p :<->: q++(.->.) :: Logic a -> Logic a -> Logic a+T .->. q = q+F .->. _ = T+_ .->. T = T+p .->. F = nott p+p .->. q = p :->: q++(.||.) :: Logic a -> Logic a -> Logic a +T .||. _ = T+F .||. q = q+_ .||. T = T+p .||. F = p+p .||. q = p :||: q++(.&&.) :: Logic a -> Logic a -> Logic a+T .&&. q = q+F .&&. _ = F+p .&&. T = p+_ .&&. F = F+p .&&. q = p :&&: q++nott :: Logic a -> Logic a+nott (Not p) = p+nott p       = Not p++-------------------------------------------------+-- Views and transformations++simplify :: Logic a -> Logic a+simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F)++pushNotWith :: (a -> Logic a) -> Logic a -> Logic a+pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F)+ where+   rec logic = +      case logic of+         Not p :<->: q -> p     .<->. q+         p :<->: Not q -> p     .<->. q+         p :<->: q     -> rec p .<->. q+         p :->:  q     -> p     .&&.  rec q+         p :||:  q     -> rec p .&&.  rec q+         p :&&:  q     -> rec p .||.  rec q+         Not p         -> p+         T             -> F+         F             -> T+         Var a         -> f a++pushNot :: Logic a -> Logic a+pushNot = pushNotWith (nott . Var)+         +orView :: View (Logic a) [a]+orView = newView "logic.orView" (($ []) . f) (foldr ((.||.). Var) F)+ where+   f (p :||: q) = (>>= f p) .  f q+   f (Var a)    = return . (a:)+   f F          = return+   f _          = const Nothing++andView :: View (Logic a) [a]+andView = newView "logic.andView" (($ []) . f) (foldr ((.&&.). Var) T)+ where+   f (p :&&: q) = (>>= f p) .  f q+   f (Var a)    = return . (a:)+   f T          = return+   f _          = const Nothing
src/Domain/Math/Approximation.hs view
@@ -23,8 +23,8 @@ -- Precision of a floating-point number  precision :: Int -> Double -> Double-precision n = (/a) . fromIntegral . round . (*a)- where a = 10 Prelude.^ (max 0 n)+precision n = (/a) . fromInteger . round . (*a)+ where a = 10 Prelude.^ max 0 n  ------------------------------------------------------------ -- Stop criteria
src/Domain/Math/Clipboard.hs view
@@ -18,12 +18,12 @@      -- generalized interface    , addToClipboardG, addListToClipboardG    , lookupClipboardG, lookupListClipboardG+   , maybeOnClipboardG    ) 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@@ -47,7 +47,7 @@  modifyExprVar :: IsTerm a => ExprVar a -> (a -> a) -> ContextMonad () modifyExprVar (ExprVar var) f =-   let safe f a = fromMaybe a (f a)+   let safe h a = fromMaybe a (h a)        g = fmap (toTerm . f) . fromTerm    in modifyVar var (safe g) @@ -104,6 +104,11 @@    m    <- readExprVar clipboard    expr <- maybeCM (M.lookup (Key s) m)    fromExpr expr-   ++maybeOnClipboardG :: IsTerm a => String -> ContextMonad (Maybe a)+maybeOnClipboardG s = do +   m <- readExprVar clipboard+   return (M.lookup (Key s) m >>= fromExpr)+ lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a] lookupListClipboardG = mapM lookupClipboardG
src/Domain/Math/Data/Interval.hs view
@@ -30,6 +30,7 @@    , testMe    ) where +import Common.TestSuite import Common.Utils (commaList) import Control.Monad import Data.Maybe@@ -69,8 +70,8 @@    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  (Excluding a) = '(' : show a+showLeft  (Including a) = '[' : show a showLeft  Unbounded     = "(-inf" showRight (Excluding a) = show a ++ ")" showRight (Including a) = show a ++ "]"@@ -203,11 +204,11 @@  isInInterval :: Ord a => a -> Interval a -> Bool isInInterval _ Empty   = False-isInInterval a (I b c) = f GT b && f LT c+isInInterval a (I x y) = f GT x && f LT y  where-   f value x = -      let g c = (c==EQ && isIncluding x) || c==value -      in maybe True (g . compare a) (getPoint x)+   f value b = +      let g c = (c==EQ && isIncluding b) || c==value +      in maybe True (g . compare a) (getPoint b)  --------------------------------------------------------------------- -- Local helper functions@@ -269,9 +270,9 @@       , (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+   coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a+   coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a+   coarbitrary Unbounded     = variant (2 :: Int)  instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where    arbitrary = frequency @@ -279,8 +280,8 @@       , (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+   coarbitrary Empty   = variant (0 :: Int)+   coarbitrary (I a b) = variant (1 :: Int) . coarbitrary a . coarbitrary b     instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where    arbitrary = do@@ -290,42 +291,42 @@ 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)+testMe :: TestSuite+testMe = suite "Intervals" $ do++   suite "Constructor functions" $ do+     addProperty "empty"     $ op0 empty     (const False)+     addProperty "unbounded" $ op0 unbounded (const True)    -   quickCheck $ op1 greaterThan (>)-   quickCheck $ op1 greaterThanOrEqualTo (>=)-   quickCheck $ op1 lessThan (<)-   quickCheck $ op1 lessThanOrEqualTo (<=)-   quickCheck $ op1 singleton (==)+     addProperty "greater than"             $ op1 greaterThan (>)+     addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=)+     addProperty "less than"                $ op1 lessThan (<)+     addProperty "less than or equal to"    $ op1 lessThanOrEqualTo (<=)+     addProperty "singleton"                $ op1 singleton (==)    -   quickCheck $ op2 open      (<)  (<)-   quickCheck $ op2 closed    (<=) (<=)-   quickCheck $ op2 leftOpen  (<)  (<=)-   quickCheck $ op2 rightOpen (<=) (<)+     addProperty "open"       $ op2 open      (<)  (<)+     addProperty "closed"     $ op2 closed    (<=) (<=)+     addProperty "left open"  $ op2 leftOpen  (<)  (<=)+     addProperty "right open" $ op2 rightOpen (<=) (<)    -   -- From/to lists-   quickCheck fromTo1-   quickCheck fromTo2+   suite "From/to lists" $ do+      addProperty "" fromTo1+      addProperty "" fromTo2    -   -- Combinators-   quickCheck defExcept-   quickCheck defUnion-   quickCheck defIntersect-   quickCheck defComplement+   suite "Combinators" $ do+      addProperty "except"     defExcept+      addProperty "union"      defUnion+      addProperty "intersect"  defIntersect+      addProperty "complement" defComplement    -   -- Combinator properties-   quickCheck $ selfInverse complement-   quickCheck $ transitive  union-   quickCheck $ commutative union-   quickCheck $ absorption  union-   quickCheck $ transitive  intersect-   quickCheck $ commutative intersect-   quickCheck $ absorption  intersect+   suite "Combinator properties" $ do+      addProperty "inverse complement"    $ selfInverse complement+      addProperty "transitive union"      $ transitive  union+      addProperty "commutative union"     $ commutative union+      addProperty "absorption union"      $ absorption  union+      addProperty "transitive intersect"  $ transitive  intersect+      addProperty "commutative intersect" $ commutative intersect+      addProperty "absorption intersect"  $ absorption  intersect  fromTo1, fromTo2 :: Intervals Int -> Bool fromTo1 a = fromList (toList a) == a
src/Domain/Math/Data/OrList.hs view
@@ -13,14 +13,14 @@    ( OrList    , orList, (\/), true, false    , isTrue, isFalse-   , disjunctions, normalize, idempotent-   , orView+   , disjunctions, normalize, idempotent, fromBool+   , oneDisjunct, orListView    ) where  import Common.View import Control.Monad-import Common.Traversable-import Common.Rewriting.Term+import Common.Classes+import Common.Rewriting import qualified Domain.Logic.Formula as Logic import Domain.Logic.Formula (Logic((:||:))) import Test.QuickCheck@@ -67,6 +67,15 @@ idempotent T           = T idempotent (OrList xs) = OrList (nub xs) +oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a)+oneDisjunct f xs = +   case disjunctions xs of +      Just [a] -> f a+      _ -> fail "oneDisjunct"++fromBool :: Bool -> OrList a+fromBool b = if b then true else false+ ------------------------------------------------------------ -- Instances @@ -74,6 +83,8 @@ joinOr :: OrList (OrList a) -> OrList a joinOr = maybe T (foldr (\/) false) . disjunctions +instance Rewrite a => Rewrite (OrList a)+ instance Functor OrList where    fmap _ T           = T    fmap f (OrList xs) = OrList (map f xs)@@ -82,9 +93,6 @@    return  = OrList . return    m >>= f = joinOr (fmap f m) -instance Once OrList where-   onceM = useOnceJoin- instance Switch OrList where    switch T           = return T    switch (OrList xs) = liftM orList (sequence xs)@@ -93,17 +101,9 @@    crush T           = []    crush (OrList xs) = xs -instance OnceJoin OrList where-   onceJoinM _ T = mzero-   onceJoinM f (OrList xs) = rec xs-    where-      rec []     = mzero-      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+   toTerm = toTerm . build orListView+   fromTerm expr = fromTerm expr >>= matchM orListView  instance Arbitrary a => Arbitrary (OrList a) where    arbitrary = do @@ -111,8 +111,8 @@       xs <- vector n       return (OrList xs) instance CoArbitrary a => CoArbitrary (OrList a) where-   coarbitrary T           = variant 0-   coarbitrary (OrList xs) = variant 1 . coarbitrary xs+   coarbitrary T           = variant (0 :: Int)+   coarbitrary (OrList xs) = variant (1 :: Int) . coarbitrary xs  instance Show a => Show (OrList a) where    show T = "true"@@ -123,8 +123,8 @@ ------------------------------------------------------------ -- View to the logic data type  -orView :: View (Logic a) (OrList a)-orView = makeView f g +orListView :: View (Logic a) (OrList a)+orListView = makeView f g   where    f p  = case p of              Logic.Var a -> return (return a)
src/Domain/Math/Data/Polynomial.hs view
@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- module Domain.Math.Data.Polynomial     ( Polynomial, var, con, raise, power, scale-   , degree, coefficient, terms+   , degree, lowestDegree, coefficient, terms    , isMonic, toMonic, isRoot, positiveRoots, negativeRoots    , derivative, eval, division, longDivision, polynomialGCD    , factorize@@ -21,7 +21,7 @@ import qualified Data.IntSet as IS import Data.Char import Control.Monad-import Common.Traversable+import Common.Classes import Data.List  (nub) import Data.Ratio (approxRational) import Domain.Math.Approximation (newton, within)@@ -50,9 +50,6 @@ instance Functor Polynomial where    fmap f (P m) = P (IM.map f m) -instance Once Polynomial where-   onceM f (P m) = liftM P (onceM f m)- instance Switch Polynomial where    switch (P m) = liftM P (switch m) @@ -97,6 +94,13 @@    | otherwise  = IS.findMax is  where is = IM.keysSet m +lowestDegree :: Polynomial a -> Int+lowestDegree (P m)+   | IS.null is = 0+   | otherwise  = IS.findMin is+ where is = IM.keysSet m++ coefficient :: Num a => Int -> Polynomial a -> a coefficient n (P m) = IM.findWithDefault 0 n m @@ -158,7 +162,7 @@ -- polynomial long division, where p2 is monic monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) monicLongDivision p1 p2-   | d1 >= d2 && isMonic p2 = (toP quot, toP rem)+   | d1 >= d2 && isMonic p2 = (toP quotient, toP remainder)    | otherwise = error $ "invalid monic division" ++ show (p1, p2)  where    d1 = degree p1@@ -166,7 +170,7 @@    xs = map (`coefficient` p1) [d1, d1-1 .. 0]    ys = drop 1 $ map (negate . (`coefficient` p2)) [d2, d2-1 .. 0]    -   (quot, rem) = rec [] xs+   (quotient, remainder) = rec [] xs    toP = P . IM.filter (/= 0) . IM.fromAscList . zip [0..]        rec acc (a:as) | length as >= length ys = @@ -203,10 +207,10 @@            , Just p2 <- [division p p1]            ]             -   candidateRoots :: Polynomial Rational -> [Rational]-   candidateRoots p = nub (map (`approxRational` 0.0001) xs)-    where-       f  = eval (fmap fromRational p)-       df = eval (fmap fromRational (derivative p))-       xs = nub (map (within 0.0001 . take 10 . newton f df) startList)-       startList = [0, 3, -3, 10, -10, 100, -100]+candidateRoots :: Polynomial Rational -> [Rational]+candidateRoots p = nub (map (`approxRational` 0.0001) xs)+ where+    f  = eval (fmap fromRational p)+    df = eval (fmap fromRational (derivative p))+    xs = nub (map (within 0.0001 . take 10 . newton f df) startList)+    startList = [0, 3, -3, 10, -10, 100, -100]
src/Domain/Math/Data/PrimeFactors.hs view
@@ -13,10 +13,13 @@    ( PrimeFactors    , factors, multiplicity, coprime    , square, power, splitPower-   , primes+   , primes, greatestPower, allPowers    ) where  import qualified Data.IntMap as IM+import Common.Utils+import Control.Monad+import Data.Maybe  ------------------------------------------------------------- -- Representation@@ -35,9 +38,9 @@ -- Conversion to and from factors  toFactors :: Integer -> Factors-toFactors n-   | n > 0     = rec primes n-   | n < 0     = rec primes (-n)+toFactors a+   | a > 0     = rec primes a+   | a < 0     = rec primes (-a)    | otherwise = IM.singleton 0 1  where    rec [] n       = IM.singleton (fromIntegral n) 1@@ -56,7 +59,7 @@  fromFactors :: Factors -> Integer fromFactors = product . map f . IM.toList- where f (a, i) = fromIntegral a ^ fromIntegral i+ where f (a, i) = toInteger a ^ toInteger i  -- For practical reasons, the list of prime numbers is cut-off after  -- 1000 elements (last primes gives 7919).@@ -121,6 +124,28 @@  power :: PrimeFactors -> Int -> PrimeFactors power (PF a m) i = PF (a^i) (IM.map (*i) m)++greatestPower :: Integer -> Maybe (Integer, Integer)+greatestPower n = do+  guard $ n > 1+  let (as, xs) = unzip $ factors $ fromInteger n+  x <- safeHead xs+  guard $ allsame xs && x > 1+  return (fromIntegral (product as), fromIntegral x)++-- n == a^x with (a,x) == greatestPower n+-- prop_greatestPower n = traceShow n $ +--   maybe True (\(a,x) -> fromIntegral a ^ fromIntegral x == n) $ greatestPower n ++allPowers :: Integer -> [(Integer, Integer)]+allPowers n = do+  (b, e) <- maybeToList $ greatestPower n +  let f i = let (a, r) = e `divMod` i+            in if a > 1 && r == 0 then Just (b^i, a) else Nothing+  mapMaybe f [1..e]++-- prop_allPowers n = traceShow n $ +--   and (map (\(a,x) -> fromIntegral a ^ fromIntegral x == n) (allPowers n))  -- splitPower i a = (b,c)   --  => b^i * c = a
src/Domain/Math/Data/Relation.hs view
@@ -16,6 +16,7 @@      Relational(..), mapLeft, mapRight, updateLeft, updateRight
      -- * Relation data type
    , Relation, relationType, RelationType(..), relationSymbols
+   , notRelation, eval
      -- * Constructor functions
    , makeType, (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.)
      -- * Equation (or equality)
@@ -25,10 +26,10 @@    ) 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 Common.Rewriting
+import Common.Classes
+import Domain.Math.Expr.Symbols (openMathSymbol)
+import Text.OpenMath.Dictionary.Relation1
 import Data.Maybe
 import Test.QuickCheck
 import Control.Monad
@@ -40,7 +41,7 @@    leftHandSide  :: f a -> a
    rightHandSide :: f a -> a
    flipSides     :: f a -> f a -- possibly also flips operator 
-   constructor   :: f a -> (b -> b -> f b)
+   constructor   :: f a -> b -> b -> f b
    isSymmetric   :: f a -> Bool
    -- default definitions
    isSymmetric _ = False
@@ -74,31 +75,56 @@    leftHandSide  = lhs
    rightHandSide = rhs
    flipSides (R x rt y) = R y (flipRelType rt) x
-   constructor (R _ rt _) x y = R x rt y
+   constructor (R _ rt _) = flip R rt
    isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType
 
 instance IsTerm a => IsTerm (Relation a) where
    toTerm p = 
       let op  = relationType p
-          sym = maybe (toSymbol (show op)) snd (lookup op relationSymbols)
+          sym = maybe (newSymbol (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) 
+   fromTerm term = 
+      case getFunction term of
+         Just (s, [a, b]) ->
+            case [ rt | (rt, (_, t)) <- relationSymbols, s==t ] of
+               [rt] -> liftM2 (makeType rt) (fromTerm a) (fromTerm b)
+               _    -> fail "fromTerm: relation"
+         _ -> fail "fromTerm: relation"
 
 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))
+   [ (EqualTo,              ("==", openMathSymbol eqSymbol))
+   , (NotEqualTo,           ("/=", openMathSymbol neqSymbol))
+   , (LessThan,             ("<",  openMathSymbol ltSymbol))
+   , (GreaterThan,          (">",  openMathSymbol gtSymbol))
+   , (LessThanOrEqualTo,    ("<=", openMathSymbol leqSymbol))
+   , (GreaterThanOrEqualTo, (">=", openMathSymbol geqSymbol))
+   , (Approximately,        ("~=", openMathSymbol approxSymbol))
    ]
 
+notRelation :: Relation a -> Relation a
+notRelation r = r { relationType = relationType r ? table }
+ where
+   table = xs ++ map swap xs ++ [(Approximately, Approximately)]
+   swap (x, y) = (y, x)
+   xs = [ (EqualTo, NotEqualTo)
+        , (LessThan, GreaterThanOrEqualTo)
+        , (LessThanOrEqualTo, GreaterThan) 
+        ]
+
+eval :: Ord a => RelationType -> a -> a -> Bool
+eval relType =
+   case relType of
+      EqualTo              -> (==)
+      NotEqualTo           -> (/=)
+      LessThan             -> (<)
+      GreaterThan          -> (>)
+      LessThanOrEqualTo    -> (<=)
+      GreaterThanOrEqualTo -> (>=)
+      Approximately        -> (==)
+
 -- helpers   
 showRelType :: RelationType -> String
 showRelType = fst . (? relationSymbols)
@@ -115,18 +141,12 @@ -----------------------------------------------------------------------------
 -- 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]
@@ -176,7 +196,10 @@ 
 instance Functor Equation where
    fmap f (x :==: y) = f x :==: f y
-   
+
+instance Zip Equation where
+   fzipWith f (a :==: b) (c :==: d) = f a c :==: f b d
+
 instance Relational Equation where
    leftHandSide  = leftHandSide  . build equationView
    rightHandSide = rightHandSide . build equationView
@@ -184,7 +207,6 @@    constructor   = const (:==:)
    isSymmetric   = const True
 
-instance Once   Equation where onceM  = onceMRelation
 instance Switch Equation where switch = switchRelation
 instance Crush  Equation where crush  = crushRelation
 
@@ -232,7 +254,6 @@       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
 
@@ -264,17 +285,4 @@ 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
@@ -80,14 +80,14 @@ recipSqMap m =     case M.toList m of       []       -> error "division by zero"-      [(n, x)] -> M.singleton n (recip (x Prelude.* fromIntegral n))-      _        -> (a-b) * recipSqMap (makeMap ((a*a) - (b*b)))+      [(n, x)] -> M.singleton n (recip (x * fromIntegral n))+      _        -> (a .-. b) .*. recipSqMap (makeMap ((a .*. a) .-. (b .*. b)))  where    (ys, zs) = splitAt (length xs `div` 2) xs    (a, b)   = (M.fromList ys, M.fromList zs)    xs  = M.toList m-   (*) = timesSqMap-   (-) = minusSqMap+   (.*.) = timesSqMap+   (.-.) = minusSqMap  sqrtPF :: Num a => P.PrimeFactors -> SqMap a sqrtPF n@@ -100,13 +100,13 @@ -- Type class instances  instance Num a => Show (SquareRoot a) where-   show (S b m) = g (map f (M.toList m)) ++ imPart+   show (S isNeg m) = g (map f (M.toList m)) ++ imPart     where        f (n, a) = ( signum a == -1                  , times (guard (abs a /= 1) >> Just (show (abs a)))                          (guard (n /= 1)     >> Just ("sqrt(" ++ show (toInteger n) ++ ")"))                  )-      imPart = if b then " (imaginary number)" else "" +      imPart = if isNeg then " (imaginary number)" else ""        g []         = "0"       g ((b,x):xs) = (if b then "-" else "") ++ x ++ concatMap h xs       h (b, x)     = (if b then " - " else " + ") ++ x@@ -147,7 +147,7 @@ fromSquareRoot :: Num a => SquareRoot a -> Maybe a fromSquareRoot a =    case toList a of-      [(a, n)] | n==1 -> Just a +      [(b, n)] | n==1 -> Just b        []              -> Just 0       _ -> Nothing @@ -165,7 +165,7 @@ scale a sr = if a==0 then 0 else fmap (*a) sr                 isqrt :: Integer -> Integer-isqrt = floor . Prelude.sqrt . fromInteger+isqrt = (floor :: Double -> Integer) . Prelude.sqrt . fromInteger  sqrtRational :: Fractional a => Rational -> SquareRoot a sqrtRational r = scale (1/fromIntegral b) (sqrt (a*b))
+ src/Domain/Math/Derivative/Exercises.hs view
@@ -0,0 +1,219 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Derivative.Exercises 
+   ( derivativeExercise, derivativePolyExercise
+   , derivativeProductExercise, derivativeQuotientExercise
+   , derivativePowerExercise
+   ) where
+
+import Common.Library
+import Common.Uniplate
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Domain.Math.Derivative.Rules
+import Domain.Math.Derivative.Strategies
+import Domain.Math.Examples.DWO5
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.CleanUp
+import Domain.Math.Polynomial.Generators
+import Domain.Math.Polynomial.RationalExercises
+import Domain.Math.Polynomial.Views
+import Prelude hiding (repeat, (^))
+import Test.QuickCheck
+
+derivativePolyExercise :: Exercise Expr
+derivativePolyExercise = describe
+   "Find the derivative of a polynomial. First normalize the polynomial \
+   \(e.g., with distribution). Don't make use of the product-rule, or \
+   \other chain rules." $ makeExercise
+   { exerciseId    = diffId # "polynomial"
+   , status        = Provisional
+   , parser        = parseExpr
+   , isReady       = (`belongsTo` polyNormalForm rationalView)
+   , isSuitable    = isPolyDiff
+   , equivalence   = eqPolyDiff
+   , similarity    = simPolyDiff
+   , strategy      = derivativePolyStrategy
+   , navigation    = navigator
+   , examples      = concat (diffSet1 ++ diffSet2 ++ diffSet3)
+   , testGenerator = Just $ liftM (diff . lambda (Var "x")) $ 
+                        sized quadraticGen
+   }
+
+derivativeProductExercise :: Exercise Expr
+derivativeProductExercise = describe
+   "Use the product-rule to find the derivative of a polynomial. Keep \
+   \the parentheses in your answer." $ 
+   derivativePolyExercise
+   { exerciseId    = diffId # "product"
+   , isReady       = noDiff
+   , strategy      = derivativeProductStrategy
+   , examples      = concat diffSet3
+   }
+
+derivativeQuotientExercise :: Exercise Expr
+derivativeQuotientExercise = describe
+   "Use the quotient-rule to find the derivative of a polynomial. Only \
+   \remove parentheses in the numerator." $ 
+   derivativePolyExercise
+   { exerciseId    = diffId # "quotient"
+   , isReady       = readyQuotientDiff
+   , isSuitable    = isQuotientDiff
+   , equivalence   = eqQuotientDiff
+   , strategy      = derivativeQuotientStrategy
+   , ruleOrdering  = ruleOrderingWithId [ruleDerivQuotient]
+   , examples      = concat diffSet4
+   , testGenerator = Nothing
+   }
+
+derivativePowerExercise :: Exercise Expr
+derivativePowerExercise = describe
+   "First write as a power, then find the derivative. Rewrite negative or \
+   \rational exponents." $ 
+   derivativePolyExercise
+   { exerciseId    = diffId # "power"
+   , status        = Experimental
+   , isReady       = \a -> noDiff a && onlyNatPower a
+   , isSuitable    = const True
+   , equivalence   = \_ _ -> True -- \x y -> eqApprox (evalDiff x) (evalDiff y)
+   , strategy      = derivativePowerStrategy
+   , examples      = concat (diffSet5 ++ diffSet6)
+   , testGenerator = Nothing
+   }
+
+derivativeExercise :: Exercise Expr
+derivativeExercise = makeExercise
+   { exerciseId   = describe "Derivative" diffId
+   , status       = Experimental
+   , parser       = parseExpr
+   , isReady      = noDiff
+   , strategy     = derivativeStrategy
+   , ruleOrdering = derivativeOrdering
+   , navigation   = navigator
+   , examples     = concat (diffSet3++diffSet4++
+                            diffSet5++diffSet6++diffSet7++diffSet8)
+   }
+
+derivativeOrdering :: Rule a -> Rule a -> Ordering
+derivativeOrdering = comparing f
+ where
+   f a = (getId a /= j, getId a == i, showId a)
+   i = getId ruleDefRoot
+   j = getId ruleDerivPolynomial
+
+isPolyDiff :: Expr -> Bool
+isPolyDiff = maybe False (`belongsTo` polyViewWith rationalView) . getDiffExpr
+
+isQuotientDiff :: Expr -> Bool
+isQuotientDiff de = fromMaybe False $ do
+   expr <- getDiffExpr de
+   xs   <- match sumView expr
+   let f a = maybe [a] (\(x, y) -> [x, y]) (match divView a)
+       ys  = concatMap f xs
+       isp = (`belongsTo` polyViewWith rationalView)
+   return (all isp ys)
+
+eqPolyDiff :: Expr -> Expr -> Bool
+eqPolyDiff x y = 
+   let f a = fromMaybe (descend f a) (apply ruleDerivPolynomial a)
+   in viewEquivalent (polyViewWith rationalView) (f x) (f y)
+
+eqQuotientDiff :: Expr -> Expr -> Bool
+eqQuotientDiff a b = eqSimplifyRational (make a) (make b)
+ where
+   make = inContext derivativeQuotientExercise . f
+   rs   = [ ruleDerivPolynomial, ruleDerivQuotient, ruleDerivProduct
+          , ruleDerivNegate, ruleDerivPlus, ruleDerivMin
+          ]
+   f x  = case mapMaybe (`apply` x) rs of
+             hd:_ -> f hd
+             []   -> descend f x
+
+readyQuotientDiff :: Expr -> Bool
+readyQuotientDiff expr = fromMaybe False $ do
+   xs <- match sumView expr
+   let f a      = fromMaybe (a, 1) (match divView a)
+       (ys, zs) = unzip (map f xs)
+       isp = (`belongsTo` polyViewWith rationalView)
+       nfp = (`belongsTo` polyNormalForm rationalView)
+   return (all nfp ys && all isp zs)
+
+simPolyDiff :: Expr -> Expr -> Bool
+simPolyDiff x y =
+   let f = acExpr . cleanUpExpr
+   in f x == f y
+
+noDiff :: Expr -> Bool
+noDiff e = null [ () | Sym s _ <- universe e, isDiffSymbol s ]   
+
+onlyNatPower :: Expr -> Bool
+onlyNatPower e = and [ isNat a | Sym s [_, a] <- universe e, isPowerSymbol s ]
+ where
+   isNat (Nat _) = True
+   isNat _       = False
+
+{-
+evalDiff :: Expr -> Expr
+evalDiff expr
+   | isDiff expr = 
+        case concatMap (`applyAll` expr) list of
+           hd:_ -> evalDiff hd 
+           _    -> expr
+   | otherwise = descend evalDiff expr
+ where
+   list = [ ruleDerivPolynomial, ruleDerivPowerFactor
+          , ruleDerivPlus, ruleDerivMin, ruleDerivNegate
+          , ruleDerivProduct, ruleDerivQuotient
+          , ruleDerivPowerChain, ruleDerivSqrtChain, ruleDerivRoot
+          ]
+
+go = checkExercise derivativePowerExercise
+
+raar i = printDerivation derivativePowerExercise expr
+ where 
+   expr = examples derivativePowerExercise !! i
+
+eqApprox :: Expr -> Expr -> Bool
+eqApprox a b = rec 5 doubleList
+ where
+   vs = nub (collectVars a ++ collectVars b)
+ 
+   rec 0 = const True
+   rec n = rec2 n 10
+    
+   rec2 _ 0 ds = undefined -- a==b
+   rec2 n m ds = case eqApproxWith f a b of  
+                    Just b  -> b && rec (n-1) ys 
+                    Nothing -> rec2 n (m-1) ys
+    where
+      (xs, ys) = splitAt (length vs) ds
+      f = (xs !!) . fromMaybe 0 . (`elemIndex` vs)
+
+eqApproxWith :: (String -> Double) -> Expr -> Expr -> Maybe Bool
+eqApproxWith f a b = do
+   d1 <- match doubleView (subst a)
+   d2 <- match doubleView (subst b)
+   return $ abs (d1 - d2) < 1e-9 -- 11 is still ok for example set
+ where 
+    subst (Var s) = Number (f s)
+    subst expr    = descend subst expr
+    
+doubleList :: [Double] -- between -20 and 20
+doubleList = iterate next (pi*exp 1)
+  where   
+    next :: Double -> Double
+    next a = if b > 20 then b-20 else b 
+     where
+       b = a + exp 3 * log 2 -}
+ src/Domain/Math/Derivative/Rules.hs view
@@ -0,0 +1,210 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Derivative.Rules where
+
+import Prelude hiding ((^))
+import Common.Transformation
+import Common.View
+import Control.Monad
+import Domain.Math.Expr
+import Common.Id
+import Common.Rewriting
+import Data.Maybe
+import Domain.Math.Polynomial.Views
+import Domain.Math.Numeric.Views
+import Domain.Math.Data.Polynomial
+import Domain.Math.Power.Views
+import Domain.Math.Power.Utils ( (<&>) )
+
+
+derivativeRules :: [Rule Expr]
+derivativeRules =
+   [ ruleDerivCon, ruleDerivPlus, ruleDerivMin, ruleDerivNegate
+   , ruleDerivMultiple, ruleDerivPower, ruleDerivVar 
+   , ruleDerivProduct, ruleDerivQuotient, ruleDerivPowerChain
+   , ruleSine, ruleLog, ruleDerivSqrt, ruleDerivSqrtChain
+   ]
+
+diff :: Expr -> Expr
+diff = unary diffSymbol
+
+ln :: Expr -> Expr
+ln = unary lnSymbol
+
+lambda :: Expr -> Expr -> Expr
+lambda = binary lambdaSymbol
+
+diffId :: Id
+diffId = newId "calculus.differentiation"
+
+isDiffSymbol, isLambdaSymbol :: Symbol -> Bool
+isDiffSymbol   = (== diffSymbol)
+isLambdaSymbol = (== lambdaSymbol)
+
+-----------------------------------------------------------------
+-- Rules for Diffs
+
+ruleSine :: Rule Expr
+ruleSine = rule (diffId, "sine") $ 
+   \x -> diff (lambda x (sin x))  :~>  cos x
+
+ruleLog :: Rule Expr
+ruleLog = rule (diffId, "logarithmic") $
+   \x -> diff (lambda x (ln x))  :~>  1/x
+       
+ruleDerivPlus :: Rule Expr
+ruleDerivPlus = rule (diffId, "plus") $
+   \x f g -> diff (lambda x (f + g))  :~>  diff (lambda x f) + diff (lambda x g)
+
+ruleDerivMin :: Rule Expr
+ruleDerivMin = rule (diffId, "min") $
+   \x f g -> diff (lambda x (f - g))  :~>  diff (lambda x f) - diff (lambda x g)
+
+ruleDerivNegate :: Rule Expr
+ruleDerivNegate = rule (diffId, "negate") $
+   \x f -> diff (lambda x (-f))  :~>  -diff (lambda x f)
+
+ruleDerivVar :: Rule Expr
+ruleDerivVar = rule (diffId, "var") $
+   \x -> diff (lambda x x)  :~>  1
+
+ruleDerivProduct :: Rule Expr
+ruleDerivProduct = rule (diffId, "product") $
+   \x f g -> diff (lambda x (f * g))  :~>  diff (lambda x f)*g + f*diff (lambda x g)
+
+-- The second rewrite rule should not have been necessary, except that cleaning
+-- up an expression will typically put the negate in front of the division: this
+-- makes sure the rule is triggered anyway.
+ruleDerivQuotient :: Rule Expr
+ruleDerivQuotient = ruleList (diffId, "quotient") 
+   [ \x f g -> diff (lambda x (f/g))  :~>  (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2)
+   , \x f g -> diff (lambda x (-f/g))  :~>  (g*diff (lambda x (-f)) - (-f)*diff (lambda x g)) / (g^2)
+   ]
+
+ruleDerivPolynomial :: Rule Expr
+ruleDerivPolynomial = describe "This rule returns the derivative for all \
+   \expressions that can be turned into a polynomial (of rational numbers). \
+   \The polynomial does not have to be in standard form." $ 
+   makeSimpleRule (diffId, "deriv-of-poly") f
+ where
+   f (Sym d [Sym l [Var v, expr]]) | isDiffSymbol d && isLambdaSymbol l = do
+      let myView = polyViewWith rationalView
+      (s, p) <- match myView expr
+      guard (s==v)
+      return (build myView (s, derivative p))
+   f _ = Nothing
+   
+-----------------------------------
+-- Special rules (not defined with unification)
+
+ruleDerivCon :: Rule Expr
+ruleDerivCon = makeSimpleRule (diffId, "constant") f
+ where 
+   f (Sym d [Sym l [Var v, e]]) 
+      | isDiffSymbol d && isLambdaSymbol l && withoutVar v e = return 0
+   f _ = Nothing
+ 
+ruleDerivMultiple :: Rule Expr
+ruleDerivMultiple = makeSimpleRule (diffId, "constant-multiple") f
+ where 
+    f (Sym d [Sym l [x@(Var v), n :*: e]]) 
+       | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = 
+       return $ n * diff (lambda x e)
+    f (Sym d [Sym l [x@(Var v), e :*: n]]) 
+       | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = 
+       return $ n * diff (lambda x e)
+    f _ = Nothing 
+
+ruleDerivPower :: Rule Expr
+ruleDerivPower = makeSimpleRule (diffId, "power") f
+ where 
+   f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) 
+      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && x==x1 && withoutVar v n =
+      return $ n * (x ^ (n-1)) 
+   f _ = Nothing
+
+ruleDerivPowerChain :: Rule Expr
+ruleDerivPowerChain = makeSimpleRule (diffId, "chain-power") f 
+ where 
+   f (Sym d [Sym l [x@(Var v), Sym p [a, n]]]) 
+      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar v n =
+      return $ n * (a ^ (n-1)) * diff (lambda x a)
+   f _ = Nothing
+   
+ruleDerivSqrt :: Rule Expr
+ruleDerivSqrt = makeSimpleRule (diffId, "sqrt") f
+ where
+   f (Sym d [Sym l [x@(Var _), Sqrt x1]]) 
+      | isDiffSymbol d && isLambdaSymbol l && x==x1 =
+      return $ 1 / (2 * sqrt x) 
+   f _ = Nothing 
+   
+ruleDerivSqrtChain :: Rule Expr
+ruleDerivSqrtChain = makeSimpleRule (diffId, "chain-sqrt") f
+ where
+   f (Sym d [Sym l [x@(Var _), Sqrt a]]) 
+      | isDiffSymbol d && isLambdaSymbol l =
+      return $ (1 / (2 * sqrt a)) * diff (lambda x a)
+   f _ = Nothing 
+   
+ruleDefRoot :: Rule Expr
+ruleDefRoot = rule (diffId, "def-root") $
+   \a b -> root a b :~> a ^ (1/b)
+
+ruleDerivRoot :: Rule Expr
+ruleDerivRoot = rule (diffId, "def-root") $
+   \a b x -> diff (lambda x (root a b)) :~> diff (lambda x (a ^ (1/b)))
+   
+ruleDerivPowerFactor :: Rule Expr
+ruleDerivPowerFactor = makeSimpleRule (diffId, "power-factor") $ \de -> do
+   expr <- getDiffExpr de
+   (a, x, r) <- match myPowerView expr
+   return $ build myPowerView (a*fromRational r, x, r-1)
+   
+-- (a+b)/c  ~>  a/c + b/c
+ruleSplitRational :: Rule Expr
+ruleSplitRational = makeSimpleRule (diffId, "split-rational") $ \expr -> do
+   (up, c) <- match divView expr
+   (a, b)  <- match plusView up
+   return (a/c + b/c)
+   
+myPowerView :: View Expr (Expr, String, Rational)
+myPowerView = makeView f g
+ where
+   f expr = case match timesView expr of
+               Just (a, b) -> do
+                  guard (hasNoVar a)
+                  (x, r) <- match powView b
+                  return (a, x, r)
+                `mplus` do
+                  guard (hasNoVar b)
+                  (x, r) <- match powView a
+                  return (b, x, r)
+               Nothing -> do
+                  (x, r) <- match powView expr
+                  return (1, x, r)
+   g (a, x, r) = a .*. (Var x .^. fromRational r) 
+  
+   powView = (powerView <&> noPowerView) >>> myVarView *** rationalView
+   myVarView   = makeView isVar Var
+   noPowerView = makeView (\expr -> Just (expr, 1)) (build powerView)
+   
+   isVar (Var x) = Just x
+   isVar _       = Nothing
+   
+isDiff :: Expr -> Bool
+isDiff = isJust . getDiffExpr
+
+getDiffExpr :: Expr -> Maybe Expr
+getDiffExpr (Sym d [Sym l [Var _, expr]]) | 
+   isDiffSymbol d && isLambdaSymbol l = Just expr
+getDiffExpr _ = Nothing
+ src/Domain/Math/Derivative/Strategies.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Derivative.Strategies 
+   ( derivativeStrategy, derivativePolyStrategy
+   , derivativeProductStrategy, derivativeQuotientStrategy
+   , derivativePowerStrategy, getDiffExpr
+   ) where
+
+import Common.Library
+import Data.Maybe
+import Domain.Math.Derivative.Rules 
+import Domain.Math.Expr
+import Domain.Math.Polynomial.CleanUp
+import Domain.Math.Polynomial.Views
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Strategies
+import Domain.Math.Power.Rules
+
+import Prelude hiding ((^))
+
+derivativeStrategy :: LabeledStrategy (Context Expr)
+derivativeStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+   label "Derivative" $ repeatS $ somewhere $ 
+      alternatives (map liftToContext derivativeRules)
+      <|> derivativePolyStepStrategy
+      <|> check isDiffC <*> once (once (liftToContext ruleDefRoot))
+ where
+   isDiffC = maybe False isDiff . current
+
+derivativePolyStrategy :: LabeledStrategy (Context Expr)
+derivativePolyStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+   label "derivative-polynomial" $
+      repeatS (somewhere (alternatives (map liftToContext rulesPolyNF)))
+      <*> derivativePolyStepStrategy
+
+rulesPolyNF :: [Rule Expr]
+rulesPolyNF =
+   [ distributionSquare, distributeTimes, merge
+   , distributeDivision, noDivisionConstant
+   ]
+
+derivativeProductStrategy :: LabeledStrategy (Context Expr)
+derivativeProductStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+   label "derivative-product" $
+      repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
+ where
+   list = map liftToContext
+      [ distributeDivision, noDivisionConstant
+      , ruleDerivProduct, defPowerNat
+      , ruleDerivNegate, ruleDerivPlus, ruleDerivMin
+      ]
+
+derivativeQuotientStrategy :: LabeledStrategy (Context Expr)
+derivativeQuotientStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+   label "derivative-quotient" $
+   repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
+   <*> repeatS (exceptLowerDiv (alternatives (map liftToContext rulesPolyNF)))
+ where
+   list = map liftToContext
+      [ ruleDerivQuotient, ruleDerivPlus, ruleDerivMin, ruleDerivNegate ]
+      
+derivativePowerStrategy :: LabeledStrategy (Context Expr)
+derivativePowerStrategy = label "derivative-power" $ 
+   cleanUpStrategy (applyTop cleanUpExpr) (label "split-rational" 
+      (repeatS (somewhere (liftToContext ruleSplitRational)))) <*>
+   configure mycfg powerOfStrategy <*> 
+   repeatS (distr <*> configure mycfg powerOfStrategy) <*>
+   cleanUpStrategy (applyTop cleanUpExpr) (label "use-derivative-rules" 
+      (repeatS (somewhere (alternatives list)))) <*>
+   configure mycfg nonNegBrokenExpStrategy
+ where
+   list = map liftToContext
+      [ ruleDerivPlus, ruleDerivMin, ruleDerivNegate, ruleDerivPowerFactor
+      , ruleDerivCon ]
+   mycfg = [(byName myFractionTimes, Remove)]
+   distr = cleanUpStrategy (applyTop cleanUpExpr) $ 
+      label "distr" (somewhere (alternatives (map liftToContext rulesPolyNF)))
+      
+derivativePolyStepStrategy :: LabeledStrategy (Context Expr)
+derivativePolyStepStrategy = label "derivative-poly-step" $
+   check polyDiff <*> liftToContext ruleDerivPolynomial
+ where
+   polyDiff = maybe False nfPoly . (>>= getDiffExpr) . current
+   nfPoly   = (`belongsTo` polyNormalForm rationalView)
+
+exceptLowerDiv :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)
+exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> 
+   if isDivC a then [0] else [0 .. arity a-1]
+ where 
+   isDivC = maybe False isDiv . current
+   isDiv (_ :/: _) = True
+   isDiv _         = False
− src/Domain/Math/DerivativeExercise.hs 
@@ -1,66 +0,0 @@-{-# OPTIONS -fno-case-merge #-}
------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
--- 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.DerivativeExercise where
-
-import Common.Uniplate (universe)
-import Prelude hiding (repeat, (^))
-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
-
-derivativeExercise :: Exercise Expr
-derivativeExercise = makeExercise
-   { description  = "Derivative"
-   , exerciseCode = makeCode "math" "derivative"
-   , status       = Experimental
-   , parser       = parseExpr
-   , isReady      = noDiff
-   , extraRules   = map liftToContext derivativeRules ++ [tidyup]
-   , strategy     = derivativeStrategy
-   , navigation   = navigator
-   , examples     = [ex1, ex2, ex3, ex4]
-   }
-   
-noDiff :: Expr -> Bool
-noDiff e = null [ () | Sym s _ <- universe e, s == diffSymbol ]   
-
-derivativeStrategy :: LabeledStrategy (Context Expr)
-derivativeStrategy =
-   label "Derivative" $
-   try tidyup <*> Common.Strategy.repeat (derivative <*> try tidyup)
-
-tidyup :: Rule (Context Expr)
-tidyup = liftToContext $ makeSimpleRule "Tidy-up rule" $ \old -> 
-   let new = simplify old
-   in if old==new then Nothing else Just new
-   
-derivative :: Strategy (Context Expr)
-derivative = somewhere $ alternatives (map liftToContext derivativeRules)
-
-ex1, ex2, ex3 :: Expr
-ex1 = diff $ lambda (Var "x") $ Var "x" ^ 2
-ex2 = diff $ lambda (Var "x") $ ((1/3) :*: (x ^ fromInteger 3)) :+: (fromInteger (-3) :*: (x ^ fromInteger 2)) :+: x :+: fromInteger (-5)
- where x = Var "x"
-ex3 = diff $ lambda (Var "x") (2 * Var "x") 
-ex4 = diff $ lambda (Var "x") (ln (Var "x"))
-
-main :: IO ()
-main = forM_ [ex1, ex2, ex3, ex4] $
-   printDerivation derivativeExercise
− src/Domain/Math/DerivativeRules.hs 
@@ -1,110 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.DerivativeRules where
-
-import Prelude hiding ((^))
-import Common.Transformation
-import Domain.Math.Expr
-import Common.Rewriting
-
-derivativeRules :: [Rule Expr]
-derivativeRules =
-   [ ruleDerivCon, ruleDerivPlus, ruleDerivMin
-   , ruleDerivMultiple, ruleDerivPower, ruleDerivVar 
-   , ruleDerivProduct, ruleDerivQuotient {-, ruleDerivChain-}, ruleDerivChainPowerExprs
-   , ruleSine, ruleLog 
-   ]
-
-diff :: Expr -> Expr
-diff = unary diffSymbol
-
-ln :: Expr -> Expr
-ln = unary lnSymbol
-
-lambda :: Expr -> Expr -> Expr
-lambda = binary lambdaSymbol
-
-fcomp :: Expr -> Expr -> Expr
-fcomp = binary fcompSymbol
-
------------------------------------------------------------------
--- Rules for Diffs
-
-ruleSine :: Rule Expr
-ruleSine = rule "Sine" $ 
-   \x -> diff (lambda x (sin x))  :~>  lambda x (cos x)
-
-ruleLog :: Rule Expr
-ruleLog = rule "Logarithmic" $
-   \x -> diff (lambda x (ln x))  :~>  lambda x (1/x)
-       
-ruleDerivPlus :: Rule Expr
-ruleDerivPlus = rule "Sum" $
-   \x f g -> diff (lambda x (f + g))  :~>  diff (lambda x f) + diff (lambda x g)
-
-ruleDerivMin :: Rule Expr
-ruleDerivMin = rule "Sum" $
-   \x f g -> diff (lambda x (f - g))  :~>  diff (lambda x f) - diff (lambda x g)
-
-ruleDerivVar :: Rule Expr
-ruleDerivVar = rule "Var" $
-   \x -> diff (lambda x x)  :~>  1
-
-ruleDerivProduct :: Rule Expr
-ruleDerivProduct = rule "Product" $
-   \x f g -> diff (lambda x (f * g))  :~>  f*diff (lambda x g) + g*diff (lambda x f)
-       
-ruleDerivQuotient :: Rule Expr
-ruleDerivQuotient = rule "Quotient" $ 
-   \x f g -> diff (lambda x (f/g))  :~>  (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2)
-
-{- ruleDerivChain :: Rule Expr
-ruleDerivChain = rule "Chain Rule" f
- where f (Diff x (f :.: g)) = return $ (Diff x f :.: g) :*: Diff x g
-       f _                        = Nothing -}
-
------------------------------------
--- Special rules (not defined with unification)
-
-ruleDerivCon :: Rule Expr
-ruleDerivCon = makeSimpleRule "Constant Term" f
- where 
-   f (Sym d [Sym l [Var v, e]]) 
-      | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars e = return 0
-   f _ = Nothing
- 
-ruleDerivMultiple :: Rule Expr
-ruleDerivMultiple = makeSimpleRule "Constant Multiple" f
- where 
-    f (Sym d [Sym l [x@(Var v), n :*: e]]) 
-       | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars n = 
-       return $ n * diff (lambda x e)
-    f (Sym d [Sym l [x@(Var v), e :*: n]]) 
-       | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars n = 
-       return $ n * diff (lambda x e)
-    f _ = Nothing 
-
-ruleDerivPower :: Rule Expr
-ruleDerivPower = makeSimpleRule "Power" f
- where 
-   f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) 
-      | d == diffSymbol && l == lambdaSymbol && p == powerSymbol && x==x1 && v `notElem` collectVars n =
-      return $ n * (x ^ (n-1)) 
-   f _ = Nothing
-
-ruleDerivChainPowerExprs :: Rule Expr
-ruleDerivChainPowerExprs = makeSimpleRule "Chain Rule for Power Exprs" f 
- where 
-   f (Sym d [Sym l [x@(Var v), Sym p [g, n]]]) 
-      | d == diffSymbol && l == lambdaSymbol && p == powerSymbol && v `notElem` collectVars n =
-      return $ n * (g ^ (n-1)) * diff (lambda x g)
-   f _ = Nothing
+ src/Domain/Math/Equation/BalanceRules.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 Domain.Math.Equation.BalanceRules +   ( plusT, minusT, timesT, divisionT +   ) where++import Common.Transformation+import Common.View+import Control.Monad+import Domain.Math.Data.Relation+import Domain.Math.Numeric.Views+import Domain.Math.Expr++plusT, minusT :: Functor f => Expr -> Transformation (f Expr)+plusT  e = makeTrans $ return . fmap (:+: e)+minusT e = makeTrans $ return . fmap (:-: e)++timesT :: Functor f => Expr -> Transformation (f Expr)+timesT e = makeTrans $ unlessZero e . fmap (e :*:)++divisionT :: Expr -> Transformation (Equation Expr)+divisionT e = makeTrans $ unlessZero e . fmap (:/: e)++unlessZero :: MonadPlus m => Expr -> a -> m a+unlessZero e a = do+   r <- matchM rationalView e+   guard (r /= 0)+   return a
src/Domain/Math/Equation/CoverUpExercise.hs view
@@ -9,22 +9,19 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Domain.Math.Equation.CoverUpExercise (coverUpExercise) where+module Domain.Math.Equation.CoverUpExercise +   ( coverUpExercise, coverUpStrategy +   ) where  import Common.Context import Common.Exercise import Common.Strategy hiding (replicate)-import Common.Transformation-import Common.Uniplate (transform)-import Common.View import Control.Monad-import Data.Ratio import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Equation.CoverUpRules import Domain.Math.Equation.Views import Domain.Math.Examples.DWO1-import Domain.Math.Numeric.Views import Domain.Math.Expr import Prelude hiding (repeat) @@ -33,14 +30,15 @@  coverUpExercise :: Exercise (OrList (Equation Expr)) coverUpExercise = makeExercise -   { description  = "solve an equation by covering up"-   , exerciseCode = makeCode "math" "coverup"+   { exerciseId   = describe "solve an equation by covering up" $+                       newId "algebra.equations.coverup"    , status       = Provisional    , parser       = parseExprWith (pOrList (pEquation pExpr))-   , equivalence  = \_ _ -> True+   -- , equivalence  = \_ _ -> True    , isReady      = solvedEquations-   , extraRules   = map liftToContext coverUpRulesOr+   , extraRules   = coverUpRulesOr    , strategy     = coverUpStrategy+   , navigation   = termNavigator    , examples     = map (orList . return) (concat (fillInResult ++ coverUpEquations))    } @@ -49,8 +47,9 @@     coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) coverUpStrategy = label "Cover-up" $ -   repeat (alternatives $ map (liftToContext . cleanUp) coverUpRulesOr)+   repeat $ somewhere $ alternatives coverUpRulesOr +{- cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr)) cleanUp = doAfter $ fmap $ fmap cleanUpExpr @@ -59,7 +58,7 @@  where    f (Negate a) = liftM negate (f a)    f (Sqrt a)   = match rationalView a >>= rootedRational 2-   f (Sym s [Nat n, a]) | s == rootSymbol =+   f (Sym s [Nat n, a]) | isRootSymbol s =       match rationalView a >>= rootedRational n    f e = match rationalView e @@ -76,7 +75,7 @@    x <- rootedInt a (numerator r)    y <- rootedInt a (denominator r)    return (fromInteger x / fromInteger y)-+-} ------------------------------------------------------------ -- Testing
src/Domain/Math/Equation/CoverUpRules.hs view
@@ -11,12 +11,13 @@ ----------------------------------------------------------------------------- module Domain.Math.Equation.CoverUpRules     ( coverUpRules, coverUpRulesOr+   , coverUp, coverUpOrs    , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight     , coverUpTimes, coverUpNegate    , coverUpNumerator, coverUpDenominator, coverUpSqrt       -- parameterized rules    , ConfigCoverUp, configName, predicateCovered, predicateCombined-   , coverLHS, coverRHS, configCoverUp, varConfig+   , coverLHS, coverRHS, configCoverUp    , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith    , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith    , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith@@ -24,86 +25,89 @@    , coverUpBinaryRule, commOp, flipOp    ) where +import Common.Classes+import Common.Context+import Common.Id+import Common.Rewriting+import Common.Transformation import Common.View-import Domain.Math.Expr-import Domain.Math.Data.Relation import Control.Monad.Identity-import Common.Transformation+import Data.Maybe import Domain.Math.Data.OrList-import Common.Traversable+import Domain.Math.Data.Relation+import Domain.Math.Expr  --------------------------------------------------------------------- -- Constructors for cover-up rules -coverUpBinary2Rule :: (OnceJoin f, Switch f, Relational r) -                   => String -> (Expr -> [(Expr, Expr)]) +coverUpFunction :: (Switch f, Relational r) +                   => (Expr -> [(Expr, Expr)])                     -> (Expr -> Expr -> [f Expr])-                   -> ConfigCoverUp -> Rule (f (r Expr))-coverUpBinary2Rule opName fm fb cfg = -   makeSimpleRuleList name $ onceJoinM $ \eq -> -      (guard (coverLHS cfg) >> coverLeft eq) ++ -      (guard (coverRHS cfg) >> coverRight eq)+                   -> ConfigCoverUp -> r Expr -> [f (r Expr)]+coverUpFunction fm fb cfg eq0 = +   (guard (coverLHS cfg) >> coverLeft eq0) ++ +   (guard (coverRHS cfg) >> coverRight eq0)  where-   name       = coverUpRuleName opName (configName cfg)-   coverRight = map (fmap flipSides) . coverLeft . flipSides-   +   coverRight   = map (fmap flipSides) . coverLeft . flipSides    coverLeft eq = do       (e1, e2) <- fm (leftHandSide eq)       guard (predicateCovered  cfg e1)       new <- fb (rightHandSide eq) e2-      switch $ fmap (guard . predicateCombined cfg) new+      _   <- switch $ fmap (guard . predicateCombined cfg) new       return (fmap (constructor eq e1) new) +coverUpBinaryOrRule :: Relational r+                   => String -> (Expr -> [(Expr, Expr)]) +                   -> (Expr -> Expr -> [OrList Expr])+                   -> ConfigCoverUp -> Rule (OrList (r Expr))+coverUpBinaryOrRule opName fm fb cfg =+   let name = coverUpRuleName opName (configName cfg)+   in makeSimpleRuleList name $ oneDisjunct $ coverUpFunction fm fb cfg+    coverUpBinaryRule :: Relational r => String                    -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr)                    -> ConfigCoverUp -> Rule (r Expr)-coverUpBinaryRule opName fm fb =-   let v = makeView (return . Identity) runIdentity-       fbi x y = [Identity (fb x y)]-   in liftRule v . coverUpBinary2Rule opName fm fbi+coverUpBinaryRule opName fm fb cfg = +   let name = coverUpRuleName opName (configName cfg)+       fb2 a b = [Identity (fb a b)]+   in makeSimpleRuleList name $ map runIdentity . coverUpFunction fm fb2 cfg         coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr)                 -> ConfigCoverUp -> Rule (r Expr) coverUpUnaryRule opName fm fb =     coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb)  -coverUpRuleName :: String -> Maybe String -> String-coverUpRuleName opName viewName =-   "cover-up " ++ opName ++ maybe "" (\s -> " [" ++ s ++ "]") viewName+coverUpRuleName :: String -> String -> Id+coverUpRuleName opName cfg =+   let f = if null cfg then newId else ( cfg # )+   in "algebra.equations.coverup" # f opName  --------------------------------------------------------------------- -- Configuration for cover-up rules  data ConfigCoverUp = Config-   { configName        :: Maybe String+   { configName        :: String    , predicateCovered  :: Expr -> Bool    , predicateCombined :: Expr -> Bool    , coverLHS          :: Bool    , coverRHS          :: Bool    } +-- Default configuration: cover-up part with variables configCoverUp :: ConfigCoverUp configCoverUp = Config-   { configName        = Nothing-   , predicateCovered  = const True-   , predicateCombined = const True+   { configName        = ""+   , predicateCovered  = hasSomeVar+   , predicateCombined = hasNoVar    , coverLHS          = True    , coverRHS          = True    } --- default configuration-varConfig :: ConfigCoverUp -varConfig = configCoverUp-   { configName        = Just "vars"-   , predicateCovered  = hasVars-   , predicateCombined = noVars-   }- --------------------------------------------------------------------- -- Parameterized cover-up rules  coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr))-coverUpPowerWith = coverUpBinary2Rule "power" (isBinary powerSymbol) fb+coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb  where    fb rhs e2 = do       n <- isNat e2@@ -116,10 +120,10 @@ coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-)  coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr)-coverUpMinusLeftWith = coverUpBinaryRule "minus left" isMinus (+)+coverUpMinusLeftWith = coverUpBinaryRule "minus-left" isMinus (+)  coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr)-coverUpMinusRightWith = coverUpBinaryRule "minus right" (flipOp . isMinus) (flip (-))+coverUpMinusRightWith = coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))  -- | Negations are pushed inside coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr)@@ -140,7 +144,7 @@ coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/))  coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr)-coverUpSqrtWith = coverUpUnaryRule "square root" isSqrt (\x -> x*x)+coverUpSqrtWith = coverUpUnaryRule "sqrt" isSqrt (\x -> x*x)  where    isSqrt (Sqrt a) = return a    isSqrt _        = []@@ -148,9 +152,23 @@ --------------------------------------------------------------------- -- Cover-up rules for variables -coverUpRulesOr :: [Rule (OrList (Equation Expr))]-coverUpRulesOr = coverUpPower : map ruleOnce coverUpRules+coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr)+coverUpOrs = join . fmap (f . coverUp)+ where+   f :: Equation Expr -> OrList (Equation Expr)+   f eq = case apply coverUpPower (return eq) of+             Just xs -> coverUpOrs xs+             Nothing -> return eq+                 +coverUp :: Equation Expr -> Equation Expr+coverUp eq = +   case mapMaybe (`apply` eq) coverUpRules of+      hd:_ -> coverUp hd+      _    -> eq +coverUpRulesOr :: IsTerm a => [Rule (Context a)]+coverUpRulesOr = use coverUpPower : map use coverUpRules+ coverUpRules :: [Rule (Equation Expr)] coverUpRules =     [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate@@ -161,15 +179,15 @@ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate,     coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr) -coverUpPower       = coverUpPowerWith       varConfig-coverUpPlus        = coverUpPlusWith        varConfig-coverUpMinusLeft   = coverUpMinusLeftWith   varConfig-coverUpMinusRight  = coverUpMinusRightWith  varConfig-coverUpTimes       = coverUpTimesWith       varConfig-coverUpNegate      = coverUpNegateWith      varConfig-coverUpNumerator   = coverUpNumeratorWith   varConfig-coverUpDenominator = coverUpDenominatorWith varConfig-coverUpSqrt        = coverUpSqrtWith        varConfig+coverUpPower       = coverUpPowerWith       configCoverUp+coverUpPlus        = coverUpPlusWith        configCoverUp+coverUpMinusLeft   = coverUpMinusLeftWith   configCoverUp+coverUpMinusRight  = coverUpMinusRightWith  configCoverUp+coverUpTimes       = coverUpTimesWith       configCoverUp+coverUpNegate      = coverUpNegateWith      configCoverUp+coverUpNumerator   = coverUpNumeratorWith   configCoverUp+coverUpDenominator = coverUpDenominatorWith configCoverUp+coverUpSqrt        = coverUpSqrtWith        configCoverUp  --------------------------------------------------------------------- -- Some helper-functions
src/Domain/Math/Equation/Views.hs view
@@ -19,7 +19,7 @@ import Domain.Math.Data.OrList import Domain.Math.Data.Relation import Common.View-import Common.Traversable+import Common.Classes  -- generalized to relation solvedRelations :: (Crush f, Relational g) => f (g Expr) -> Bool@@ -31,9 +31,9 @@ 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)+      (Just x, Nothing) -> withoutVar x (rightHandSide r)+      (Nothing, Just x) -> withoutVar x (leftHandSide r)+      _ -> hasNoVar (leftHandSide r) && hasNoVar (rightHandSide r)  -- The variable must appear on the left solvedRelationWith :: Relational f => (Expr -> Bool) -> f Expr -> Bool@@ -48,12 +48,12 @@  solvedEquation :: Equation Expr -> Bool solvedEquation eq@(lhs :==: rhs) = -   (eq `belongsTo` equationSolvedForm) || (noVars lhs && noVars rhs)+   (eq `belongsTo` equationSolvedForm) || (hasNoVar lhs && hasNoVar rhs)  equationSolvedForm :: View (Equation Expr) (String, Expr) equationSolvedForm = makeView f g  where-   f (Var x :==: e) | x `notElem` collectVars e =+   f (Var x :==: e) | withoutVar x e =       return (x, e)    f _ = Nothing    g (s, e) = Var s :==: e
src/Domain/Math/Examples/DWO1.hs view
@@ -20,6 +20,7 @@    ) where  import Prelude hiding ((^))+import Common.Rewriting import Domain.Math.Data.Relation import Domain.Math.Expr
src/Domain/Math/Examples/DWO3.hs view
@@ -15,6 +15,7 @@ module Domain.Math.Examples.DWO3 where  import Prelude hiding ((^))+import Common.Rewriting import Domain.Math.Expr  ----------------------------------------------------------
+ src/Domain/Math/Examples/DWO4.hs view
@@ -0,0 +1,502 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Example exercises from the Digital Mathematics Environment (DWO),+-- see: http://www.fi.uu.nl/dwo/gr/frameset.html.+--+-----------------------------------------------------------------------------+module Domain.Math.Examples.DWO4 +   ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit+   , powerEquations, expEquations, logEquations, higherPowerEquations+   , rootEquations, rootEquations2, rootSubstEquations, expEquations2+   ) where++import Prelude hiding ((^))+import Common.Rewriting+import Domain.Math.Data.Relation+import Domain.Math.Expr++----------------------------------------------------------+-- HAVO B applets++-- Hoofdstuk 7, vergelijkingen met machten algebraisch (6)+powerEquations :: [[Equation Expr]]+powerEquations = +  -- los vergelijkingen algebraisch op+  let x = Var "x" in+  [ [ x^14 :==: 25+    , x^(-7) :==: 110+    , 2*x^(3.5) :==: 70+    , 8*x^(-(9.2)) :==: 1000+    ]+  , [ root x 5 :==: 2.9+    , 5 * root x 3 :==: 7+    , root (x^3) 4 :==: 720+    , root (x^2) 5 :==: 5.5+    ]+  , [ 4*x^(-12) :==: 28 +    , 7*x^(5.1) + 16 :==: 100+    , 8*x^(-((1.9))) - 5 :==: 2+    , 0.8 * x^(0.7) + 7 :==: 12.5+    ]+  , [ 4*root x 7 + 7 :==: 11.8+    , 9*x^(3.2)+17 :==: 37+    , 6*x^(-(3.1))-9 :==: 12+    , 0.7 * x^(-(1.1)) + 17 :==: 40+    ]+  ]++-- Hoofdstuk 7, exponentiele vergelijkingen algebraisch (7)+expEquations :: [[Equation Expr]]+expEquations =+  -- los exponentiele vergelijkingen algebraisch op+  let x = Var "x" in+  [ [ 2^x :==: 16 * sqrt 2+    , 2^(x+2) :==: 1/4+    , 3^(x-1) :==: 81+    , 3^(x+5) :==: 243/(sqrt 3)+    ]+  , [ 5^(2-x) :==: 0.04+    , 3^(2*x) :==: 1/9+    , 3^(1-3*x) :==: 81+    , 3^(3*x-2) :==: 3*sqrt 3+    ]+  , [ 5*2^(x-1) :==: 20*sqrt 2+    , 6*5^(2-x) :==: 150+    , 2*7^(4*x-1) :==: 98+    , 8*3^(5-2*x) :==: 72*sqrt 3+    ]+  , [ 2^x-7 :==: 9+    , 4^(3*x)+5 :==: 69+    , 7*3^(2*x+1) :==: 189+    , 5*2^(1-4*x)+11 :==: 51+    ]+  , [ 5^(x-4) :==: (1/5)^(2*x+1)+    , 7^(1-2*x) :==: 1+    , 4^(2*x-3) :==: 2*sqrt 2+    , 2*9^(1-2*x) :==: 6*sqrt 3+    ]+  ]++-- Hoofdstuk 7, logaritmische vergelijkingen algebraisch (8)+logEquations :: [[Equation Expr]]+logEquations =+  -- los algebraisch op+  let x = Var "x" in+  [ [ logBase 2 x :==: 7+    , logBase 3 (x-2) :==: 2+    , logBase 4 (x-3) :==: 1+(1/2)+    , logBase 5 ((1/10)*x-3) :==: -1+    , logBase x 7 :==: 1+    , logBase x 4 :==: -1+    , logBase 2 (x^2-1) :==: 3+    , logBase (1/3) (1-5*x) :==: -1+    ]+  ]+++----------------------------------------------------------+-- VWO A/C applets++-- Hoofdstuk 5, hogeremachtswortels (1)+higherPowerEquations :: [[Equation Expr]]+higherPowerEquations =+  -- bereken exacte oplossing+  let x = Var "x" in+  [ [ 2*x^3+9 :==: 19+    , 4*x^5-17 :==: 27+    , 3*x^7+8 :==: 62+    , 5*x^3-1 :==: 9+    , 6-5*x^3 :==: 76+    , 11-7*x^5 :==: 53+    , 4-(1/5)*x^7 :==: 9+    , 18-11*x^7 :==: 62+    ]+  , [ (1/2)*x^4+5 :==: 12+    , 5*x^6-37 :==: 68+    , 4*x^8-19 :==: 9+    , 5*x^6+7 :==: 97+    , 18-7*x^4 :==: -38+    , 3+(1/3)*x^6 :==: 7+    , 1-(1/9)*x^8 :==: -4+    , 47+15*x^8 :==: 77+    ]+  , [ 18*x^8-11 :==: 7+    , (1/4)*x^6+14 :==: 30+    , 5*x^4+67 :==: 472+    , 5*x^4-1 :==: 4+    , (1/8)*x^7+24 :==: 40+    , (1/5)*x^3+27 :==: 52+    , 32*x^3+18 :==: 22+    , 4*x^3-8 :==: 100+    ]+  , [ 14-2*x^3 :==: 700+    , 4-3*x^5 :==: 100+    , 14-11*x^7 :==: 25+    , 1-3*x^5 :==: 97+    ]+    -- Geef in twee decimalen nauwkeurig+  , [ 3*x^5+7 :==: 15+    , 0.7 * x^4 - 1.3 :==: 2+    , (1/3)*x^7 :==: 720+    ]+  ]++-- Hoofdstuk 5, hogeremachtswortels (2)+rootEquations :: [[Equation Expr]]+rootEquations = +  -- Bereken exacte oplossing+  let x = Var "x" in+  let y = Var "y" in+  [ [ x^4 :==: 6+    , root x 4 :==: 6+    , sqrt x :==: 10+    , root x 5 :==: 2+    ]+  , [ 3*x^5-1 :==: 20+    , 3*root (x-1) 5 - 1 :==: 20+    , (1/10)*sqrt x + 2 :==: 12+    , (1/5)*x^7+8 :==: 26+    ]+  , [ 3*root x 4+2 :==: 14+    , (1/2)*x^8-2 :==: 18+    , 5-2*root x 3 :==: 3+    ]+  -- Maak x vrij+  , [ y :==: x^5+    , y :==: 2*x^5+4+    , y :==: (1/10)*x^3-6+    , y :==: root x 7+    , y :==: 2*root x 3+8+    , y :==: (1/10)*root x 5-6+    ]+  , [ y :==: 3*root x 7-6+    , y :==: (1/4)*x^9-6+    , y :==: 8+(1/2)*root x 3+    ]+  ]++++----------------------------------------------------------+-- VWO B applets++-- Hoofdstuk 1, wortelvergelijkingen+rootEquations2 :: [[Equation Expr]]+rootEquations2 =+  let x = Var "x" in+  -- los algebraisch op+  [ [ 5-2*sqrt x :==: 1+    , 7-3*sqrt x :==: 5+    , 4-2*sqrt x :==: -3+    , 6-3*sqrt x :==: 2+    ]+  , [ 2*sqrt x :==: x+    , 2*sqrt x :==: 3*x+    , x-3*sqrt x :==: 0+    , 3*x-5*sqrt x :==: 0+    ]+  , [ x :==: sqrt (2*x+3)+    , x :==: sqrt (3*x+10)+    , x :==: sqrt (4*x+21)+    , x :==: sqrt (3*x+4)+    ]+  , [ 5*x :==: sqrt (50*x+75)+    , 2*x :==: sqrt (24*x+28)+    , 3*x :==: sqrt (27*x-18)+    , 2*x :==: sqrt (28*x-40)+    , 3*x :==: sqrt (3*x+42)+    , 5*x :==: sqrt (49*x+2)+    , 3*x :==: sqrt (10*x-1)+    , 5*x :==: sqrt (30*x-5)+    ]+  , [ x-sqrt x :==: 6+    , x-4*sqrt x :==: 12+    , x-sqrt x :==: 12+    , x-sqrt x :==: 2+    , 2*x+sqrt x :==: 3+    , 3*x+4*sqrt x :==: 20+    , 2*x+sqrt x :==: 15+    , 2*x-3*sqrt x :==: 27+    ]+  ]++-- Hoofdstuk 1, wortelvergelijkingen+rootSubstEquations :: [[Equation Expr]]+rootSubstEquations =+  let x = Var "x" in+  -- los algebraisch op+  [ [ 8*x^3+1 :==: 9*x*sqrt x+    , 27*x^3 :==: 28*x*sqrt x-1+    , x^3+3 :==: 4*x*sqrt x+    , x^3 :==: 10*x*sqrt x-16+    ]+  , [ x^3 :==: 6*x*sqrt x+16+    , x^3-24*x*sqrt x :==: 81+    , x^3+x*sqrt x :==: 20+    , x^3-15 :==: 2*x*sqrt x+    ]+  , [ x^5+32 :==: 33*x^2*sqrt x+    , 243*x^5-244*x^2*sqrt x+1 :==: 0+    , 32*x^5+31*x^2*sqrt x :==: 1+    , x^5 :==: 242*x^2*sqrt x+243+    ]+  , [ x^5+8 :==: 6*x^2*sqrt x+    , x^5 :==: 9*x^2*sqrt x-18+    , x^5 :==: 5*x^2*sqrt x+24+    , x^5+4*x^2*sqrt x :==:12+    ]+  ]++-- Hoofdstuk 1, gebroken vergelijkingen+brokenEquations :: [[Equation Expr]]+brokenEquations =+   -- Bereken exact de oplossingen+   let x = Var "x" in+   [ [ (2*x^2-10) / (x^2+3) :==: 0+     , (7*x^2-21) / (2*x^2-5) :==: 0+     , (3*x^2-6) / (4*x^2+1) :==: 0+     , (4*x^2-24) / (6*x^2-2) :==: 0+     , x^2 / (x+4) :==: (3*x+4) / (x+4)+     , (x^2+2) / (x-2) :==: (x+8) / (x-2)+     , (x^2+6*x-6)/(x^2-1) :==: (4*x+9)/(x^2-1)+     , (x^2+6)/(x^2-2) :==: (7*x)/(x^2-2)+     ]+   , [ (x^2+6*x)/(x^2-1) :==: (3*x+4)/(x^2-1)+     , (x^2+6)/(x-3) :==: (5*x)/(x-3) +     , (x^2+4*x)/(x^2-4) :==: (3*x + 6)/(x^2-4)+     , (x^2+2*x-4)/(x-5) :==: (4*x+11)/(x-5)+     , (5*x+2)/(2*x-1) :==: (5*x+2)/(3*x+5)+     , (x^2-9)/(4*x-1) :==: (x^2-9)/(2*x+7)+     , (3*x-2)/(2*x^2) :==: (3*x-2)/(x^2+4)+     , (2*x+1)/(x^2+3*x) :==: (2*x+1)/(5*x+8)+     ]+   , [ (x^2-1)/(2*x+2) :==: (x^2-1)/(x+8)+     , (x^2-4)/(3*x-6) :==: (x^2-4)/(2*x+1)+     , (x^2+5*x)/(2*x^2) :==: (x^2+5*x)/(x^2+4)+     , (x^2-3*x)/(2*x-6) :==: (x^2-3*x)/(4*x+2)+     , x/(x+1) :==: 1 + 3/4+     , (x+2)/(3*x) :==: 1 + 1/3+     , (2*x+3)/(x-1) :==: 3 + 1/2+     , (x-3)/(1-x) :==: 1 + 2/5+     ]+   , [ (x+4)/(x+3) :==: (x+1)/(x+2)+     , (2*x+3)/(x-1) :==: (2*x-1) / (x-2)+     , (3*x+6)/(3*x-1) :==: (x+4)/(x+1)+     , (x+2)/(2*x+5) :==: (x+4)/(2*x-3)+     , (x+5)/(2*x) + 2 :==: 5+     , (3*x+4)/(x+2) - 3 :==: 2+     , (x^2)/(5*x+6) + 4 :==: 5+     , (x^2)/(2*x-3) + 3 :==: 7+     ]+   , [ (x-2)/(x-3) :==: x/2+     , (x+9)/(x-5) :==: 2/x+     , (x+2)/(x+4) :==: 2/(x+1)+     , (-3)/(x-5) :==: (x+3)/(x+1)+     , (x+1)/(x+2) :==: (7*x+1)/(2*x-4)+     , (2*x-7)/(5-x) :==: (x+1)/(3*x-7)+     , (x+1)/(x-1) :==: (3*x-7)/(x-2)+     , (3*x-7)/(x-2) :==: (7-x)/(3*x-3)+     ]+   ]+   +-- Hoofdstuk 4, gebroken vorm herleiden (1 en 1a)+normBroken :: [[Expr]]+normBroken =+   -- Herleid+   let x = Var "x" in+   let y = Var "y" in+   let a = Var "a" in+   let b = Var "b" in+   [ [ 7/(2*x) + 3/(5*x), 3/(2*x) + 2/(3*x), 4/(5*x)-2/(3*x)+     , 2/(7*x) - 1/(4*x), 5/(6*a)+3/(7*a), 3/(8*a)+5/(3*a)+     , 7/(2*a)-2/(3*a),  9/(5*a)-1/(2*a)+     ]+   , [ 1/x+1/y, 2/(3*x)+1/(2*y), 3/(x^2*y) - 5/(2*x*y), 2/(x*y)-7/(5*y)+     , 2/a - 3/b, 4/(3*a)-2/(5*b), 2/(a*b)+4/(3*a), 7/(4*a)+3/(4*b)+     ]+   , [ 3+1/(2*x), 2*x+(3/(5*x)), 5/(2*x)-3, 3-5/(7*x), 5/(3*a)+1+     , 4*a+3/(2*a), 2*a-1/(3*a), 7/(5*a)-2+     ]+   , [ 5/(x+2)+4/(x+3), 3/(x-1)+2/(x+3), 4/(x+5)+2/(x-3), 3/(x-2)+2/(x-3)+     , 4/(x+3)-6/(x+2), 1/(x+5)-3/(x-4), 7/(x-3)-2/(x+1), 6/(x-1)-3/(x-2)+     ]+   , [ (x+1)/(x+2)+(x+2)/(x-3), (x-2)/(x+3)+(x-1)/(x+2), (x+3)/(x-1)+(x+2)/(x-4)+     , (x-4)/(x+5)+(x-2)/(x-3), (x-1)/(x+1)-(x+2)/(x-2), (x+5)/(x+3)-(x+3)/(x+5)+     , (x-1)/(x+2)-(x+4)/(x+1), (x-3)/(x-1)-(x+2)/(x+4)+     ]+   , [ (2*x)/(x-1)+x/(x+2), (3*x)/(x-4)+(5*x)/(x-2)+     , (4*x)/(x+2)-(2*x)/(x+1), x/(x+5)-(4*x)/(x+6)+     ]+   ]++-- Hoofdstuk 4, gebroken vorm herleiden (2 en 2a)+normBroken2 :: [[Expr]]+normBroken2 =+   -- Herleid+   let x = Var "x" in+   let a = Var "a" in+   let p = Var "p" in+   [ [ (x^2+4*x-5)/(x^2+5*x-6), (x^2+2*x-8)/(x^2+10*x+24)+     , (x^2-7*x+12)/(x^2+x-20), (x^2+7*x+12)/(x^2+5*x+6)+     , (a^2-a-2)/(a^2+4*a-12), (a^2-3*a-10)/(a^2-a-20)+     , (a^2-2*a-15)/(a^2-3*a-18), (a^2+a-2)/(a^2+3*a+2)+     ]+   , [ (x^2-16)/(x^2+x-12), (x^2-2*x+1)/(x^2-1), (x^2-9)/(x^2+6*x+9)+     , (x^2-7*x+6)/(x^2-1), (2*p^2+8*p)/(p^2-16), (-(p^2)+5*p)/(p^2-10*p+25)+     , (p^2-4)/(4*p^2+8*p), (p^2-12*p+36)/(p^2-6*p)+     ]+   , [ (x^3+3*x^2+2*x)/(x^2+4*x+4), (x^3+10*x^2+24*x)/(x^2+7*x+6)+     , (x^2+5*x+6)/(x^3-x^2-6*x), (x^2+3*x-4)/(x^3-6*x^2+5*x)+     , (a^3+7*a^2+12*a)/(a^2+6*a+9), (a^3+7*a^2+10*a)/(a^2-a-6)+     , (a^2-9)/(a^3-4*a^2+3*a), (a^2-2*a-15)/(a^3-3*a^2-10*a)+     ]+   ]+   +deelUit :: [[Expr]]+deelUit =+   let x = Var "x" in+   let a = Var "a" in+   let p = Var "p" in+   let t = Var "t" in+   [ -- laatste sommen van gebroken vorm herleiden (2), niveau 5+     [ (-6*a^2-1)/a, -2*p^2+3/(7*p), (7*t^2+4)/(-4*t), (9*x^2+8)/(8*x)+     ]+   , -- sommen (2a)+     [ (-7*a^2-4*a-6)/(-6*a), (3*p^2+6*p-8)/p, (2*t^2-9*t-8)/(-2*t)+     , (x^2+5*x+5)/(2*x), (5*a^3-4*a+2)/(9*a), (5*p^3-7*p^2+9)/(2*p)+     , (-3*t^3+6*t-4)/(3*t), (4*x^3-3*x^2+4)/(7*x)+     ]+   ]+   +-- Vervolg hoofdstuk 4, gebroken vorm herleiden (2 en 2a), vanaf niveau 4+normBrokenCon :: [[Equation Expr]]+normBrokenCon =+   -- Herleid+   let a = Var "a" in+   let p = Var "p" in+   let t = Var "t" in+   let ca = symbol (newSymbol "A") in+   let ct = symbol (newSymbol "T") in+   let cn = symbol (newSymbol "N") in+   [ [ ca :==: (p^2+2*p)/(p^2-4), ca :==: (6*p^2-18*p)/(p^2-9)+     , ca :==: (p^2-1)/(-2*p^2+2*p), ca :==: (p^2-16)/(4*p^2+16*p)+     , ct :==: (t^3-2*t^2)/(t^2-4), ct :==: (t^3+4*t^2)/(t^2-16)+     , ct :==: (t^2-1)/(t^3+t^2), ct :==: (t^2-25)/(t^3-5*t^2)+     ]+   , [ cn :==: (a^4+4*a^2-5)/(a^4-1), cn :==: (a^4+5*a^2+6)/(a^4+4*a^2+3)+     , cn :==: (a^4-5*a^2+6)/(a^4-7*a^2+10), cn :==: (a^4-8*a^2+16)/(a^4-5*a^2+4)+     ]+   ]++-- Hoofdstuk 5, exponentiele vergelijkingen exact oplossen (1, 2, 2a)+expEquations2 :: [[Equation Expr]]+expEquations2 =+  let x = Var "x" in+  -- los algebraisch op+  -- 1+  [ [ 2^(2*x-1) :==: 1/16+    , 3^(1-x) :==: 81+    , 5^(1-2*x) :==: 1/5+    , (1/2)^(4*x-3) :==: 1/4+    , (1/3)^(5*x+2) :==: 1/3+    , 6^(3*x-2) :==: 1/216+    ]+  , [ 2^(3*x+2) :==: 2*sqrt 2+    , 3^(2*x+1) :==: 9*sqrt 3+    , 5^(4*x+3) :==: 625*sqrt 5+    , (1/2)^(x+1) :==: 4+    , (1/3)^(x-3) :==: 3+    , 4^(x+2) :==: 64*root 4 3+    ]+  , [ 2^(x+3) :==: (1/2)*root 2 3+    , 3^(4*x+1) :==: 27+    , 5^(-x+2) :==: 1/25+    , (1/2)^(1-x) :==: sqrt 2+    , (1/3)^(x+1) :==: (1/9)*sqrt 3+    , 2^(1-3*x) :==: (1/8)*sqrt 2+    ]+  , [ 3*2^x+1 :==: 25+    , 4*3^x-9 :==: 27+    , 2*5^x+4 :==: 14+    , 5*(1/2)^x+11 :==: 51+    , 8*(1/3)^x+27 :==: 99+    , 3*(1/5)^x-35 :==: 40+    ]+  , [ 2^(4*x+3) :==: 1+    , (1/2)^(2*x-1) :==: 1+    , 3^(2*x+4) :==: 1+    , (1/3)^(x-3) :==: 1+    , 4^(4*x-7) :==: 1+    , 5^(3*x-6) :==: 1+    ]+  -- 2+  , [ 2^(2*x+1) :==: (1/2)^(x+2)+    , 4^(2*x-1) :==: 2^(3*x+2)+    , 2^(5*x-4) :==: 8^(x-3)+    , (1/4)^(2*x+1) :==: 2^(6-2*x)+    , (1/3)^(2*x-3) :==: 3^(4*x-3)+    , 3^(3*x-2) :==: 9^(2-x)+    , 27^(2*x+1) :==: 3^(2*x-5)+    , 3^(5*x-1) :==: (1/9)^(2*x-1)+    ]+  , [ 6^(7*x-3) :==: 36^(2*x+3)+    , (1/7)^(2*x-1) :==: 7^(2*x-7)+    , 5^(5-2*x) :==: (1/5)^(x+2)+    , 25^(4*x+1) :==: 5^(5*x-4)+    , 3^(x^2) :==: (1/3)^(2*x)+    , (1/2)^(x^2) :==: 2^(2*x)+    , 5^(x^2) :==: 25^(3*x)+    , 2^(x^2) :==: (1/8)^(-x)+    ]+  , [ (1/2)^(2-2*x) :==: 4^(3*x+5)+    , 8^(x+1) :==: (1/2)^(x+7)+    , (1/4)^(x+2) :==: 8^(2*x-1)+    , 8^(2*x-3) :==: 16^(2*x+3)+    , (1/3)^(x-2) :==: 9^(x+4)+    , 9^(2*x-1) :==: 27^(2*x-1)+    , (1/9)^(x+3) :==: 27^(2*x+2)+    , 27^(3-2*x) :==: (1/3)^(4*x+3)+    ]+  , [ 4*2^x :==: 2^(3*x-2)+    , 2^(5*x-9) :==: (1/8)*2^x+    , 3^(4*x+6) :==: 27*3^x+    , (1/9)*3^x :==: 3^(2-3*x)+    , 3*3^x :==: (1/3)^(2*x+5)+    , 4^(x+1) :==: 8*2^x+    , (1/2)*2^x :==: (1/2)^x+    , 9^(x+2) :==: (1/3)*3^x+    ]+  , [ (1/5)*5^(3*x-2) :==: 25^(x+1)+    , 9*3^(2*x+1) :==: (1/3)^(4*x-3)+    , 4^(3*x-5) :==: 8*2^(x+2)+    , (1/2)^(3-2*x) :==: (1/4)*2^(3*x-4)+    , 2^(x+2)+2^x :==: 40+    , 2^(x+4) :==: 3/4+2^(x+2)+    , 2^(x-2)+2^(x+1) :==: 9+    , 2^(x+5)-2^(x+4) :==: 16+    ]+  -- 2a+  , [ 3^(x+2) :==: 72+3^x+    , 3^(x-1)+3^(x+1) :==: 10+    , 3^(x+3)+3^(x+2) :==: 12+    , 3^x-3^(x-1) :==: 54+    ]+  , [ 5^(x+1)+5^x :==: 150+    , 5^(x+1) :==: 100+5^x+    , 5^(x+2)+5^x :==:1+1/25+    , 5^(x+1)+5^(x+2) :==: 30+    ]+  , [ 2^(x+4)-2^(x-2) :==: 63*sqrt 2+    , 3^(x-1)+3^x :==: 12*sqrt 3+    , 5^x-5^(x-1) :==: 4*sqrt 5+    , 2^(x+2)+2^(x-3) :==: 66*sqrt 2+    ]+  ]
+ src/Domain/Math/Examples/DWO5.hs view
@@ -0,0 +1,167 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Example exercises from the Digital Mathematics Environment (DWO),+-- see: http://www.fi.uu.nl/dwo/gr/frameset.html.+--+-----------------------------------------------------------------------------+module Domain.Math.Examples.DWO5 +   ( diffSet1, diffSet2, diffSet3, diffSet4+   , diffSet5, diffSet6, diffSet7, diffSet8+   ) where++import Domain.Math.Expr+import Prelude hiding ((^))+import Data.Maybe++differentiateLists :: [[Expr]] -> [[Expr]]+differentiateLists = map (map differentiate)++differentiate :: Expr -> Expr+differentiate a = +   let x = fromMaybe "x" (selectVar a) +   in unary diffSymbol $ binary lambdaSymbol (Var x) a++----------------------------------------------------------+-- HAVO B applets++-- Hoofdstuk 6, differentieer+-- Bereken de afgeleide+diffSet1 :: [[Expr]]+diffSet1 = differentiateLists $+   let x = Var "x" in+   let p = Var "p" in+   let q = Var "q" in+   let r = Var "r" in+   [ [ 3*x^4 - 7*x^2, -x^3-5*x, 1/2*x^6-5*x^2+4, -1/3*x^3+(1+1/2)*x^2-x+1]+   , [ -x^5+5*x+23, -2*p^4+5*p-12, 3/5*q^5-q^3+4*q, -2/3*r^6+1/4*r^4-3*r+7]  +   , -- werk eerst de haakjes weg+     [ (x-2)^2, -(1-3*x)^2, (x-1)*(2*x+5), -(1-3*x)*(2*x+7)]+     -- differentieer+   , [x^3-x*(x+5), -2*(p+1)*(p-12), q*(q^5-q^3)+3*q^2+4, -3*r*(r-1)*(r+2)]+   ]+   +----------------------------------------------------------+-- VWO A/C applets++-- Hoofdstuk 7, differentieer+diffSet2 :: [[Expr]]+diffSet2 = differentiateLists $+   let x = Var "x" in+   [ [ 5*x^2, -4*x^2, 10*x^2-8, -8*x^2+7]+   , [ 3*x^2+4*x, -0.5*x^2-2*x, -8*x^2+7*x-3, -0.25*x^2+x-1]+   , [ (x+2)^2, (5*x+7)*(4-3*x), (3*x+6)^2-8*x+     , 5*(x-3)^2+5*x, 5*(x-3)^2+5*(2*x-1), -3*(x-1)*(5-9*x)-8*(x-7) ]+   ]+   +-- Hoofdstuk 7, bereken de afgeleide: zelfde als Havo B applet++----------------------------------------------------------+-- VWO B applets++-- Hoofdstuk 3, differentieren: zelfde als Havo B applet++-- Hoofdstuk 7+-- Gebruik de productregel+diffSet3 :: [[Expr]]+diffSet3 = differentiateLists $+   let x = Var "x" in+   [ [ (x^2+2*x)*(3*x+5), (2*x^2-3*x)*(4*x+1), (3*x^3+4*x)*(x^2-2)+     , (4*x^3-x)*(3*x^2+7*x), (x^2+2*x)*(x^3-4*x^2+3), (5*x-7)*(2*x^3-3*x+1)+     , (3*x^2+2)*(5*x^3+4*x^2-7*x), (4*x+1)*(3*x^3-x^2+2*x)+     ]+   , [ (3*x+1)^2, (5*x-2)^2, (2*x+7)^2, (4*x-3)^2+     , (2*x^2-3*x)^2, (3*x^2+2)^2, 2*x^3-3*x^2, (5*x^3+7*x)^2+     ]+   ]+   +-- Gebruik de quotientregel+diffSet4 :: [[Expr]]+diffSet4 = differentiateLists $+   let x = Var "x" in+   [ [ 5/(x-1), 3/(x+2), (-2)/(x-3), (-3)/(x+4), 3/(2*x-1)+     , 2/(3*x+4), (-4)/(3*x-1), (-2)/(4*x+3) +     ]+   , [ (x+1)/(x-2), (x-3)/(x+4), (x+5)/(x-1), (x-2)/(x+1)+     , (2*x+3)/(4*x-1), (3*x-1)/(2*x+1), (4*x+3)/(3*x-2), (5*x-2)/(3*x+4)+     ]+   , [ (3*x^2)/(2*x^3+4), (2*x^3)/(3*x^2-1), (x^2)/(4*x^3-2)+     , (3*x^3)/(5*x^2+7), (1-x^3)/(x+4), (x+3)/(2-x^2)+     , (1-2*x^3)/(x+1), (x+5)/(2-3*x^2)+     ]+   , [ (2-x)/(x^2+1)+2*x^3, (x^3-3)/(4-x)+x^2+     , (3-2*x)/(2*x^2-3)+x^3, (2*x^3-4)/(6-5*x)+4*x^2+     ] +   ]+   +-- differentieer x^n (n geheel), noteer zonder negatieve exponent+diffSet5 :: [[Expr]]+diffSet5 = differentiateLists $+   let x = Var "x" in+   [ [ 4/x^2, 5/x^3, 2/x^4, 3/x^5, 1/9*x^2, 1/7*x^3, 1/5*x^4, 1/8*x^5 ]+   , [ 3*x^2-4/(x^2), 7*x^3-2/(x^3), 2*x^4-5/(x^4), 2*x^5-6/(x^5) +     , (3*x+2)/(x^3), (2*x^2-4)/x^5, (4*x-3)/x^2, (6*x^2+5)/x^4 +     ]+   , -- herleid de afgeleide tot 1 breuk+     [ (2*x^4+3)/x^2, (2*x^5-5)/x^3, (4*x^5-1)/x^2, (4*x^4+3)/x^3+     , (3*x-1)/(7*x^2), (2*x^3+1)/(3*x^4), (x^2-2)/(3*x^3), (x+5)/(6*x^3)+     ]+   ]+   +-- differentieer x^r (r uit R), noteer zonder negatieve en gebroken exponent+diffSet6 :: [[Expr]]+diffSet6 = differentiateLists $+   let x = Var "x" in+   [ [ x*root x 3, x^3*sqrt x, x*root x 5, x^4*sqrt x, 1/(x*root x 3)+     , 1/(x^3*sqrt x), 1/(x*root x 5), 1/(x^4*sqrt x)+     ]+   , [ x^2*root (x^2) 3, x*root (x^3) 4, x^3*root (x^2) 5, x^2*root (x^3) 5+     , (x^3+1)*(2+sqrt x), (3+x^2)*(1+root x 3), (x^2+1)*(root x 3+2)+     , (3+x^3)*(sqrt x+1) +     ]+   , [ (sqrt x + 1)^2, (x*sqrt x-3)^2, (sqrt x-2)^2, (x*sqrt x+1)^2+     , (x+2)/sqrt x, (x-3)/sqrt x, (x-4)/sqrt x, (x+5)/sqrt x+     ]+   , [ (x-2)/(x*sqrt x), (x+3)/(x*sqrt x), (x+4)/(x*sqrt x), (x-5)/(x*sqrt x)+     , (x^2+2)/(3*sqrt x), (x^2-3)/(4*sqrt x)+     , (x^2+4)/(2*sqrt x), (x^2-6)/(3*sqrt x)+     ]+   , [ (x+3)/(x^2*sqrt x), (x-1)/(x^3*sqrt x), (x-2)/(x^2*sqrt x)+     , (x+4)/(x^3*sqrt x), (sqrt x-2)/x^2, (2*sqrt x+1)/x^2+     , (1-sqrt x)/x, (3*sqrt x+2)/x+     ]+   ]+   +-- differentieren met de kettingregel+diffSet7 :: [[Expr]]+diffSet7 = differentiateLists $+   let x = Var "x" in+   [ [ 2*(x^2+3*x)^5, 3*(x^3-4*x)^6, -6*(x^2+2*x)^4, -5*(x^3-3*x^2)^3]+   , [ -(2/(x^2+3*x)^5),-(3/(x^3-4*x)^6), 6/(x^2+2*x)^4, 5/(x^3-3*x^2)^3]+   , [ sqrt (3*x^4-x), sqrt (x^3+5*x^2), sqrt (6*x^2+x), sqrt (7*x^3-3*x^2)]+   , [ 1/sqrt (3*x-2), 1/sqrt (8*x+5), 1/sqrt (3*x-4), 1/sqrt (5*x-2)]+   , [ (2*x-1)^2*sqrt (2*x-1), (3*x^2+2)*sqrt (3*x^2+2)+     , (3*x+5)^3*sqrt (3*x+5), (4*x^3-7)*sqrt (4*x^3-7)+     ]+   ]+   +-- differentieren met de kettingregel gecombineerd+diffSet8 :: [[Expr]]+diffSet8 = differentiateLists $+   let x = Var "x" in+   [ [ 2*x*sqrt (4*x+3), 3*x*sqrt (2*x-5), 4*x*sqrt (3*x+2), 2*x*sqrt (5*x-3)]+   , [ x^2*(4*x^2-2)^3, x^3*(3*x-4)^3, x^4*(3*x^2+1)^5, x^5*(4*x+3)^4]+   , [ (x+3)/sqrt (2*x-1), (x+7)/sqrt (4*x+3)+     , (x-2)/sqrt (3*x+1), (x-7)/sqrt (5*x-4) +     ]+   , [ sqrt (2*x^2-1)/(x+3), sqrt (4*x^2+3)/(x+7)+     , sqrt (3*x^2+1)/(x-2), sqrt (5*x^2-4)/(x-7)+     ]+   ]
src/Domain/Math/Expr.hs view
@@ -10,15 +10,15 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Expr -   ( module Domain.Math.Expr.Data+   ( module Common.Rewriting.Term+   , module Domain.Math.Expr.Data    , module Domain.Math.Expr.Parser-   , module Domain.Math.Expr.Symbolic    , module Domain.Math.Expr.Symbols    , module Domain.Math.Expr.Views    ) where  import Domain.Math.Expr.Data import Domain.Math.Expr.Parser-import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Expr.Views+import Common.Rewriting.Term hiding (Term(..))
src/Domain/Math/Expr/Data.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XDeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -12,18 +12,18 @@ ----------------------------------------------------------------------------- module Domain.Math.Expr.Data where -import Data.Char (isAlphaNum)-import Data.Ratio-import Data.Typeable-import Test.QuickCheck-import Control.Monad+import Common.Rewriting import Common.Uniplate import Common.Utils (commaList) import Common.View-import Common.Rewriting hiding (operators)-import Domain.Math.Expr.Symbolic+import Control.Monad+import Data.Char (isAlphaNum)+import Data.Maybe+import Data.Ratio+import Data.Typeable+import Domain.Math.Data.Relation (relationSymbols) import Domain.Math.Expr.Symbols-+import Test.QuickCheck import qualified Common.Rewriting.Term as Term  -----------------------------------------------------------------------@@ -88,23 +88,17 @@    asinh   = unary asinhSymbol    atanh   = unary atanhSymbol    acosh   = unary acoshSymbol -   -instance Symbolic Expr where-   variable = Var-   -   getVariable (Var s) = return s-   getVariable _       = mzero-   ++instance WithFunctions Expr where    function s [a, b]        | s == plusSymbol   = a :+: b       | s == timesSymbol  = a :*: b       | s == minusSymbol  = a :-: b       | s == divideSymbol = a :/: b-      | s == rootSymbol && b == Nat 2 = Sqrt a+      | isRootSymbol s && b == Nat 2 = Sqrt a    function s [a]       | s == negateSymbol = Negate a-   function s as = -      Sym s as+   function s as = Sym s as        getFunction expr =       case expr of@@ -115,8 +109,13 @@          a :/: b  -> return (divideSymbol, [a, b])          Sqrt a   -> return (rootSymbol,   [a, Nat 2])          Sym s as -> return (s, as)-         _ -> mzero+         _ -> fail "Expr.getFunction" +instance WithVars Expr where+   variable = Var+   getVariable (Var s) = return s+   getVariable _       = fail "Expr.getVariable"+ fromDouble :: Double -> Expr fromDouble d    | d < 0     = negate (Number (abs d))@@ -144,16 +143,16 @@ instance CoArbitrary Expr where          coarbitrary expr =       case expr of -         a :+: b  -> variant 0 . coarbitrary a . coarbitrary b-         a :*: b  -> variant 1 . coarbitrary a . coarbitrary b-         a :-: b  -> variant 2 . coarbitrary a . coarbitrary b-         Negate a -> variant 3 . coarbitrary a-         Nat n    -> variant 4 . coarbitrary n-         a :/: b  -> variant 5 . coarbitrary a . coarbitrary b-         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+         a :+: b  -> variant (0 :: Int) . coarbitrary a . coarbitrary b+         a :*: b  -> variant (1 :: Int) . coarbitrary a . coarbitrary b+         a :-: b  -> variant (2 :: Int) . coarbitrary a . coarbitrary b+         Negate a -> variant (3 :: Int) . coarbitrary a+         Nat n    -> variant (4 :: Int) . coarbitrary n+         a :/: b  -> variant (5 :: Int) . coarbitrary a . coarbitrary b+         Number d -> variant (6 :: Int) . coarbitrary d+         Sqrt a   -> variant (7 :: Int) . coarbitrary a+         Var s    -> variant (8 :: Int) . coarbitrary s+         Sym f xs -> variant (9 :: Int) . coarbitrary (show f) . coarbitrary xs    symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr symbolGenerator extras syms = f @@ -171,9 +170,9 @@ natGenerator = liftM (Nat . abs) arbitrary  varGenerator :: [String] -> Gen Expr-varGenerator vars-   | null vars = error "varGenerator: empty list"-   | otherwise = oneof [ return (Var x) | x <- vars ]+varGenerator xs+   | null xs   = error "varGenerator: empty list"+   | otherwise = oneof [ return (Var x) | x <- xs ]  ----------------------------------------------------------------------- -- Pretty printer @@ -184,6 +183,7 @@ showExpr :: OperatorTable -> Expr -> String showExpr table = rec 0   where+   rec :: Int -> Expr -> String    rec _ (Nat n)    = if n>=0 then show n else "(ERROR)" ++ show n    rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d    rec _ (Var s) @@ -191,28 +191,30 @@       | otherwise        = "\"" ++ s ++ "\""    rec i expr =        case getFunction expr of+         Just (s1, [Sym s2 [Var x, a]]) | s1 == diffSymbol && s2 == lambdaSymbol ->+            parIf (i>10000) $ "D(" ++ x ++ ") " ++ rec 10001 a          -- To do: remove special case for sqrt-         Just (s, [a, b]) | s == rootSymbol && b == Nat 2 -> +         Just (s, [a, b]) | isRootSymbol s && b == Nat 2 ->              parIf (i>10000) $ unwords ["sqrt", rec 10001 a]          Just (s, xs) | s == listSymbol ->              "[" ++ commaList (map (rec 0) xs) ++ "]"          Just (s, as) ->              case (lookup s symbolTable, as) of                 (Just (InfixLeft, n, op), [x, y]) -> -                  parIf (i>n) $ concat [rec n x, op, rec (n+1) y]+                  parIf (i>n) $ 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]+                  parIf (i>n) $ rec (n+1) x ++ op ++ rec n y                (Just (InfixNon, n, op), [x, y]) -> -                  parIf (i>n) $ concat [rec (n+1) x, op, rec (n+1) y]+                  parIf (i>n) $ rec (n+1) x ++ op ++ rec (n+1) y                (Just (PrefixNon, n, op), [x]) ->-                  parIf (i>=n) $ concat [op, rec (n+1) x]+                  parIf (i>=n) $ op ++ rec (n+1) x                _ ->                    parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as)          Nothing ->              error "showExpr"     showSymbol s-      | s == rootSymbol = "root"+      | isRootSymbol s = "root"       | otherwise = show s     symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ]@@ -220,16 +222,22 @@    parIf b = if b then par else id    par s   = "(" ++ s ++ ")" -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)) -> -              s1 == s2 && length as == length bs-         _ -> False +type OperatorTable = [(Associativity, [(Symbol, String)])] +data Associativity = InfixLeft | InfixRight | PrefixNon+                   | InfixNon+   deriving (Show, Eq)++operatorTable :: OperatorTable+operatorTable =+     (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) :+   [ (InfixLeft,  [(plusSymbol, "+"), (minusSymbol, "-")])    -- 6+   , (PrefixNon,  [(negateSymbol, "-")])                      -- 6++   , (InfixLeft,  [(timesSymbol, "*"), (divideSymbol, "/")])  -- 7+   , (InfixRight, [(powerSymbol, "^")])                       -- 8+   ]++ instance Rewrite Expr  instance Different Expr where@@ -241,57 +249,30 @@    toTerm (Var v)    = Term.Var v    toTerm expr =        case getFunction expr of-         Just (s, xs) -> Term.makeConTerm s (map toTerm xs)+         Just (s, xs) -> function s (map toTerm xs)          Nothing      -> error "IsTerm Expr"     fromTerm (Term.Num n)   = return (fromInteger n)    fromTerm (Term.Float d) = return (Number d)    fromTerm (Term.Var v)   = return (Var v)    fromTerm t =-      case Term.getSpine t of-         (Term.Con s, xs) -> do+      case getFunction t of+         Just (s, xs) -> do             ys <- mapM fromTerm xs             return (function s ys)          _ -> fail "fromTerm"  instance IsTerm a => IsTerm [a] where    toTerm = function listSymbol . map toTerm-   fromTerm a = isSymbol listSymbol a >>= mapM fromTerm+   fromTerm a = do+      xs <- isFunction listSymbol a+      mapM fromTerm xs  toExpr :: IsTerm a => a -> Expr-toExpr a =-   case fromTerm (toTerm a) of-      Just expr -> expr-      Nothing   -> error "Invalid term"+toExpr = fromJust . fromTerm . toTerm  fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a fromExpr = fromTerm . toTerm  exprView :: IsTerm a => View Expr a exprView = makeView fromExpr toExpr---------------------------------------------------------------------------- AC Theory for expression-{--exprACs :: Operators Expr-exprACs = [plusOperator, timesOperator]--plusOperator, timesOperator :: Operator Expr-plusOperator  = acOperator (+) isPlus-timesOperator = acOperator (*) isTimes--collectPlus, collectTimes :: Expr -> [Expr]-collectPlus  = collectWithOperator plusOperator-collectTimes = collectWithOperator timesOperator--size :: Expr -> Int-size e = 1 + compos 0 (+) size e--}-collectVars :: Expr -> [String]-collectVars e = [ s | Var s <- universe e ]--hasVars :: Expr -> Bool-hasVars = not . noVars--noVars :: Expr -> Bool-noVars = null . collectVars
src/Domain/Math/Expr/Parser.hs view
@@ -17,20 +17,20 @@  import Prelude hiding ((^)) import Text.Parsing-import Control.Monad+import Control.Monad.Error+import Common.Rewriting import Common.Transformation import qualified Domain.Logic.Formula as Logic import Domain.Logic.Formula (Logic) import Domain.Math.Data.Relation import Domain.Math.Expr.Data-import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Data.OrList import Test.QuickCheck (arbitrary)  scannerExpr :: Scanner scannerExpr = defaultScanner -   { keywords             = ["sqrt", "root", "and", "or", "true", "false"]+   { keywords             = ["sqrt", "root", "log", "and", "or", "true", "false", "D"]    , keywordOperators     = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"]    , operatorCharacters   = "+-*/^.=<>~"    , qualifiedIdentifiers = True@@ -67,9 +67,15 @@     -- To fix: sqrt expects exactly one argument     <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt"      <|> function rootSymbol <$ pKey "root"+    <|> function logSymbol  <$ pKey "log"+    <|> makeDiff <$ pKey "D"+ where+   makeDiff [x,a] = unary diffSymbol (binary lambdaSymbol x a)+   makeDiff _     = symbol bottomSymbol  qualifiedSymb :: TokenParser ([Expr] -> Expr)-qualifiedSymb = (function . uncurry makeSymbol) <$> (pQVarid <|> pQConid)+qualifiedSymb = f <$> (pQVarid <|> pQConid)+ where f (a, b) = function $ newSymbol (a, b)  pEquations :: TokenParser a -> TokenParser (Equations a) pEquations = pLines True . pEquation@@ -101,7 +107,6 @@    pTerm =  return <$> p          <|> true   <$  pKey "true"          <|> false  <$  pKey "false"-   pSepList p q = (:) <$> p <*> pList (q *> p)  pLogic :: TokenParser a -> TokenParser (Logic a) pLogic p = levelOr
− src/Domain/Math/Expr/Symbolic.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Domain.Math.Expr.Symbolic -   ( module Domain.Math.Expr.Symbolic, Symbol-   ) where--import Control.Monad-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--class Symbolic a where-   -- constructing-   variable   :: String -> a-   symbol     :: Symbol -> a-   function   :: Symbol -> [a] -> a-   -- matching-   getVariable :: MonadPlus m => a -> m String-   getSymbol   :: MonadPlus m => a -> m Symbol-   getFunction :: MonadPlus m => a -> m (Symbol, [a])-   isSymbol    :: MonadPlus m => Symbol -> a -> m [a]-   -- default definition-   symbol s = function s []-   getSymbol a = do-      (t, as) <- getFunction a -      guard (null as)-      return t-   isSymbol s a = do-      (t, as) <- getFunction a-      guard (s==t)-      return as-   -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 :: (IsSymbol s, Symbolic a) => s -> a -> a -> a-binary f a b = function (toSymbol f) [a, b]--isConst :: (IsSymbol s, Symbolic a) => s -> a -> Bool-isConst s = maybe False null . isSymbol (toSymbol s) --isVariable :: Symbolic a => a -> Bool-isVariable = isJust . getVariable--isUnary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m a-isUnary s a = -   case isSymbol (toSymbol s) a of-      Just [x] -> return x-      _ -> mzero--isBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a)-isBinary s a = -   case isSymbol (toSymbol s) a of-      Just [x, y] -> return (x, y)-      _ -> mzero---- left-associative by default-isAssoBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a)-isAssoBinary s a =-   case isSymbol (toSymbol s) a of-      Just [x, y] -> return (x, y)-      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
@@ -8,103 +8,131 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) ----- Exports relevant OpenMath symbols, converted to the --- Symbol data type from @Common.Rewriting@.+-- Exports relevant OpenMath symbols -- ------------------------------------------------------------------------------module Domain.Math.Expr.Symbols where+module Domain.Math.Expr.Symbols+   ( openMathSymbol+     -- OpenMath dictionary symbols+   , plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol+   , powerSymbol, negateSymbol, sinSymbol, cosSymbol, lnSymbol+   , diffSymbol, piSymbol, lambdaSymbol, listSymbol+   , absSymbol, signumSymbol, logSymbol, expSymbol, tanSymbol, asinSymbol+   , atanSymbol, acosSymbol, sinhSymbol, tanhSymbol, coshSymbol, asinhSymbol+   , atanhSymbol, acoshSymbol, bottomSymbol, fcompSymbol+     -- Matching+   , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot+   , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol+   , (^), root+   ) where +import Common.Id+import Common.Rewriting import Control.Monad-import Domain.Math.Expr.Symbolic-import Domain.Math.Data.Relation (relationSymbols)+import Prelude hiding ((^))+import qualified Text.OpenMath.Dictionary.Arith1    as OM+import qualified Text.OpenMath.Dictionary.Calculus1 as OM+import qualified Text.OpenMath.Dictionary.Fns1      as OM+import qualified Text.OpenMath.Dictionary.List1     as OM+import qualified Text.OpenMath.Dictionary.Nums1     as OM+import qualified Text.OpenMath.Dictionary.Transc1   as OM+import qualified Text.OpenMath.Symbol               as OM --- 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+-- | Conversion function+openMathSymbol :: OM.Symbol -> Symbol+openMathSymbol s = newSymbol (OM.dictionary s # OM.symbolName s)  ---------------------------------------------------------------- Converted OpenMath symbols+-- Arith1 dictionary -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+plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol,+   powerSymbol, negateSymbol, absSymbol :: Symbol+   +plusSymbol   = openMathSymbol OM.plusSymbol+timesSymbol  = openMathSymbol OM.timesSymbol+minusSymbol  = openMathSymbol OM.minusSymbol+divideSymbol = openMathSymbol OM.divideSymbol+rootSymbol   = openMathSymbol OM.rootSymbol+powerSymbol  = openMathSymbol OM.powerSymbol+negateSymbol = openMathSymbol OM.unaryMinusSymbol+absSymbol    = openMathSymbol OM.absSymbol -sinSymbol, cosSymbol, lnSymbol :: Symbol-sinSymbol        = toSymbol Transc1.sinSymbol-cosSymbol        = toSymbol Transc1.cosSymbol-lnSymbol         = toSymbol Transc1.lnSymbol+-------------------------------------------------------------+-- Transc1 dictionary -diffSymbol, piSymbol, lambdaSymbol, listSymbol :: Symbol-diffSymbol       = toSymbol Calculus1.diffSymbol-piSymbol         = toSymbol Nums1.piSymbol-lambdaSymbol     = toSymbol Fns1.lambdaSymbol-listSymbol       = toSymbol List1.listSymbol+logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol,+   sinhSymbol, tanhSymbol, coshSymbol :: Symbol ----------------------------------------------------------------- Operator fixities+logSymbol  = openMathSymbol OM.logSymbol+sinSymbol  = openMathSymbol OM.sinSymbol+cosSymbol  = openMathSymbol OM.cosSymbol+lnSymbol   = openMathSymbol OM.lnSymbol+expSymbol  = openMathSymbol OM.expSymbol +tanSymbol  = openMathSymbol OM.tanSymbol+sinhSymbol = openMathSymbol OM.sinhSymbol+tanhSymbol = openMathSymbol OM.tanhSymbol+coshSymbol = openMathSymbol OM.coshSymbol -type OperatorTable = [(Associativity, [(Symbol, String)])]+-------------------------------------------------------------+-- Other dictionaries -data Associativity = InfixLeft | InfixRight | PrefixNon-                   | InfixNon-   deriving (Show, Eq)+diffSymbol, lambdaSymbol, listSymbol, piSymbol :: Symbol -operatorTable :: OperatorTable-operatorTable =-     (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) :-   [ (InfixLeft,  [(plusSymbol, "+"), (minusSymbol, "-")])    -- 6-   , (PrefixNon,  [(negateSymbol, "-")])                      -- 6+-   , (InfixLeft,  [(timesSymbol, "*"), (divideSymbol, "/")])  -- 7-   , (InfixRight, [(powerSymbol, "^")])                       -- 8-   ]+diffSymbol   = openMathSymbol OM.diffSymbol+lambdaSymbol = openMathSymbol OM.lambdaSymbol+listSymbol   = openMathSymbol OM.listSymbol+piSymbol     = openMathSymbol OM.piSymbol  ------------------------------------------------------------- -- Extra math symbols -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"+signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol,+   acoshSymbol, bottomSymbol, fcompSymbol :: Symbol +signumSymbol = newSymbol "signum"    +asinSymbol   = newSymbol "asin"   +atanSymbol   = newSymbol "atan"   +acosSymbol   = newSymbol "acos"     +asinhSymbol  = newSymbol "asinh"  +atanhSymbol  = newSymbol "atanh" +acoshSymbol  = newSymbol "acosh"  +bottomSymbol = newSymbol "error"+fcompSymbol  = newSymbol "compose"+ ------------------------------------------------------------- -- Some match functions -isPlus, isTimes, isMinus, isDivide :: -   (Symbolic a, MonadPlus m) => a -> m (a, a)-isNegate :: (Symbolic a, MonadPlus m) => a -> m a+isPlus, isTimes, isMinus, isDivide, isPower, isRoot :: +   (WithFunctions a, MonadPlus m) => a -> m (a, a)+isNegate :: (WithFunctions a, MonadPlus m) => a -> m a     isPlus   = isAssoBinary plusSymbol isTimes  = isAssoBinary timesSymbol   isMinus  = isBinary     minusSymbol   isDivide = isBinary     divideSymbol  isNegate = isUnary      negateSymbol +isPower  = isBinary     powerSymbol+isRoot   = isBinary     rootSymbol +isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol :: Symbol -> Bool++isPowerSymbol  = (== powerSymbol)+isRootSymbol   = (== rootSymbol)+isLogSymbol    = (== logSymbol)+isDivideSymbol = (== divideSymbol)+ infixr 8 ^ -(^) :: Symbolic a => a -> a -> a+(^) :: WithFunctions a => a -> a -> a (^) = binary powerSymbol -root :: Symbolic a => a -> a -> a+root :: WithFunctions a => a -> a -> a root = binary rootSymbol++-- left-associative+isAssoBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a)+isAssoBinary s a =+   case isFunction s a of+      Just [x, y] -> return (x, y)+      Just (x:xs) | length xs > 1 -> return (x, function s xs)+      _ -> fail "isAssoBinary"
src/Domain/Math/Expr/Views.hs view
@@ -12,25 +12,34 @@ module Domain.Math.Expr.Views where  import Prelude hiding (recip, (^))+import Common.Rewriting import Common.View import Domain.Math.Expr.Data import Domain.Math.Expr.Symbols-import Data.List (nub)+import qualified Data.Set as S  ------------------------------------------------------------ -- Smart constructors +infixr 8 .^.+infixl 7 .*., ./.+infixl 6 .-., .+.+ (.+.) :: Expr -> Expr -> Expr-Nat 0 .+. b        = b-a     .+. Nat 0    = a-a     .+. Negate b = a .-. b-a     .+. b        = a :+: b+Nat 0 .+. b         = b+a     .+. Nat 0     = a+a     .+. Negate b  = a .-. b+a     .+. (b :+: c) = (a .+. b) .+. c+a     .+. (b :-: c) = (a .+. b) .-. c+a     .+. b         = a :+: b  (.-.) :: Expr -> Expr -> Expr-Nat 0 .-. b        = neg b-a     .-. Nat 0    = a-a     .-. Negate b = a .+. b-a     .-. b        = a :-: b+Nat 0 .-. b         = neg b+a     .-. Nat 0     = a+a     .-. Negate b  = a .+. b+a     .-. (b :+: c) = (a .-. b) .-. c+a     .-. (b :-: c) = (a .-. b) .+. c+a     .-. b         = a :-: b  neg :: Expr -> Expr neg (Nat 0)    = 0@@ -40,14 +49,15 @@ neg a          = Negate a  (.*.) :: Expr -> Expr -> Expr-Nat 0    .*. _        = Nat 0-_        .*. Nat 0    = Nat 0-Nat 1    .*. b        = b-a        .*. Nat 1    = a-Negate a .*. b        = neg (a .*. b)-a        .*. Negate b = neg (a .*. b)+Nat 0    .*. _             = Nat 0+_        .*. Nat 0         = Nat 0+Nat 1    .*. b             = b+a        .*. Nat 1         = a+Negate a .*. b             = neg (a .*. b)+a        .*. Negate b      = neg (a .*. b) a        .*. (Nat 1 :/: b) = a ./. b-a        .*. b        = a :*: b+a        .*. (b :*: c)     = (a .*. b) .*. c+a        .*. b             = a :*: b  (./.) :: Expr -> Expr -> Expr a ./. Nat 1           = a@@ -129,32 +139,32 @@ simpleProductView :: View Expr (Bool, [Expr]) simpleProductView = makeView (Just . second ($ []) . f) g  where-   f (a :*: b)  = f a &&& f b+   f (a :*: b)  = f a .&&. f b    f (Negate a) = first not (f a)    f e          = (False, (e:))    -   (n1, g1) &&& (n2, g2) = (n1 /= n2, g1 . g2)+   (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2)        g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs)  productView :: View Expr (Bool, [Expr]) productView = makeView (Just . second ($ []) . f False) g  where-   f r (a :*: b)  = f r a &&& f r b+   f r (a :*: b)  = f r a .&&. f r b    f r (a :/: b)  = case a of -- two special cases (for efficiency)                        Nat 1          -> f (not r) b                        Negate (Nat 1) -> first not (f (not r) b)-                       _              -> f r a &&& f (not r) b+                       _              -> f r a .&&. f (not r) b    f r (Negate a) = first not (f r a)    f r e          = (False, if r then (recip e:) else (e:))    -   (n1, g1) &&& (n2, g2) = (n1 /= n2, g1 . g2)+   (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2)        g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs)     -- helper to determine the name of the variable (move to a different module?) selectVar :: Expr -> Maybe String-selectVar = f . nub . collectVars+selectVar = f  . S.toList . varSet  where    f []  = Just "x" -- exceptional case (e.g., for constants)    f [a] = Just a
src/Domain/Math/Numeric/Exercises.hs view
@@ -27,42 +27,43 @@ ------------------------------------------------------------ -- Exercises -numericExercise :: LabeledStrategy Expr -> Exercise Expr+numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr numericExercise s = makeExercise     { status        = Alpha    , parser        = parseExpr    , equivalence   = viewEquivalent rationalView-   , strategy      = mapRules liftToContext s+   , strategy      = s+   , navigation   = termNavigator    }  naturalExercise :: Exercise Expr naturalExercise = (numericExercise naturalStrategy)-   { description  = "simplify expression (natural numbers)"-   , exerciseCode = makeCode "math" "natural"+   { exerciseId   = describe "simplify expression (natural numbers)" $ +                       newId "numbers.natural"    , isReady      = (`belongsTo` integerNormalForm)    , examples     = concat calculateResults    }  integerExercise :: Exercise Expr integerExercise = (numericExercise integerStrategy)-   { description  = "simplify expression (integers)"-   , exerciseCode = makeCode "math" "integer"+   { exerciseId   = describe "simplify expression (integers)" $ +                       newId "numbers.integers"    , isReady      = (`belongsTo` integerNormalForm)    , examples     = concat calculateResults    }     rationalExercise :: Exercise Expr rationalExercise = (numericExercise rationalStrategy)-   { description    = "simplify expression (rational numbers)"-   , exerciseCode   = makeCode "math" "rational"+   { exerciseId     = describe "simplify expression (rational numbers)" $ +                         newId "numbers.rational"    , isReady        = (`belongsTo` rationalNormalForm)    , randomExercise = simpleGenerator (rationalGenerator 5)    }  fractionExercise :: Exercise Expr fractionExercise = (numericExercise fractionStrategy)-   { description    = "simplify expression (fractions)"-   , exerciseCode   = makeCode "math" "fraction"+   { exerciseId     = describe "simplify expression (fractions)" $ +                         newId "arithmetic.fractions"    , isReady        = (`belongsTo` rationalNormalForm)    , randomExercise = simpleGenerator (rationalGenerator 5)    }
src/Domain/Math/Numeric/Laws.hs view
@@ -16,91 +16,88 @@    , fracLaws, testFracLaws, testFracLawsWith    ) where +import Common.TestSuite import Test.QuickCheck -testNumLaws :: Num a => String -> Gen a -> IO ()+testNumLaws :: Num a => String -> Gen a -> TestSuite testNumLaws = testNumLawsWith (==) -testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> IO ()-testNumLawsWith eq s g = do-   putStrLn $ "Testing Num instance for " ++ s+testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> TestSuite+testNumLawsWith eq s g = suite ("Num instance for " ++ s) $    mapM_ ($ g) (numLaws eq) -testFracLaws :: Fractional a => String -> Gen a -> IO ()+testFracLaws :: Fractional a => String -> Gen a -> TestSuite testFracLaws = testFracLawsWith (==) -testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> IO ()-testFracLawsWith eq s g = do-   putStrLn $ "Testing Fractional instance for " ++ s+testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> TestSuite+testFracLawsWith eq s g = suite ("Fractional instance for " ++ s) $     mapM_ ($ g) (fracLaws eq) -numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> IO ()]+numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> TestSuite] numLaws eq =-   [ law1 "plus zero left"     $ \a      ->      0+a == a-   , law1 "plus zero right"    $ \a      ->      a+0 == a-   , law2 "plus comm"          $ \a b    ->      a+b == b+a-   , law3 "plus trans"         $ \a b c  ->  a+(b+c) == (a+b)+c-   , law1 "negate zero"        $ \a      ->       -0 == 0        `asTypeOf` a-   , law1 "negate double"      $ \a      ->    -(-a) == a-   , law1 "minus zero left"    $ \a      ->      0-a == -a-   , law1 "minus zero right"   $ \a      ->      a-0 == a-   , law2 "negate plus"        $ \a b    ->   -(a+b) == -a-b-   , law2 "negate minus"       $ \a b    ->   -(a-b) == -a+b-   , law2 "plus negate"        $ \a b    ->   a+(-b) == a-b-   , law1 "times zero left"    $ \a      ->      0*a == 0-   , law1 "times zero right"   $ \a      ->      a*0 == 0-   , law1 "times one left"     $ \a      ->      1*a == a-   , law1 "times one right"    $ \a      ->      a*1 == a-   , law2 "times comm"         $ \a b    ->      a*b == b*a-   , law3 "times trans"        $ \a b c  ->  a*(b*c) == (a*b)*c-   , law2 "times negate left"  $ \a b    ->   (-a)*b == -(a*b)-   , law2 "times negate right" $ \a b    ->   a*(-b) == -(a*b)-   , law3 "times plus left"    $ \a b c  ->  (a+b)*c == a*c + b*c-   , law3 "times plus right"   $ \a b c  ->  a*(b+c) == a*b + a*c-   , law3 "times minus left"   $ \a b c  ->  (a-b)*c == a*c - b*c-   , law3 "times minus right"  $ \a b c  ->  a*(b-c) == a*b - a*c+   [ law1 "plus zero left"     $ \a      ->      0+a === a+   , law1 "plus zero right"    $ \a      ->      a+0 === a+   , law2 "plus comm"          $ \a b    ->      a+b === b+a+   , law3 "plus trans"         $ \a b c  ->  a+(b+c) === (a+b)+c+   , law1 "negate zero"        $ \a      ->       -0 === 0        `asTypeOf` a+   , law1 "negate double"      $ \a      ->    -(-a) === a+   , law1 "minus zero left"    $ \a      ->      0-a === -a+   , law1 "minus zero right"   $ \a      ->      a-0 === a+   , law2 "negate plus"        $ \a b    ->   -(a+b) === -a-b+   , law2 "negate minus"       $ \a b    ->   -(a-b) === -a+b+   , law2 "plus negate"        $ \a b    ->   a+(-b) === a-b+   , law1 "times zero left"    $ \a      ->      0*a === 0+   , law1 "times zero right"   $ \a      ->      a*0 === 0+   , law1 "times one left"     $ \a      ->      1*a === a+   , law1 "times one right"    $ \a      ->      a*1 === a+   , law2 "times comm"         $ \a b    ->      a*b === b*a+   , law3 "times trans"        $ \a b c  ->  a*(b*c) === (a*b)*c+   , law2 "times negate left"  $ \a b    ->   (-a)*b === -(a*b)+   , law2 "times negate right" $ \a b    ->   a*(-b) === -(a*b)+   , law3 "times plus left"    $ \a b c  ->  (a+b)*c === a*c + b*c+   , law3 "times plus right"   $ \a b c  ->  a*(b+c) === a*b + a*c+   , law3 "times minus left"   $ \a b c  ->  (a-b)*c === a*c - b*c+   , law3 "times minus right"  $ \a b c  ->  a*(b-c) === a*b - a*c    ]  where-   infix 4 ==-   a == b = property (a `eq` b)+   infix 4 ===+   a === b = property (a `eq` b) -fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> IO ()]+fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> TestSuite] fracLaws eq =-   [ law3 "division numerator"   $ \a b c  ->      (a/b)/c == a/(b*c)          <| b/=0 && c/=0-   , law3 "division denominator" $ \a b c  ->      a/(b/c) == a*(c/b)          <| b/=0 && c/=0-   , law1 "zero numerator"       $ \a      ->          0/a == 0 <| a/=0-   , law1 "one numerator"        $ \a      ->          1/a == recip a          <| a/=0-   , law1 "one denominator"      $ \a      ->          a/1 == a-   , law1 "division is one"      $ \a      ->          a/a == 1                <| a/=0-   , law1 "recip double"         $ \a      ->            a == recip (recip a)  <| a/=0-   , law3 "times division left"  $ \a b c  ->      (a/b)*c == (a*c)/b          <| b/=0-   , law3 "times division right" $ \a b c  ->      a*(b/c) == (a*b)/c          <| c/=0-   , law3 "plus division left"   $ \a b c  ->      (a/b)+c == (a+c*b)/b        <| b/=0-   , law3 "plus division right"  $ \a b c  ->      a+(b/c) == (a*c+b)/c        <| c/=0-   , law3 "minus division left"  $ \a b c  ->      (a/b)-c == (a-c*b)/b        <| b/=0-   , law3 "minus division right" $ \a b c  ->      a-(b/c) == (a*c-b)/c        <| c/=0-   , law2 "negate numerator"     $ \a b    ->      a/(-b)  == -(a/b)           <| b/=0-   , law2 "negate denominator"   $ \a b    ->       (-a)/b == -(a/b)           <| b/=0-   , law2 "recip times"          $ \a b    ->  recip (a*b) == recip a*recip b  <| a/=0 && b/=0-   , law2 "recip division"       $ \a b    ->  recip (a/b) == b/a              <| a/=0 && b/=0+   [ law3 "division numerator"   $ \a b c  ->      (a/b)/c === a/(b*c)          <| b/=0 && c/=0+   , law3 "division denominator" $ \a b c  ->      a/(b/c) === a*(c/b)          <| b/=0 && c/=0+   , law1 "zero numerator"       $ \a      ->          0/a === 0 <| a/=0+   , law1 "one numerator"        $ \a      ->          1/a === recip a          <| a/=0+   , law1 "one denominator"      $ \a      ->          a/1 === a+   , law1 "division is one"      $ \a      ->          a/a === 1                <| a/=0+   , law1 "recip double"         $ \a      ->            a === recip (recip a)  <| a/=0+   , law3 "times division left"  $ \a b c  ->      (a/b)*c === (a*c)/b          <| b/=0+   , law3 "times division right" $ \a b c  ->      a*(b/c) === (a*b)/c          <| c/=0+   , law3 "plus division left"   $ \a b c  ->      (a/b)+c === (a+c*b)/b        <| b/=0+   , law3 "plus division right"  $ \a b c  ->      a+(b/c) === (a*c+b)/c        <| c/=0+   , law3 "minus division left"  $ \a b c  ->      (a/b)-c === (a-c*b)/b        <| b/=0+   , law3 "minus division right" $ \a b c  ->      a-(b/c) === (a*c-b)/c        <| c/=0+   , law2 "negate numerator"     $ \a b    ->      a/(-b)  === -(a/b)           <| b/=0+   , law2 "negate denominator"   $ \a b    ->       (-a)/b === -(a/b)           <| b/=0+   , law2 "recip times"          $ \a b    ->  recip (a*b) === recip a*recip b  <| a/=0 && b/=0+   , law2 "recip division"       $ \a b    ->  recip (a/b) === b/a              <| a/=0 && b/=0    ]  where-   infix 4 ==-   a == b = property (a `eq` b)+   infix 4 ===+   a === b = property (a `eq` b)    infix 1 <|    p <| b = b ==> p  -- local helper-functions-report :: String -> Property -> IO ()-report s p = putStr (take 30 ("- " ++ s ++ repeat ' ')) >> quickCheck p--law1 :: Show a => String -> (a -> Property) -> Gen a -> IO ()-law1 s p g = report s (make g id p)+law1 :: Show a => String -> (a -> Property) -> Gen a -> TestSuite+law1 s p g = addProperty s (make g id p) -law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> IO ()-law2 s p g = report s (make g (make g id) p)+law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> TestSuite+law2 s p g = addProperty s (make g (make g id) p) -law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> IO ()-law3 s p g = report s (make g (make g (make g id)) p)+law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> TestSuite+law3 s p g = addProperty s (make g (make g (make g id)) p) +make :: Show a => Gen a -> (b -> Property) -> (a -> b) -> Property make g c p = forAll g (c . p)
src/Domain/Math/Numeric/Rules.hs view
@@ -20,9 +20,12 @@ ------------------------------------------------------------ -- Rules +alg :: String+alg = "algebra.manipulation"+ calcRuleName :: String -> String -> String calcRuleName opName viewName =-   "calculate " ++ opName ++ " [" ++ viewName ++ "]"+   "arithmetic.operation." ++ viewName ++ "." ++ opName        calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e calcBinRule opName op m viewName v = @@ -52,87 +55,87 @@       return (build v d)  negateZero :: Rule Expr -negateZero = makeSimpleRule "negate zero" f+negateZero = makeSimpleRule (alg, "negate-zero") f  where    f (Negate (Nat n)) | n == 0 = Just 0    f _                         = Nothing  doubleNegate :: Rule Expr -doubleNegate = makeSimpleRule "double negate" f+doubleNegate = makeSimpleRule (alg, "double-negate") f  where    f (Negate (Negate a)) = Just a    f _                   = Nothing  plusNegateLeft :: Rule Expr-plusNegateLeft = makeSimpleRule "plus negate left" f+plusNegateLeft = makeSimpleRule (alg, "plus-negate-left") f  where    f (Negate a :+: b) = Just (b :-: a)    f _                = Nothing  plusNegateRight :: Rule Expr-plusNegateRight = makeSimpleRule "plus negate right" f+plusNegateRight = makeSimpleRule (alg, "plus-negate-right") f  where    f (a :+: Negate b) = Just (a :-: b)    f _                = Nothing  minusNegateLeft :: Rule Expr-minusNegateLeft = makeSimpleRule "minus negate left" f+minusNegateLeft = makeSimpleRule (alg, "minus-negate-left") f  where    f (Negate a :-: b) = Just (Negate (a :+: b))    f _                = Nothing  minusNegateRight :: Rule Expr-minusNegateRight = makeSimpleRule "minus negate right" f+minusNegateRight = makeSimpleRule (alg, "minus-negate-right") f  where    f (a :-: Negate b) = Just (a :+: b)    f _                = Nothing  timesNegateLeft :: Rule Expr-timesNegateLeft = makeSimpleRule "times negate left" f+timesNegateLeft = makeSimpleRule (alg, "times-negate-left") f  where    f (Negate a :*: b) = Just (Negate (a :*: b))    f _                = Nothing  timesNegateRight :: Rule Expr-timesNegateRight = makeSimpleRule "times negate right" f+timesNegateRight = makeSimpleRule (alg, "times-negate-right") f  where    f (a :*: Negate b) = Just (Negate (a :*: b))    f _                = Nothing  divisionNegateLeft :: Rule Expr-divisionNegateLeft = makeSimpleRule "division negate left" f+divisionNegateLeft = makeSimpleRule (alg, "division-negate-left") f  where    f (Negate a :/: b) = Just (Negate (a :/: b))    f _                = Nothing  divisionNegateRight :: Rule Expr-divisionNegateRight = makeSimpleRule "division negate right" f+divisionNegateRight = makeSimpleRule (alg, "division-negate-right") f  where    f (a :/: Negate b) = Just (Negate (a :/: b))    f _                = Nothing  divisionNumerator :: Rule Expr-divisionNumerator = makeSimpleRule "division numerator" f+divisionNumerator = makeSimpleRule (alg, "division-numerator") f  where    f ((a :/: b) :/: c)        = Just (a :/: (b :*: c))    f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c)))    f _                        = Nothing  divisionDenominator :: Rule Expr-divisionDenominator = makeSimpleRule "division denominator" f+divisionDenominator = makeSimpleRule (alg, "division-denominator") f  where    f (a :/: (b :/: c))        = Just ((a :*: c) :/: b)    f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b))    f _                        = Nothing  simplerFraction :: Rule Expr-simplerFraction = makeSimpleRule "simpler fraction" $ \expr -> do+simplerFraction = makeSimpleRule (alg, "simpler-fraction") $ \expr -> do    new <- canonical rationalRelaxedForm expr    guard (expr /= new)    return new  fractionPlus :: Rule Expr -- also minus-fractionPlus = makeSimpleRule "fraction plus" $ \expr -> do+fractionPlus = makeSimpleRule (alg, "fraction-plus") $ \expr -> do    (e1, e2) <- match plusView expr    (a, b)   <- match fractionForm e1    (c, d)   <- match fractionForm e2@@ -140,11 +143,11 @@    return (build fractionForm (a+c, b))  fractionPlusScale :: Rule Expr -- also minus-fractionPlusScale = makeSimpleRuleList "fraction plus scale" $ \expr -> do+fractionPlusScale = makeSimpleRuleList (alg, "fraction-plus-scale") $ \expr -> do    (e1, e2) <- matchM plusView expr    (a, b)   <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1))    (c, d)   <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2))-   guard (b /= 0 && d /= 0)+   guard (b /= 0 && d /= 0 && b /= d)    let bd  = lcm b d        e1n = build fractionForm (a * (bd `div` b), bd)        e2n = build fractionForm (c * (bd `div` d), bd)@@ -152,7 +155,7 @@      build plusView (e1, e2n) | d /= bd ]  fractionTimes :: Rule Expr-fractionTimes = makeSimpleRule "fraction times" f +fractionTimes = makeSimpleRule (alg, "fraction-times") f   where    f (e1 :*: e2) = do       (a, b)   <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1))
src/Domain/Math/Numeric/Strategies.hs view
@@ -12,109 +12,69 @@ module Domain.Math.Numeric.Strategies    ( naturalStrategy, integerStrategy    , rationalStrategy, fractionStrategy-   , testAll    ) where -import Common.Apply+import Common.Context import Common.Strategy-import Common.Transformation-import Common.Uniplate import Common.View import Domain.Math.Expr import Domain.Math.Numeric.Rules import Domain.Math.Numeric.Views-import Domain.Math.Numeric.Generators import Prelude hiding (repeat)-import Test.QuickCheck hiding (label)  ------------------------------------------------------------ -- Strategies -naturalStrategy :: LabeledStrategy Expr-naturalStrategy = label "simplify" $ repeat $ alternatives $ map swRule-   [ calcPlusWith     "nat" natView-   , calcMinusWith    "nat" natView-   , calcTimesWith    "nat" natView-   , calcDivisionWith "nat" natView-   , doubleNegate-   , negateZero-   , plusNegateLeft-   , plusNegateRight-   , minusNegateLeft-   , minusNegateRight-   , timesNegateLeft-   , timesNegateRight   -   , divisionNegateLeft-   , divisionNegateRight  -   ]+naturalStrategy :: LabeledStrategy (Context Expr)+naturalStrategy = label "simplify" $ +   repeat $ somewhere $ alternatives $ map use+      [ calcPlusWith     "natural" natView+      , calcMinusWith    "natural" natView+      , calcTimesWith    "natural" natView+      , calcDivisionWith "natural" natView+      , doubleNegate, negateZero, plusNegateLeft, plusNegateRight+      , minusNegateLeft, minusNegateRight, timesNegateLeft+      , timesNegateRight, divisionNegateLeft, divisionNegateRight  +      ]  where    natView = makeView f fromInteger     where       f (Nat n) = Just n       f _       = Nothing -integerStrategy :: LabeledStrategy Expr-integerStrategy = label "simplify" $ repeat $ alternatives $ map swRule-   [ calcPlusWith     "int" integerNormalForm-   , calcMinusWith    "int" integerNormalForm-   , calcTimesWith    "int" integerNormalForm-   , calcDivisionWith "int" integerNormalForm-   , doubleNegate-   , negateZero-   ]--rationalStrategy :: LabeledStrategy Expr-rationalStrategy = label "simplify" $ repeat $ alternatives $ map swRule-   [ calcPlusWith     "rational" rationalRelaxedForm-   , calcMinusWith    "rational" rationalRelaxedForm-   , calcTimesWith    "rational" rationalRelaxedForm-   , calcDivisionWith "int"      integerNormalForm-   , doubleNegate-   , negateZero-   , divisionDenominator-   , divisionNumerator-   , simplerFraction-   ]--fractionStrategy :: LabeledStrategy Expr-fractionStrategy = label "simplify" $ repeat $ alternatives $ map swRule-   [ fractionPlus, fractionPlusScale, fractionTimes-   , calcPlusWith     "int" integerNormalForm-   , calcMinusWith    "int" integerNormalForm-   , calcTimesWith    "int" integerNormalForm -- not needed?-   , calcDivisionWith "int" integerNormalForm-   , doubleNegate-   , negateZero-   , divisionDenominator  -   , divisionNumerator -   , simplerFraction -- only apply when fractionPlusScale is not applicable-   ]--swRule :: Uniplate a => Rule a -> Rule a-swRule r = makeSimpleRuleList (name r) (somewhereM (applyAll r))----------------------------------------------------------------- Test code+integerStrategy :: LabeledStrategy (Context Expr)+integerStrategy = label "simplify" $ +   repeat $ somewhere $ alternatives $ map use+      [ calcPlusWith     "integer" integerNormalForm+      , calcMinusWith    "integer" integerNormalForm+      , calcTimesWith    "integer" integerNormalForm+      , calcDivisionWith "integer" integerNormalForm+      , doubleNegate, negateZero+      ] -testAll :: IO ()-testAll = sequence_ [test1, test2, test3, test4]+rationalStrategy :: LabeledStrategy (Context Expr)+rationalStrategy = label "simplify" $ +   repeat $ somewhere $ alternatives $ map use+      [ calcPlusWith     "rational" rationalRelaxedForm+      , calcMinusWith    "rational" rationalRelaxedForm+      , calcTimesWith    "rational" rationalRelaxedForm+      , calcDivisionWith "integer"      integerNormalForm+      , doubleNegate, negateZero, divisionDenominator+      , divisionNumerator, simplerFraction+      ] -test1 = quickCheck $ forAll (sized integerGenerator) $ \e -> -   Prelude.not (e `belongsTo` integerView) || -   applyD naturalStrategy e `belongsTo` integerNormalForm-   -test2 = quickCheck $ forAll (sized integerGenerator) $ \e -> -   Prelude.not (e `belongsTo` integerView) || -   applyD integerStrategy e `belongsTo` integerNormalForm-   -test3 = quickCheck $ forAll (sized rationalGenerator) $ \e -> -   Prelude.not (e `belongsTo` rationalView) || -   applyD rationalStrategy e `belongsTo` rationalNormalForm-   -test4 = quickCheck $ forAll (sized rationalGenerator) $ \e -> -   Prelude.not (e `belongsTo` rationalView) || -   applyD fractionStrategy e `belongsTo` rationalNormalForm-   -{- testC = quickCheck $ forAll (sized rationalGenerator) $ \e -> -   let a = cleanUp e-   in a == cleanUp a -}+fractionStrategy :: LabeledStrategy (Context Expr)+fractionStrategy = label "simplify" $ +   repeat $ +      somewhere +         (  use (calcPlusWith     "integer" integerNormalForm)+        <|> use (calcMinusWith    "integer" integerNormalForm)+        <|> use (calcTimesWith    "integer" integerNormalForm) -- not needed?+        -- <|> use (calcDivisionWith "integer" integerNormalForm)  -- not needed?+         ) |> +      somewhere+         (  use doubleNegate <|> use negateZero <|> use divisionDenominator  +        <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator+         ) |>+      somewhere (use fractionPlusScale) |>+      somewhere (use simplerFraction)
src/Domain/Math/Numeric/Tests.hs view
@@ -11,59 +11,65 @@ ----------------------------------------------------------------------------- module Domain.Math.Numeric.Tests (main) where -import Common.Apply+import Common.Classes+import Common.Context+import Common.TestSuite import Common.View import Control.Monad+import Data.Maybe import Domain.Math.Expr import Domain.Math.Numeric.Generators import Domain.Math.Numeric.Strategies import Domain.Math.Numeric.Views import Test.QuickCheck -main :: 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+main :: TestSuite+main = suite "Numeric tests" $ do++   suite "Correctness numeric views" $ do+      let f s v = forM_ numGenerators $ \g -> do+             addProperty ("idempotence " ++ s) $ propIdempotence g v+             addProperty ("soundness " ++ s)   $ propSoundness semEqDouble g v+      f "integer view"          integerView+      f "rational view"         rationalView+      f "integer normal form"   integerNormalForm+      f "rational normal form"  rationalNormalForm+      f "rational relaxed form" rationalRelaxedForm++   suite "Normal forms" $ do+      let f s v = forM_ numGenerators $ \g ->+             addProperty s $ propNormalForm g v+      f "integer normal form" integerNormalForm     -- f rationalNormalForm -- no longer a normal form -   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-   +   suite "Correctness generators" $ do+      let f s g v = addProperty s $ forAll (sized g) (`belongsTo` v)+      f "integer" integerGenerator integerView+      f "rational" rationalGenerator rationalView+      f "ratio expr" ratioExprGen rationalNormalForm+      f "ratio expr nonzero" ratioExprGenNonZero rationalNormalForm++   suite "View relations" $ do+      let va .>. vb = forM_ numGenerators $ \g -> +             addProperty "" $ forAll g $ \a -> +                not (a `belongsTo` va) || a `belongsTo` vb+      integerNormalForm .>. integerView+      rationalNormalForm .>. rationalRelaxedForm+      rationalRelaxedForm .>. rationalView+      integerNormalForm .>. rationalNormalForm+      integerView .>. rationalView++   suite "Pre/post conditions strategies" $ do+      let f l s pre post = forM_ numGenerators $ \g -> +             addProperty l $ forAll g $ \a ->+                let run = fromMaybe a . fromContext . applyD s +                        . newContext emptyEnv . termNavigator+                in not (a `belongsTo` pre) || run a `belongsTo` post+      f "natural"  naturalStrategy  integerView  integerNormalForm+      f "integer"  integerStrategy  integerView  integerNormalForm+      f "rational" rationalStrategy rationalView rationalNormalForm+      f "fraction" fractionStrategy rationalView rationalNormalForm+ numGenerators :: [Gen Expr] numGenerators = map sized     [ integerGenerator, rationalGenerator@@ -73,12 +79,11 @@ semEqDouble :: Expr -> Expr -> Bool semEqDouble a b =     case (match doubleView a, match doubleView b) of-      (Just a, Just b)   -> a ~= b+      (Just x, Just y)   -> x ~= y       (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+   x ~= y = abs x < delta || abs y < delta || abs (1 - (x/y)) < delta
src/Domain/Math/Numeric/Views.hs view
@@ -10,13 +10,14 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Numeric.Views-   ( integralView, realView-   , integerView, rationalView, doubleView, mixedFractionView+   ( integralView, integerView+   , rationalView, doubleView, mixedFractionView    , integerNormalForm, rationalNormalForm, mixedFractionNormalForm    , rationalRelaxedForm, fractionForm    , intDiv, fracDiv, exprToNum    ) where +import Common.Rewriting import Common.View import Control.Monad import Data.Ratio@@ -26,37 +27,34 @@ -- Numeric views  integralView :: Integral a => View Expr a-integralView = makeView (exprToNum f) fromIntegral+integralView = newView "num.integer" (exprToNum f) fromIntegral  where    f s [x, y] -      | s == divideSymbol = +      | isDivideSymbol s =             intDiv x y-      | s == powerSymbol = do+      | isPowerSymbol s = do            guard (y >= 0)            return (x Prelude.^ y)    f _ _ = Nothing+   +integerView :: View Expr Integer+integerView = integralView -realView :: RealFrac a => View Expr a-realView = makeView (exprToNum f) (fromRational . toRational)+rationalView :: View Expr Rational+rationalView = newView "num.rational" (exprToNum f) fromRational  where    f s [x, y] -      | s == divideSymbol = +      | isDivideSymbol s =             fracDiv x y-      | s == powerSymbol = do+      | isPowerSymbol s = do            let ry = toRational y            guard (denominator ry == 1)            let a = x Prelude.^ abs (numerator ry)            return (if numerator ry < 0 then 1/a else a)    f _ _ = Nothing    -integerView :: View Expr Integer-integerView = integralView--rationalView :: View Expr Rational-rationalView = makeView (match realView) fromRational- mixedFractionView :: View Expr Rational-mixedFractionView = makeView (match realView) mix +mixedFractionView = newView "num.mixed-fraction" (match rationalView) mix   where    mix r =        let (d, m) = abs (numerator r) `divMod` denominator r@@ -65,7 +63,7 @@       in sign (fromInteger d .+. rest)  doubleView :: View Expr Double-doubleView = makeView rec Number+doubleView = newView "num.double" rec Number  where    rec expr =       case expr of@@ -78,14 +76,14 @@  -- N or -N (where n is a natural number) integerNormalForm :: View Expr Integer-integerNormalForm = makeView (optionNegate f) fromInteger+integerNormalForm = newView "num.integer-nf" (optionNegate f) fromInteger  where    f (Nat n) = Just n    f _       = Nothing  -- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5) rationalNormalForm :: View Expr Rational-rationalNormalForm = makeView f fromRational+rationalNormalForm = newView "num.rational-nf" f fromRational  where       f (Nat a :/: Nat b) = simple a b    f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b)@@ -98,7 +96,7 @@       | otherwise = Nothing  mixedFractionNormalForm :: View Expr Rational-mixedFractionNormalForm = makeView f fromRational+mixedFractionNormalForm = newView "num.mixed-fraction-nf" f fromRational  where    f (Negate (Nat a) :-: (Nat b :/: Nat c)) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c)    f (Negate (Nat a :+: (Nat b :/: Nat c))) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c)@@ -114,7 +112,7 @@       | otherwise = Nothing  fractionForm :: View Expr (Integer, Integer)-fractionForm = makeView f (\(a, b) -> (fromInteger a :/: fromInteger b))+fractionForm = newView "num.fraction-form" f (\(a, b) -> (fromInteger a :/: fromInteger b))  where    f (Negate a) = liftM (first negate) (g a)    f a = g a@@ -126,7 +124,7 @@    g _       = Nothing  rationalRelaxedForm :: View Expr Rational-rationalRelaxedForm = makeView (optionNegate f) fromRational+rationalRelaxedForm = newView "num.rational-relaxed" (optionNegate f) fromRational  where    f (e1 :/: e2) = do       a <- match integerNormalForm e1@@ -145,9 +143,9 @@  doubleSym :: Symbol -> [Double] -> Maybe Double doubleSym s [x, y] -   | s == divideSymbol = fracDiv x y-   | s == powerSymbol  = floatingPower x y   -   | s == rootSymbol && x >= 0 && y >= 1 = Just (x ** (1/y))+   | isDivideSymbol s = fracDiv x y+   | isPowerSymbol  s = floatingPower x y   +   | isRootSymbol   s && x >= 0 && y >= 1 = Just (x ** (1/y)) doubleSym _ _ = Nothing  -- General numeric interpretation function: constructors Sqrt and
src/Domain/Math/Polynomial/BuggyRules.hs view
@@ -8,37 +8,426 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) ----- Some buggy rules catching common misconceptions on the abc-formula+-- Some buggy rules catching common misconceptions (also on the abc-formula) -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.BuggyRules where +import Prelude hiding ((^))+import Common.Id import Domain.Math.Expr import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Polynomial.Views-import Domain.Math.Polynomial.Rules (abcFormula)+import Domain.Math.Polynomial.Rules+import Domain.Math.Polynomial.CleanUp import Domain.Math.Numeric.Views+import Domain.Math.Data.Polynomial+import Domain.Math.Equation.CoverUpRules+import Common.Classes+import Common.Context+import Common.Rewriting import Common.View-import Common.Transformation-import Common.Traversable+import Common.Transformation (Rule, buggyRule, siblingOf, Transformation, useRecognizer, supply1, makeTransList) import Control.Monad+import qualified Common.Transformation as Rule -abcBuggyRules :: [Rule (OrList (Equation Expr))]-abcBuggyRules = map f [ minusB, twoA, minus4AC, oneSolution ]+makeRule :: IsId n => n -> Transformation a -> Rule a+makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a+makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a+ruleList :: (RuleBuilder f a, Rewrite a, IsId n) => n -> [f] -> Rule a++makeRule           = buggyName Rule.makeRule+makeSimpleRule     = buggyName Rule.makeSimpleRule+makeSimpleRuleList = buggyName Rule.makeSimpleRuleList+ruleList           = buggyName Rule.ruleList++buggyName :: IsId n => (Id -> a) -> n -> a+buggyName f s = f ("algebra.equations.buggy" # s)++buggyRulesExpr :: [Rule Expr]+buggyRulesExpr = +   map (siblingOf distributeTimes)+   [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign+   , buggyDistrTimesTooMany, buggyDistrTimesDenom+   ] +++   [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined+   ]++buggyRulesEquation :: [Rule (Equation Expr)]+buggyRulesEquation = +   [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide+   , buggyNegateAll+   , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus+   , buggyMultiplyOneSide, buggyMultiplyForgetOne+   ]++buggyPlus :: Rule (Equation Expr)+buggyPlus = describe "Moving a term from the left-hand side to the \+   \right-hand side (or the other way around), but forgetting to change \+   \the sign." $ +   buggyRule $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do+      (a, b) <- matchM plusView lhs+      [ a :==: rhs + b, b :==: rhs + a ]+    `mplus` do+      (a, b) <- matchM plusView rhs+      [ lhs + a :==: b, lhs + b :==: a ]++buggyNegateOneSide :: Rule (Equation Expr)+buggyNegateOneSide = describe "Negate terms on one side only." $+   buggyRule $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) ->+      [ -lhs :==: rhs, lhs :==: -rhs  ] ++buggyFlipNegateOneSide :: Rule (Equation Expr)+buggyFlipNegateOneSide = describe "Negate terms on one side only." $+   buggyRule $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) ->+      [ -rhs :==: lhs, rhs :==: -lhs  ]++buggyNegateAll :: Rule (Equation Expr)+buggyNegateAll = describe "Negating all terms (on both sides of the equation, \+   \but forgetting one term." $+   buggyRule $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do +      xs <- matchM sumView lhs+      ys <- matchM sumView rhs+      let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys)+          makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys)+          makeEq as bs = build sumView as :==: build sumView bs+          f i j = if i==j then id else negate+          len as = let n = length as in if n < 2 then -1 else n+      map makeL [0 .. len xs] ++ map makeR [0 .. len ys]++buggyDivNegate :: Rule (Equation Expr)+buggyDivNegate = describe "Dividing, but wrong sign." $+   buggyRule $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do+      (a, b) <- matchM timesView lhs+      [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ]+    `mplus` do+      (a, b) <- matchM timesView rhs+      [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ]++buggyDivNumDenom :: Rule (Equation Expr)+buggyDivNumDenom = describe "Dividing both sides, but swapping \+   \numerator/denominator." $+   buggyRule $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do+      (a, b) <- matchM timesView lhs+      [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ]+    `mplus` do+      (a, b) <- matchM timesView rhs+      [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ]++buggyDistrTimes :: Rule Expr+buggyDistrTimes = describe "Incorrect distribution of times over plus: one \+   \term is not multiplied." $+   buggyRule $ makeSimpleRuleList "distr-times-plus" $ \expr -> do+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr+      [ a*b+c, b+a*c ]+    `mplus` do+      ((a, b), c) <- matchM (timesView >>> first plusView) expr+      [ a*c+b, a+b*c ]++buggyDistrTimesForget :: Rule Expr+buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \+   \one term is forgotten." $+   buggyRule $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr+      [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ]+    `mplus` do+      ((a, b), c) <- matchM (timesView >>> first plusView) expr+      [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b]  where-   f r = r { ruleSiblings = [name abcFormula] }+   forget :: Expr -> [Expr]+   forget expr =+      case match productView expr of+         Just (b, xs) | n > 1 -> +            [ build productView (b, make i) | i <- [0..n-1] ]+          where+            make i = [ x | (j, x) <- zip [0..] xs, i/=j ]+            n = length xs+         _ -> [0] +buggyDistrTimesSign :: Rule Expr+buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \+   \changing sign of addition." $+   buggyRule $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr+      [ a.*.b .-. a.*.c ]+    `mplus` do+      ((a, b), c) <- matchM (timesView >>> first plusView) expr+      [ a.*.c .-. b.*.c ]++buggyDistrTimesTooMany :: Rule Expr+buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \+   \a*(b+c)+d, where 'a' is also multiplied to d." $ +   buggyRule $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do+      ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr+      [cleanUpExpr $ a*b+a*c+a*d]++buggyDistrTimesDenom :: Rule Expr+buggyDistrTimesDenom = describe "Incorrct distribution of times over plus: \+   \one of the terms is a fraction, and the outer expression is multiplied by \+   \the fraction's denominator." $+   buggyRule $ makeSimpleRuleList "distr-times-denom" $ \expr -> do+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr+      [(1/a)*b + a*c, a*b + (1/a)*c]+    `mplus` do+      ((a, b), c) <- matchM (timesView >>> first plusView) expr+      [a*(1/c) + b*c, a*c + b*(1/c)]++buggyMinusMinus :: Rule Expr+buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \+   \change sign." $+   buggyRule $ makeSimpleRule "minus-minus" $ \expr ->+      case expr of+         a :-: (b :-: c)  -> Just (a-b-c)+         Negate (a :-: b) -> Just (a-b) +         _ -> Nothing++buggyCancelMinus :: Rule (Equation Expr)+buggyCancelMinus = describe "Cancel terms on both sides, but terms have \+   \different signs." $+   buggyRule $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do+      xs <- matchM sumView lhs+      ys <- matchM sumView rhs  +      [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys+           , cleanUpExpr x == cleanUpExpr (-y) +           , let f n as = build sumView $ take n as ++ drop (n+1) as+           , let eq = f i xs :==: f j ys+           ]++buggyPriorityTimes :: Rule Expr+buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \+   \ignoring some parentheses." $+   buggyRule $ makeSimpleRuleList "priority-times" $ \expr -> do+      (a, (b, c)) <- matchM (plusView >>> second timesView) expr+      [(a+b)*c]+    `mplus` do+      ((a, b), c) <- matchM (plusView >>> first timesView) expr+      [a*(b+c)]++buggyMultiplyOneSide :: Rule (Equation Expr)+buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $+   buggyRule $ makeRule "multiply-one-side" $ +   useRecognizer recognizeEq $ supply1 (const (Just 2)) multiplyOneSide+ where+   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =+      let p r  = r `notElem` [-1, 0, 1] && +                 any (myEq eq2) (applyAll (multiplyOneSide r) eq1)+      in maybe False p (recognizeMultiplication a1 b1) +      || maybe False p (recognizeMultiplication a2 b2)++recognizeMultiplication :: Expr -> Expr -> Maybe Rational+recognizeMultiplication a b = do+   (_, pa) <- match (polyViewWith rationalView) a +   (_, pb) <- match (polyViewWith rationalView) b+   let d = coefficient (degree pa) pa+   guard (d /= 0)+   return (coefficient (degree pb) pb / d)+   +multiplyOneSide :: Rational -> Transformation (Equation Expr)+multiplyOneSide r = makeTransList $ \(lhs :==: rhs) -> do+      xs <- matchM sumView lhs+      ys <- matchM sumView rhs+      let f = map (*fromRational r)+      [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)]++buggyMultiplyForgetOne :: Rule (Equation Expr)+buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \+   \equation, but forget one." $+   buggyRule $ makeRule "multiply-forget-one" $ +   useRecognizer recognizeEq $ supply1 (const (Just 2)) multiplyForgetOne+ where+   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =+      let p r  = r `notElem` [-1, 0, 1] && +                 any (myEq eq2) (applyAll (multiplyForgetOne r) eq1)+      in maybe False p (recognizeMultiplication a1 b1) +      || maybe False p (recognizeMultiplication a2 b2)++multiplyForgetOne :: Rational -> Transformation (Equation Expr)+multiplyForgetOne r = makeTransList $ \(lhs :==: rhs) -> do+   xs <- matchM sumView lhs+   ys <- matchM sumView rhs+   let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys)+       makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys) +       f as bs = build sumView as :==: build sumView bs+       mul b   = if b then (*fromRational r) else id+   do guard (length xs > 1) +      map makeL [0 .. length xs-1]+    `mplus` do+      guard (length ys > 1)+      map makeR [0 .. length ys-1]++-- Redundant function; should come from exercise+myEq :: Equation Expr -> Equation Expr -> Bool+myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr)++---------------------------------------------------------+-- Quadratic and Higher-Degree Polynomials++buggyQuadratic :: IsTerm a => [Rule (Context a)]+buggyQuadratic =+   map use+      [ buggyCoverUpTimesMul, buggyCoverUpEvenPower+      , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth+      , buggyDivisionByVarZero+      ] +++   map use+      [ buggyDistributionSquare, buggyDistributionSquareForget+      , buggySquareMultiplication+      ] +++   map use+      [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget+      , buggyCoverUpSquareMinus+      ]++buggyCoverUpEvenPower :: Rule (Equation Expr)+buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \+   \the negative root" $ buggyRule $ siblingOf coverUpPower $+   makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) ->+      make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs+ where+   make equals ab c = do +      (a, b) <- isBinary powerSymbol ab+      n <- matchM integerView b+      guard (n > 0 && even n)+      return (a `equals` root c (fromInteger n))++buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr))+buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \+   \but there is some other operation to be done first. Example: x^2+1=9" $+   buggyRule $ siblingOf coverUpPower $ +   makeSimpleRuleList "coverup.even-power-too-early" $ +      oneDisjunct $ helperBuggyCUPower True++buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr))+buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \+   \but there is some other operation to be done first. Example: 9*x^2=81, \+   \ and rewriting this into x=9 or x=-9." $+   buggyRule $ siblingOf coverUpPower $ +   makeSimpleRuleList "coverup.even-power-forget" $ +      oneDisjunct $ helperBuggyCUPower False++helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)]+helperBuggyCUPower mode (lhs :==: rhs) =+   make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs+ where+   make equals ab c = do+      (sym, xs) <- getFunction ab+      (i, x)    <- zip [0..] xs+      (a, b)    <- isBinary powerSymbol x+      n         <- matchM integerView b+      guard (n > 0 && even n)+      let opa | mode      = function sym (take i xs ++ [a] ++ drop (i+1) xs)+              | otherwise = a+          rb  = root c (fromInteger n)+      return $ orList [opa `equals` rb, opa `equals` (-rb)]++buggyCoverUpTimesMul :: Rule (Equation Expr)+buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \+   \dividing the right-hand side, multiplication is used." $+   buggyRule $ siblingOf coverUpTimes $ +   makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do+      guard (rhs /= 0)+      (a, b) <- isTimes lhs+      [a :==: rhs*b, b :==: rhs*a]+    `mplus` do+      guard (lhs /= 0)+      (a, b) <- isTimes rhs+      [lhs*a :==: b, lhs*b :==: a]++buggyDistributionSquare :: Rule Expr+buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \+   \addition: forgetting the 2ab term" $ +   buggyRule $ siblingOf distributionSquare $+   ruleList "distr-square"+      [ \a b -> (a+b)^2 :~> a^2+b^2+      , \a b -> (a-b)^2 :~> a^2-b^2+      , \a b -> (a-b)^2 :~> a^2+b^2+      ]++buggyDistributionSquareForget :: Rule Expr+buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \+   \addition: squaring only one term" $ +   buggyRule $ siblingOf distributionSquare $+   ruleList "distr-square-forget"+      [ \a b -> (a+b)^2 :~> a^2+b+      , \a b -> (a+b)^2 :~> a+b^2+      , \a b -> (a-b)^2 :~> a^2-b+      , \a b -> (a-b)^2 :~> a-b^2+      ]++buggySquareMultiplication :: Rule Expr+buggySquareMultiplication = describe "Incorrect square of a term that involves \+   \a multiplication." $ buggyRule $+   ruleList "square-multiplication"+      [ \a b -> (a*b)^2 :~> a*b^2+      , \a b -> (a*b)^2 :~> a^2*b+      , \a b -> a*b^2   :~> (a*b)^2+      , \a b -> a^2*b   :~> (a*b)^2+      ] ++buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr))+buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \+   \on the right-hand side, resulting in an error in the signs" $+   buggyRule $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq -> +      case eq of+         Sym s [a, 2] :==: b | isPowerSymbol s -> +            Just $ orList [a :==: sqrt b, a :==: sqrt (-b)]+         _ -> Nothing++buggyCoverUpTimesWithPlus :: Rule (Equation Expr)+buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \+   \addition on the other side. Only one of the terms is divided." $ +   buggyRule $ makeSimpleRuleList "coverup.times-with-plus" $ +   \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs+ where+   make equals ab cd = do+      (a, b) <- isTimes ab+      (c, d) <- isPlus cd+      [ a `equals` (c/b+d), a `equals` (c+d/b), +        b `equals` (c/a+d), b `equals` (c+d/a) ]+        +buggyDivisionByVarBoth :: Rule (Equation Expr)+buggyDivisionByVarBoth = describe "Divide both sides by variable, without \+   \introducing the x=0 alternative." $ +   buggyRule $ makeSimpleRule "division-by-var-both" $ +   \(lhs :==: rhs) -> do+      (s1, p1) <- match polyView lhs+      (s2, p2) <- match polyView rhs+      let n = lowestDegree p1 `min` lowestDegree p2+      guard (n > 0 && s1==s2)+      let f p = build polyView (s1, raise (-n) p)+      return (f p1 :==: f p2)++buggyDivisionByVarZero :: Rule (Equation Expr)+buggyDivisionByVarZero = describe "Divide both sides by variable, without \+   \introducing the x=0 alternative." $ +   buggyRule $ makeSimpleRuleList "division-by-var-zero" $ +   \(lhs :==: rhs) -> do+      guard (rhs == 0)+      (s, p) <- matchM polyView lhs+      let n = lowestDegree p+      guard (n > 0)+      -- Quick fix to do some trivial steps for a linear equation, so that+      -- buggy rules are recognized. +      let eq = build polyView (s, raise (-n) p) :==: 0+      eq : applyM coverUpPlus eq++---------------------------------------------------------+-- ABC formula misconceptions++abcBuggyRules :: [Rule (OrList (Equation Expr))]+abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ]+ abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)])                  -> Transformation (OrList (Equation Expr)) abcMisconception f = makeTransList $ -   onceJoinM $ \(lhs :==: rhs) -> do+   oneDisjunct $ \(lhs :==: rhs) -> do       guard (rhs == 0)       (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs       f x a b c        minusB :: Rule (OrList (Equation Expr))-minusB = buggyRule $ makeRule "abc misconception minus b" $ +minusB = buggyRule $ makeRule "abc.minus-b" $     abcMisconception $ \x a b c -> do       let discr = sqrt (fromRational (b*b - 4 * a * c))           f (?) buggy = @@ -50,7 +439,7 @@                    twoA :: Rule (OrList (Equation Expr))-twoA = buggyRule $ makeRule "abc misconception two a" $ +twoA = buggyRule $ makeRule "abc.two-a" $     abcMisconception $ \x a b c -> do       let discr = sqrt (fromRational (b*b - 4 * a * c))           f (?) buggy = @@ -61,7 +450,7 @@         orList [ f (+) True,  f (-) False ]]           minus4AC :: Rule (OrList (Equation Expr))-minus4AC = buggyRule $ makeRule "abc misconception minus 4ac" $ +minus4AC = buggyRule $ makeRule "abc.minus-4ac" $     abcMisconception $ \x a b c -> do       let discr (?) = sqrt (fromRational ((b*b) ? (4 * a * c)))           f (?) buggy = @@ -72,7 +461,7 @@         orList [ f (+) True,  f (-) False ]]           oneSolution :: Rule (OrList (Equation Expr))-oneSolution = buggyRule $ makeRule "abc misconception one solution" $ +oneSolution = buggyRule $ makeRule "abc.one-solution" $     abcMisconception $ \x a b c -> do       let discr = sqrt (fromRational (b*b - 4 * a * c))           f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a)
src/Domain/Math/Polynomial/CleanUp.hs view
@@ -10,23 +10,25 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.CleanUp -   ( cleanUp, cleanUpRelation, cleanUpExpr, cleanUpExpr2+   ( cleanUpRelations, cleanUpRelation, cleanUpExpr    , cleanUpSimple, collectLikeTerms-   , normalizeSum, normalizeProduct+   , acExpr, smart    ) where +import Common.Utils (fixpoint) import Common.Uniplate import Common.View import Control.Monad import Data.List import Data.Maybe+import Data.Ord import Domain.Math.Data.OrList import Domain.Math.Data.Relation import Domain.Math.Data.SquareRoot (fromSquareRoot) import Domain.Math.Expr import Domain.Math.Numeric.Views-import Domain.Math.Power.Views-import Domain.Math.Simplification (smartConstructors)+import Domain.Math.Power.OldViews+import Domain.Math.Simplification hiding (simplify, simplifyWith) import Domain.Math.SquareRoot.Views import Prelude hiding ((^), recip) import qualified Prelude@@ -44,10 +46,10 @@    f x y       | x == 0              = 0       | y == 0 || x <= 0    = root (fromIntegral x) (fromIntegral y)-      | a Prelude.^ y == x  = fromIntegral a+      | e Prelude.^ y == x  = fromIntegral e       | otherwise           = root (fromIntegral x) (fromIntegral y)     where-      a = round (fromIntegral x ** (1 / fromIntegral y))+      e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y))  ---------------------------------------------------------------------- -- Expr normalization@@ -55,108 +57,58 @@ collectLikeTerms :: Expr -> Expr collectLikeTerms = simplifyWith f sumView  where-   f = normalizeSum . map (simplifyWith (second normalizeProduct) productView)--normalizeProduct :: [Expr] -> [Expr]-normalizeProduct ys = f [ (match rationalView y, y) | y <- ys ]- where  -   f []                    = []-   f ((Nothing  , e):xs)   = e:f xs-   f ((Just r   , _):xs)   = -      let cs   = r : [ c | (Just c, _) <- xs ]-          rest = [ x | (Nothing, x) <- xs ]-      in build rationalView (product cs):rest--normalizeSum :: [Expr] -> [Expr]-normalizeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ]- where-   pm :: Rational -> Expr -> (Rational, Expr)-   pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of-                         (Just r1, _) -> pm (r*r1) e2-                         (_, Just r1) -> pm (r*r1) e1-                         _           -> (r, e1 .*. e2)-   pm r (Negate e) = pm (negate r) e-   pm r e = case match rationalView e of-               Just r1 -> (r*r1, Nat 1)-               Nothing -> (r, e)-   -   rec [] = []-   rec ((Nothing, e):xs) = e:rec xs-   rec ((Just (r, a), e):xs) = new:rec rest-    where-      (js, rest) = partition (maybe False ((==a) . snd) . fst) xs-      rs  = r:map fst (mapMaybe fst js)-      new | null js   = e-          | otherwise = build rationalView (sum rs) .*. a +   f = mergeAlikeSum . map (simplifyWith (second mergeAlikeProduct) productView)  --------------------------------------------------------------- Testing--{---- List with hard cases-hardCases = map cleanUpExpr $ let x=Var "x" in-  [ -1/2*x*(x/1)-  , (x/(-3))-  , (x/(-3))^2-  , (0-x)*(-x)/(-5/2)-  , (x/(-1))^2-  , (x/(-1))^2-(-7/2)*x/(-1)-  , (x^2+0)*3-  , -(49/9*x^2+0^2)*(3/16)-  , (0*x-(-x^2))*(-3)-  , x^2 - x^2-  , x^2-x^2-(x+x)*1-  , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1-  , (-7+7*x)^2-(x*0)^2/(-3)-  , 1*(x+93)+4-  , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9-  ] -}-          ------------------------------------------------------------- -- Cleaning up  cleanUpSimple :: Expr -> Expr-cleanUpSimple = transform (f4 . f2 . f1)+cleanUpSimple = fixpoint (transform (f2 . f1))  where-   use v = simplifyWith (assoPlus v) sumView-   f1    = simplify rationalView-   f2    = use identity-   f4    = smartConstructors--cleanUpRelation :: OrList (Relation Expr) -> OrList (Relation Expr)-cleanUpRelation = simplifyWith cleanUp (switchView equationView)+   use v = simplifyWith (assocPlus v) sumView+   f1 = use rationalView+   f2 = smartConstructors -cleanUp :: OrList (Equation Expr) -> OrList (Equation Expr)-cleanUp = idempotent . join . fmap (keepEquation . fmap cleanUpExpr)+cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr)+cleanUpRelations = idempotent . join . fmap cleanUpRelation -keepEquation :: Equation Expr -> OrList (Equation Expr)-keepEquation eq@(a :==: b)-   | any falsity (universe a ++ universe b) = false-   | a == b    = true-   | otherwise = -        case (match rationalView a, match rationalView b) of-           (Just r, Just s) -              | r == s    -> true-              | otherwise -> false-           _              -> return eq+cleanUpRelation :: Relation Expr -> OrList (Relation Expr)+cleanUpRelation = f . fmap cleanUpBU  where+   f rel+      | any falsity (universe a ++ universe b) = false+      | a == b    = fromBool (relationType rel `elem` equals)+      | otherwise = +           case (match rationalView a, match rationalView b) of+              (Just r, Just s) -> fromBool (eval (relationType rel) r s)+              _                -> return rel+    where+      (a, b) = (leftHandSide rel, rightHandSide rel)++   equals = +      [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately]++   falsity :: Expr -> Bool    falsity (Sqrt e)  = maybe False (<0)  (match rationalView e)    falsity (_ :/: e) = maybe False (==0) (match rationalView e)    falsity _         = False-+    -- also simplify square roots-cleanUpExpr2 :: Expr -> Expr-cleanUpExpr2 = cleanUpExpr . transform (simplify (squareRootViewWith rationalView))- cleanUpExpr :: Expr -> Expr-cleanUpExpr = cleanUpBU2 {- e = if a1==a2 && a2==a3 && a3==a3 && a3==a4 then a1 else error $ "\n\n\n" ++ unlines (map show-   [e, a1, a2, a3, a4])- where-   a1 = cleanUpFix e-   a2 = cleanUpBU e-   a3 = cleanUpBU2 e-   a4 = cleanUpLattice e -}-      +cleanUpExpr = fixpoint $ +   cleanUpBU . transform (simplify (squareRootViewWith rationalView))++-- normalize expr with associativity and commutative rules for + and *+acExpr :: Expr -> Expr+acExpr expr = +   case (match sumView expr, match productView expr) of+      (Just xs, _) | length xs > 1 -> +         build sumView $ sort $ map acExpr xs+      (_, Just (b, xs)) | length xs > 1 -> +         build productView (b, sort $ map acExpr xs)+      _ -> +         descend acExpr expr+    ------------------------------------------------------------ -- Technique 1: fixed points of views {-@@ -170,178 +122,89 @@    f3 = use (powerFactorViewWith rationalView)    f4 = smartConstructors -}-assoPlus :: View Expr a -> [Expr] -> [Expr]-assoPlus v = rec . map (simplify v)+assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr]+assocPlus  = assocOp (+)+assocTimes = assocOp (*)++assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr]+assocOp op v = rec . map (simplify v)  where    rec (x:y:zs) =-      case canonical v (x+y) of-         Just a  -> assoPlus v (a:zs)-         Nothing -> x:assoPlus v (y:zs)+      case canonical v (op x y) of+         Just a  -> rec (a:zs)+         Nothing -> x:rec (y:zs)    rec xs = xs  --------------------------------------------------------------- Technique 2a: one bottom-up traversal-{-+-- Fixpoint of a bottom-up traversal+ cleanUpBU :: Expr -> Expr-cleanUpBU = transform (f4 . f3 . f2 . f1)+cleanUpBU = {- fixpoint $ -} transform $ \e -> +   simplify myView $ +   fromMaybe (smart e) $+      canonical rationalView e+    `mplus` do+      a <- canonical specialSqrtOrder e+      -- Just simplify order of terms with square roots for now+      return (transform smart a)+    `mplus` do+      xs <- match sumView e+      guard (length xs > 1)+      return $ build sumView $+         assocPlus myView xs+    `mplus`+      canonical myView e+    `mplus` do+      (b, xs) <- match productView e+      guard (length xs > 1)+      return $ build productView +         (b, assocTimes myView xs)  where-   use v = simplifyWith (assoPlus v) sumView- -   f1 = simplify rationalView-   f2 = simplify (squareRootViewWith rationalView)-   f3 = use (powerFactorViewWith rationalView)-   f4 = smartConstructors--}---------------------------------------------------------------- Technique 2b: one bottom-up traversal--cleanUpBU2 :: Expr -> Expr-cleanUpBU2 = transform $ \e -> -   case ( canonical rationalView e-        , canonical specialSqrtOrder e-        , match sumView e-        ) of-      (Just a, _, _) -> a-      (_, Just a, _) -> -- Just simplify order of terms with square roots for now-                        transform smart a-      (_, _, Just xs) | length xs > 1 -> -         build sumView (assoPlus (powerFactorViewWith rationalView) xs)-      _ -> case canonical (powerFactorViewWith rationalView) e of-              Just a  -> a-              Nothing -> smart e+   myView = powerFactorViewWith rationalView  specialSqrtOrder :: View Expr [Expr] specialSqrtOrder = sumView >>> makeView f id  where    make = match (squareRootViewWith rationalView)-   cmp (_, x) (_, y) = g x `compare` g y-   g = isNothing . fromSquareRoot+   g    = isNothing . fromSquareRoot . snd    f xs = do       ys <- mapM make xs-      return $ map fst $ sortBy cmp $ zip xs ys+      return $ map fst $ sortBy (comparing g) $ zip xs ys  smart :: Expr -> Expr smart (a :*: b) = a .*. b smart (a :/: b) = a ./. b smart expr@(Sym s [x, y]) -   | s == powerSymbol = x .^. y-   | s == rootSymbol  = fromMaybe expr $ +   | isPowerSymbol s = x .^. y+   | isRootSymbol  s = fromMaybe expr $          liftM2 simplerRoot (match rationalView x) (match integerView y) smart (Negate a) = neg a smart (a :+: b) = a .+. b smart (a :-: b) = a .-. b smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2+-- smart (Sqrt a)  = maybe (Sqrt a) (`simplerRoot` 2) (match rationalView a) smart e = e ---------------------------------------------------------------- Technique 3: lattice of views-{--data T = R Rational -       | S (SquareRoot Rational)-       | P String Rational Int-       | E Expr deriving Show-   -cleanUpLattice :: Expr -> Expr-cleanUpLattice = fromT . toT -fromT :: T -> Expr-fromT (R r)     = fromRational r-fromT (S s)     = build (squareRootViewWith rationalView) s-fromT (P x r n) = build (powerFactorViewForWith x rationalView) (r, n)-fromT (E e)     = e--toT :: Expr -> T-toT (Nat n) = R (fromInteger n)-toT (x :/: y) = divT (toT x) (toT y)-toT (x :*: y) = mulT (toT x) (toT y)-toT (Var x) = P x 1 1-toT (Sym s [x, y]) | s == powerSymbol =-   case (toT x, toT y) of-      (R x, R y) | denominator y == 1  ->-         R (x Prelude.^ fromInteger (numerator y))-      (P x a n, R y) | denominator y == 1 -> -         P x (a Prelude.^ numerator y) (n*fromInteger (numerator y))-      (x, y) -> E (fromT x .^. fromT y)-toT e@(Sqrt _) = fromMaybe (E e) $ do -- Also here, too simplistic-   s <- match (squareRootViewWith rationalView) e-   return (S s)-toT (Negate e) = negT (toT e)-toT expr =-   case match sumView expr of-      Just xs | length xs > 1 -> sumT (map toT xs)-      _ -> error $ show expr-      -negT :: T -> T-negT (R r)     = R (negate r)-negT (S s)     = S (negate s)-negT (P x r n) = P x (negate r) n-negT (E e)     = E (neg e)-     -sumT :: [T] -> T-sumT = head . f (const True) . f (`elem` [1,2]) . f (==1) . concatMap g- where-   g e@(E a) = case match sumView a of-                  Just xs | length xs > 1 -> map (upgr . E) xs-                  _ -> [e]-   g a = [a]- -   f p (a:b:xs)-      | p (orderT a) && p (orderT b) = -           f p (plusT a b:xs)-      | otherwise  = a:f p (b:xs)-   f _ xs = xs--plusT :: T -> T -> T-plusT (R 0) t = t -- ?????-plusT t (R 0) = t -- ?????-plusT (R x) (R y) = R (x+y)-plusT (S x) (S y) = S (x+y)-plusT t@(P _ _ _) b = plusT (E $ fromT t) b -plusT (E a) (E b) = E (a .+. b)-plusT a b = convTs plusT a b--divT :: T -> T -> T-divT t (R 1) = t -- ?????-divT t (R (-1)) = negT t -- ?????-divT (R x) (R y) | y /= 0 = R (x/y)-divT t@(R _) b@(R _) = divT (E $ fromT t) b-divT (S x) (S y) = S (x/y)-divT t@(P _ _ _) b = divT (E $ fromT t) b -divT (E a) (E b) = E (a ./. b)-divT a b = convTs divT a b--mulT :: T -> T -> T-mulT (R 0) _     = R 0 -- ?????-mulT _ (R 0)     = R 0 -- ?????-mulT t (R 1)     = t -- ????-mulT (R 1) t     = t -- ?????-mulT (R a) (R b) = R (a*b)-mulT (S a) (S b) = S (a*b)-mulT (P x1 r1 n1) (P x2 r2 n2) | x1==x2 = P x1 (r1*r2) (n1+n2)-                               | otherwise = error ""-mulT (E a) (E b) = E (a .*. b)-mulT a b = convTs mulT a b--convTs :: (T -> T -> T) -> T -> T -> T-convTs f (R a) t@(S _)       = f (S (fromRational a)) t-convTs f (R a) t@(P x _ _)   = f (P x (fromRational a) 0) t-convTs f t@(R _) e@(E _)     = f (E $ fromT t) e-convTs f t@(P _ _ _) e@(E _) = f (E $ fromT t) e-convTs f a b | orderT a > orderT b = convTs (flip f) b a-convTs _ x y = error $ "conv " ++ show (x, y)--orderT :: T -> Int-orderT (R _)     = 1-orderT (S _)     = 2-orderT (P _ _ _) = 3-orderT (E _)     = 4+------------------------------------------------------------+-- Testing -upgr :: T -> T-upgr (E e) =-   case (match (squareRootViewWith rationalView) e, match (powerFactorViewWith rationalView) e) of-      (Just a, _) -> upgr (S a)-      (_, Just (x, a, n)) -> upgr (P x a n)-      _ -> E e-upgr (S a) = maybe (S a) R (fromSquareRoot a)-upgr (P _ a n) | n==0 = R a-upgr t = t -}+{-+-- List with hard cases+hardCases = map cleanUpExpr $ let x=Var "x" in+  [ -1/2*x*(x/1)+  , (x/(-3))+  , (x/(-3))^2+  , (0-x)*(-x)/(-5/2)+  , (x/(-1))^2+  , (x/(-1))^2-(-7/2)*x/(-1)+  , (x^2+0)*3+  , -(49/9*x^2+0^2)*(3/16)+  , (0*x-(-x^2))*(-3)+  , x^2 - x^2+  , x^2-x^2-(x+x)*1+  , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1+  , (-7+7*x)^2-(x*0)^2/(-3)+  , 1*(x+93)+4+  , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9+  ] -}
src/Domain/Math/Polynomial/Equivalence.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XGeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -15,27 +15,28 @@    , eqAfterSubstitution    ) where +import Common.Classes import Common.Context-import Common.Traversable+import Common.Rewriting+import Common.Uniplate import Common.View+import Control.Monad+import Data.List (sort, nub) import Data.Maybe+import Data.Ord+import Domain.Logic.Formula hiding (Var, disjunctions)+import Domain.Math.Clipboard+import Domain.Math.Data.Interval import Domain.Math.Data.Polynomial hiding (eval)-import Data.List (sort, nub)+import Domain.Math.Data.Relation hiding (eval)+import Domain.Math.Data.SquareRoot+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.CleanUp import Domain.Math.Polynomial.Views+import Domain.Math.SquareRoot.Views import Prelude hiding ((^), sqrt)-import 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 = @@ -106,7 +107,7 @@  -- Use normal (numeric) ordering on square roots instance Ord Q where-   Q a `compare` Q b = f a `compare` f b +   Q a `compare` Q b = comparing f a b     where       f :: SquareRoot Rational -> Double       f = eval . fmap fromRational@@ -120,14 +121,18 @@ highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool highEqContext = eqContextWith (polyEq highRel) +eqContextWith :: (Logic (Relation Expr) -> Logic (Relation Expr) -> Bool)+              -> Context (Logic (Relation Expr)) +              -> Context (Logic (Relation Expr))+              -> Bool eqContextWith eq a b = isJust $ do    termA <- fromContext a    termB <- fromContext b    guard $        case (ineqOnClipboard a, ineqOnClipboard b) of -         (Just 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+         (Just x,  Just y)  -> eq x y && eq termA termB+         (Just x,  Nothing) -> eq (fmap toEq x) termA && eq x termB+         (Nothing, Just y)  -> eq (fmap toEq y) termB && eq termA y          (Nothing, Nothing) -> eq termA termB  where    toEq :: Relation Expr -> Relation Expr@@ -151,11 +156,11 @@ cuPlus :: Relation Expr -> Maybe (Relation Expr) cuPlus rel = do    (a, b) <- match plusView (leftHandSide rel)-   guard (noVars b && noVars (rightHandSide rel))+   guard (hasNoVar b && hasNoVar (rightHandSide rel))    return $ constructor rel a (rightHandSide rel - b)  `mplus` do    (a, b) <- match plusView (leftHandSide rel)-   guard (noVars a && noVars (rightHandSide rel))+   guard (hasNoVar a && hasNoVar (rightHandSide rel))    return $ constructor rel b (rightHandSide rel - a)  `mplus` do    a <- isNegate (leftHandSide rel)@@ -175,8 +180,8 @@ 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))+   guard (n > 0 && hasNoVar (rightHandSide rel))+   let expr = cleanUpExpr (root (rightHandSide rel) (fromIntegral n))        new = constructor rel a expr        opp = constructor (flipSides rel) a (-expr)        rt  = relationType rel@@ -259,13 +264,13 @@  -- for similarity  simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool-simLogic f a b = rec (fmap f a) (fmap f b)+simLogic f p0 q0 = rec (fmap f p0) (fmap f q0)  where    rec a b   -      | isOperator orOperator a =+      | isOr a =            let collect = nub . sort . trueOr . collectOr            in recList (collect a) (collect b)-      | isOperator andOperator a =+      | isAnd a =            let collect = nub . sort . falseAnd . collectAnd            in recList (collect a) (collect b)       | otherwise = @@ -286,6 +291,17 @@        falseAnd xs = if F `elem` xs then [] else xs    +   shallowEq a b = +      let g = descend (const T) +      in g a == g b +      +   isOr (_ :||: _) = True+   isOr _          = False+   +   isAnd (_ :||: _) = True+   isAnd _          = False+   +    eqAfterSubstitution :: (Functor f, Functor g)     => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool eqAfterSubstitution eq ca cb = fromMaybe False $ do @@ -296,9 +312,7 @@  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+substitute pair expr = descend (substitute pair) expr  substOnClipboard :: Context a -> Maybe (String, Expr) substOnClipboard = evalCM $ const $ do
src/Domain/Math/Polynomial/Exercises.hs view
@@ -16,8 +16,8 @@ import Common.Exercise import Common.Rewriting import Common.Strategy-import Common.Traversable-import Common.Transformation+import Common.Classes+import Common.Uniplate import Common.View import Data.Maybe import Domain.Math.Data.OrList@@ -33,6 +33,7 @@ import Domain.Math.Polynomial.Views import Domain.Math.Polynomial.Equivalence import Domain.Math.Numeric.Views+import Domain.Math.Equation.CoverUpRules import Control.Monad  ------------------------------------------------------------@@ -40,18 +41,24 @@  linearExercise :: Exercise (Equation Expr) linearExercise = makeExercise -   { description  = "solve a linear equation"-   , exerciseCode = makeCode "math" "lineq"+   { exerciseId   = describe "solve a linear equation" $ +                       newId "algebra.equations.linear"    , status       = Provisional    , parser       = parseExprWith (pEquation pExpr)-   , similarity   = eqRelation cleanUpSimple+   , similarity   = eqRelation (acExpr . cleanUpExpr)    , equivalence  = viewEquivalent linearEquationView    , isSuitable   = (`belongsTo` linearEquationView)    , isReady      = solvedRelationWith $ \a ->                         a `belongsTo` mixedFractionNormalForm ||                         a `belongsTo` rationalNormalForm-   , extraRules   = liftToContext buggyPlus : linearRules-   , strategy     = mapRules liftToContext linearStrategy+   , extraRules   = map use buggyRulesEquation +++                    map use buggyRulesExpr +   , ruleOrdering = ruleOrderingWithId+                       [ getId coverUpTimes, getId flipEquation+                       , getId removeDivision+                       ]+   , strategy     = linearStrategy+   , navigation   = termNavigator    , examples     = concat (linearEquations ++ [specialCases])    }  where@@ -61,87 +68,93 @@        linearMixedExercise :: Exercise (Equation Expr) linearMixedExercise = linearExercise -   { description  = "solve a linear equation with mixed fractions"-   , exerciseCode = makeCode "math" "lineq-mixed"+   { exerciseId   = describe "solve a linear equation with mixed fractions" $ +                       newId "algebra.equations.linear.mixed"    , isReady      = solvedRelationWith (`belongsTo` mixedFractionNormalForm)-   , strategy     = mapRules liftToContext linearMixedStrategy+   , strategy     = linearMixedStrategy    }   quadraticExercise :: Exercise (OrList (Relation Expr)) quadraticExercise = makeExercise -   { description  = "solve a quadratic equation"-   , exerciseCode = makeCode "math" "quadreq"+   { exerciseId   = describe "solve a quadratic equation" $ +                       newId "algebra.equations.quadratic"    , status       = Provisional    , parser       = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of                                  Left err -> Left err                                  Right xs -> Right (build (switchView equationView) xs)-   , similarity   = eqOrList cleanUpExpr2+   , similarity   = eqOrList cleanUpExpr    , equivalence  = equivalentRelation (viewEquivalent quadraticEquationsView)    , isSuitable   = (`belongsTo` (switchView equationView >>> quadraticEquationsView))    , isReady      = solvedRelations-   , extraRules   = map (liftToContext . liftRule (switchView equationView)) $ -                       quadraticRules ++ abcBuggyRules+   , extraRules   = map use abcBuggyRules ++ buggyQuadratic +++                    map use buggyRulesEquation ++ map use buggyRulesExpr +   , ruleOrdering = ruleOrderingWithId $ +                       quadraticRuleOrder ++ [getId buggySquareMultiplication]    , strategy     = quadraticStrategy+   , navigation   = termNavigator    , examples     = map (orList . return . build equationView) (concat quadraticEquations)    }     higherDegreeExercise :: Exercise (OrList (Relation Expr)) higherDegreeExercise = makeExercise -   { description   = "solve an equation (higher degree)"-   , exerciseCode  = makeCode "math" "higherdegree"+   { exerciseId    = describe "solve an equation (higher degree)" $+                        newId "algebra.equations.polynomial"    , status        = Provisional    , parser        = parser quadraticExercise-   , similarity    = eqOrList cleanUpExpr2+   , similarity    = eqOrList cleanUpExpr    , eqWithContext = Just $ eqAfterSubstitution $                          equivalentRelation (viewEquivalent higherDegreeEquationsView)    , isSuitable    = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView))    , isReady       = solvedRelations-   , extraRules    = map (liftToContext . liftRule (switchView equationView)) higherDegreeRules+   , extraRules    = map use abcBuggyRules ++ buggyQuadratic +++                     map use buggyRulesEquation ++ map use buggyRulesExpr +   , ruleOrdering = ruleOrderingWithId quadraticRuleOrder    , strategy      = higherDegreeStrategy+   , navigation   = termNavigator    , examples      = map (orList . return . build equationView)                          (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations])    }     quadraticNoABCExercise :: Exercise (OrList (Relation Expr)) quadraticNoABCExercise = quadraticExercise-   { description  = "solve a quadratic equation without abc-formula"-   , exerciseCode = makeCode "math" "quadreq-no-abc"+   { exerciseId   = describe "solve a quadratic equation without abc-formula" $ +                       newId "algebra.equations.quadratic.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)+   cfg = [ (byName prepareSplitSquare, Reinsert)+         , (byName bringAToOne, Reinsert)+         , (byName (newId "abc form"), Remove)+         , (byName simplerPolynomial, Remove)          ]           quadraticWithApproximation :: Exercise (OrList (Relation Expr)) quadraticWithApproximation = quadraticExercise-   { description  = "solve a quadratic equation with approximation"-   , exerciseCode = makeCode "math" "quadreq-with-approx"+   { exerciseId   = describe "solve a quadratic equation with approximation" $ +                       newId "algebra.equations.quadratic.approximate"    , status       = Alpha    , parser       = parseExprWith (pOrList (pRelation pExpr))    , strategy     = configure cfg quadraticStrategy    , equivalence  = equivalentApprox    }  where-   cfg = [ (ByName "approximate result", Reinsert)-         , (ByName "square root simplification", Remove)+   cfg = [ (byName (newId "approximate result"), Reinsert)+         , (byName (newId "square root simplification"), Remove)          ] --- fixMe = checksForList quadraticWithApproximation- findFactorsExercise :: Exercise Expr findFactorsExercise = makeExercise-   { description  = "factorize the expression"-   , exerciseCode = makeCode "math" "factor"+   { exerciseId   = describe "factorize the expression" $ +                       newId "algebra.manipulation.polynomial.factor"    , status       = Provisional    , parser       = parseExprWith pExpr    , similarity   = \a b -> cleanUpExpr a == cleanUpExpr b    , equivalence  = viewEquivalent (polyViewWith rationalView)    , isReady      = (`belongsTo` linearFactorsView)-   , strategy     = mapRules liftToContext findFactorsStrategy+   , strategy     = findFactorsStrategy+   , navigation   = termNavigator+   , extraRules   = map liftToContext buggyRulesExpr    , examples     = concat findFactors    } @@ -180,11 +193,12 @@    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++toApprox :: Equation Expr -> Relation Expr+toApprox (a :==: b) = f a .~=. f b+ where+   f x = maybe x (Number . precision 4) (match doubleView x)+        equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool equivalentRelation f ra rb = fromMaybe False $ do@@ -196,32 +210,28 @@                (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -> Bool eqOrList f x y = normOrList f x == normOrList f y -eqRelation :: (Relational f, Eq (f Expr)) => -                 (Expr -> Expr) -> f Expr -> f Expr -> Bool-eqRelation f x y = normRelation f x == normRelation f y+eqRelation :: (Relational f, Eq (f Expr)) => (Expr -> Expr) -> f Expr -> f Expr -> Bool+eqRelation f x y = fmap f x == fmap f y +-- Normalize the order of disjunctions. Simplify the expression with the function+-- passed as argument, but do not change (flip) the sides of the relation. normOrList :: (Relational f, Ord (f Expr)) =>                   (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr)-normOrList f = normalize . fmap (normRelation f)--normRelation :: Relational f => (Expr -> Expr) -> f Expr -> f Expr-normRelation f rel-   | leftHandSide new > rightHandSide new && isSymmetric new = flipSides new-   | otherwise = new- where-   new = fmap (normExpr f) rel+normOrList f = normalize . fmap (fmap (normExpr f))  normExpr :: (Expr -> Expr) -> Expr -> Expr-normExpr f = normalizeWith [plusOperator, timesOperator] . f+normExpr f = rec . f  where-   plusOperator  = acOperator (+) isPlus-   timesOperator = acOperator (*) isTimes+   plusOperator  = makeCommutative $ monoid +                      (makeBinary (getId plusSymbol) (+) isPlus)+                      (simpleConstant "zero" 0)+   timesOperator = makeCommutative $ monoid +                      (makeBinary (getId timesSymbol) (*) isTimes)+                      (simpleConstant "one" 1)+   make          = simplifyWith (map rec) . magmaListView    --- 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 ]+   rec expr = +      case expr of+         _ :+: _ -> make plusOperator  expr+         _ :*: _ -> make timesOperator expr+         _       -> descend rec expr
src/Domain/Math/Polynomial/IneqExercises.hs view
@@ -15,20 +15,21 @@  import Common.Context import Common.Exercise+import Common.Rewriting import Common.Strategy hiding (not) import Common.Transformation-import Common.Uniplate (uniplate)+import Common.Uniplate (descend) import Common.View import Control.Monad import Data.List (nub, sort) import Data.Maybe (fromMaybe) import Domain.Math.Data.Interval-import Domain.Logic.Formula (Logic((:||:), (:&&:)))+import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic) import Domain.Math.Clipboard import Domain.Math.Data.OrList import Domain.Math.Data.Relation import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)-import Domain.Math.Polynomial.Exercises (eqRelation, normRelation)+import Domain.Math.Polynomial.Exercises (eqRelation, normExpr) import Domain.Math.Equation.Views import Domain.Math.Examples.DWO2 import Domain.Math.Expr@@ -40,17 +41,19 @@ import Domain.Math.SquareRoot.Views import Prelude hiding (repeat) import qualified Domain.Logic.Formula as Logic+import qualified Domain.Logic.Views as Logic  ineqLinearExercise :: Exercise (Relation Expr) ineqLinearExercise = makeExercise -   { description  = "solve a linear inequation"-   , exerciseCode = makeCode "math" "linineq"+   { exerciseId   = describe "solve a linear inequation" $ +                       newId "algebra.inequalities.linear"    , status       = Provisional    , parser       = parseExprWith (pRelation pExpr)    , isReady      = solvedRelation    , equivalence  = linEq-   , similarity   = eqRelation cleanUpExpr2-   , strategy     = mapRules liftToContext ineqLinear+   , similarity   = eqRelation cleanUpExpr+   , strategy     = ineqLinear+   , navigation   = termNavigator    , examples     = let x = Var "x"                         extra = (x-12) / (-2) :>: (x+3)/3                     in map (build inequalityView) (concat ineqLin1 ++ [extra])@@ -58,33 +61,40 @@     ineqQuadraticExercise :: Exercise (Logic (Relation Expr)) ineqQuadraticExercise = makeExercise -   { description   = "solve a quadratic inequation"-   , exerciseCode  = makeCode "math" "quadrineq"+   { exerciseId    = describe "solve a quadratic inequation" $ +                        newId "algebra.inequalities.quadratic"    , status        = Provisional    , parser        = parseExprWith (pLogicRelation pExpr)    , prettyPrinter = showLogicRelation    , isReady       = solvedRelations    , eqWithContext = Just quadrEqContext-   , similarity    = simLogic (normRelation cleanUpExpr2 . flipGT)+   , similarity    = simLogic (fmap (normExpr cleanUpExpr) . flipGT)    , strategy      = ineqQuadratic+   , navigation    = termNavigator+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder    , examples      = map (Logic.Var . build inequalityView)                           (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad])    }  ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr)) ineqHigherDegreeExercise = makeExercise -   { description   = "solve an inequation of higher degree"-   , exerciseCode  = makeCode "math" "ineqhigherdegree"+   { exerciseId    = describe "solve an inequation of higher degree" $ +                        newId "algebra.inequalities.polynomial"    , status        = Provisional    , parser        = parseExprWith (pLogicRelation pExpr)    , prettyPrinter = showLogicRelation    , isReady       = solvedRelations    , eqWithContext = Just highEqContext-   , similarity    = simLogic (normRelation cleanUpExpr2 . flipGT)+   , similarity    = simLogic (fmap (normExpr cleanUpExpr) . flipGT)    , strategy      = ineqHigherDegree+   , navigation    = termNavigator+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder    , examples      = map (Logic.Var . build inequalityView) ineqHigh    } +ineq :: String+ineq = "algebra.inequalities"+ showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String showLogicRelation logic =     case logic of@@ -107,7 +117,7 @@       ineq2 <- match inequalityView r2       let g (a :>=: b) = b :<=: a           g (a :>:  b) = b :<:  a-          g ineq       = ineq+          g e          = e       make (g ineq1) (g ineq2)    f _ = Nothing    @@ -123,34 +133,42 @@       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)+      let g b = if b then (.<=.) else (.<.)+      in Logic.Var (g o1 x y) :&&: Logic.Var (g o2 y z) +ineqLinear :: LabeledStrategy (Context (Relation Expr))+ineqLinear = cleanUpStrategy (applyTop (fmap cleanUpSimple)) ineqLinearG -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)+ineqLinearG :: IsTerm a => LabeledStrategy (Context a)+ineqLinearG = label "Linear inequation" $+   label "Phase 1" (repeat +       (  use removeDivision+      <|> multi (showId distributeTimes) +             (somewhere (useC parentNotNegCheck <*> use distributeTimes))+      <|> multi (showId merge) (once (use merge))+       ))+   <*>  +   label "Phase 2" +       (  try (use varToLeft)+      <*> try coverUpPlus+      <*> try (use flipSign)+      <*> try (use coverUpTimesPositive)+       ) --- helper strategy-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]+-- helper strategy (todo: fix needed, because the original rules do not +-- work on relations)+coverUpPlus :: IsTerm a => Strategy (Context a) +coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps)+ where+   coverUps :: [ConfigCoverUp -> Rule (Relation Expr)]+   coverUps = +      [ coverUpBinaryRule "plus" (commOp . isPlus) (-)+      , coverUpBinaryRule "minus-left" isMinus (+)+      , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))+      ]     coverUpTimesPositive :: Rule (Relation Expr)-coverUpTimesPositive = coverUpBinaryRule "times positive" (commOp . m) (/) varConfig+coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp  where    m expr = do       (a, b) <- matchM timesView expr@@ -159,7 +177,8 @@       return (a, b)        flipSign :: Rule (Relation Expr)-flipSign = makeSimpleRule "flip sign" $ \r -> do+flipSign = describe "Flip sign of inequality" $+   makeSimpleRule (ineq, "flip-sign") $ \r -> do    let lhs = leftHandSide r        rhs = rightHandSide r    guard (isNegative lhs) @@ -170,25 +189,41 @@       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+ineqQuadratic = cleanUpStrategy (applyTop cleanUpLogicRelation) $ +   label "Quadratic inequality" $ +      use trivialRelation+       |> try (useC turnIntoEquation) +      <*> quadraticStrategyG+      <*> useC 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+ineqHigherDegree = cleanUpStrategy (applyTop cleanUpLogicRelation) $+   label "Inequality of a higher degree" $ +      use trivialRelation+       |> try (useC turnIntoEquation) +      <*> higherDegreeStrategyG+      <*> useC solutionInequation -justOneView :: View (OrList a) a-justOneView = makeView (f . disjunctions) return- where-   f (Just [r]) = Just r-   f _          = Nothing+-- First, cleanup expression. Then, cleanup equations only (there is an +-- explicit rule for the other relations). Finally, simplify the logical+-- proposition (including impotency or).+cleanUpLogicRelation :: Logic (Relation Expr) -> Logic (Relation Expr)+cleanUpLogicRelation = +   let f a | relationType a == EqualTo = build orListView (cleanUpRelation a)+           | otherwise                 = Logic.Var a+   in simplifyWith idempotent orListView . Logic.simplify +    . catLogic . fmap (f . fmap cleanUpExpr)+   +trivialRelation :: Rule (OrList (Relation Expr))+trivialRelation =+   makeSimpleRule (ineq, "trivial") $ oneDisjunct $ \a -> do+      let new = cleanUpRelation a+      guard (isTrue new || isFalse new)+      return new  turnIntoEquation :: Rule (Context (Relation Expr))-turnIntoEquation = makeSimpleRule "turn into equation" $ withCM $ \r -> do+turnIntoEquation = describe "Turn into equation" $ +   makeSimpleRule (ineq, "to-equation") $ withCM $ \r -> do    guard (relationType r `elem` ineqTypes)    addToClipboard "ineq" (toExpr r)    return (leftHandSide r .==. rightHandSide r)@@ -198,19 +233,20 @@  -- Todo: cleanup this function solutionInequation :: Rule (Context (Logic (Relation Expr)))-solutionInequation = makeSimpleRule "solution inequation" $ withCM $ \r -> do-   ineq <- lookupClipboard "ineq" >>= fromExpr+solutionInequation = describe "Determine solution for inequality" $ +   makeSimpleRule (ineq, "give-solution") $ withCM $ \r -> do+   inEquation <- lookupClipboard "ineq" >>= fromExpr    removeClipboard "ineq"-   orv  <- maybeCM (matchM orView r)+   orv  <- maybeCM (matchM orListView r)    case disjunctions orv of        Nothing -> -- both sides are the same-         if relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]+         if relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]          then return Logic.T          else return Logic.F       Just [] -> do -- no solutions found for equations-         let vs = collectVars (toExpr ineq)+         let vs = vars (toExpr inEquation)          guard (not (null vs))-         if evalIneq ineq (head vs) 0+         if evalIneq inEquation (head vs) 0             then return Logic.T              else return Logic.F       Just xs -> do@@ -220,9 +256,9 @@          ds <- matchM (listView doubleView) zs          guard (all (==v) vs)          let rs = makeRanges including (sort (zipWith A ds zs))-             including = relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]+             including = relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]          return $ fromIntervals v fromDExpr $ -            fromList [ this | (d, isP, this) <- rs, isP || evalIneq ineq v d ]+            fromList [ this | (d, isP, this) <- rs, isP || evalIneq inEquation v d ]  where    makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)]    makeRanges b xs =@@ -248,9 +284,9 @@           evalIneq :: Relation Expr -> String -> Double -> Bool    evalIneq r v d = fromMaybe False $-      liftM2 (evalType (relationType r)) (use leftHandSide) (use rightHandSide)+      liftM2 (evalType (relationType r)) (useSide leftHandSide) (useSide rightHandSide)     where-      use f = match doubleView (sub (f r))+      useSide f = match doubleView (sub (f r))              evalType tp =          case tp of @@ -263,8 +299,7 @@             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+      sub expr = descend sub expr  data DExpr = A Double Expr
+ src/Domain/Math/Polynomial/LeastCommonMultiple.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)+--+-----------------------------------------------------------------------------+module Domain.Math.Polynomial.LeastCommonMultiple +   ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM +   , powerProductView+   ) where++import Prelude hiding ((^))+import Common.TestSuite+import Common.View+import Control.Monad+import Data.List+import Data.Ratio+import Data.Maybe+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Power.Views+import Test.QuickCheck++-- | Returns the least common multiple of two expressions. +lcmExpr :: Expr -> Expr -> Expr+lcmExpr a b = fromMaybe (a*b) $ do+   (ar, as) <- match powerProductView a+   (br, bs) <- match powerProductView b+   return $ build powerProductView (lcmR ar br, merge as bs)+ where   +   lcmR :: Rational -> Rational -> Rational+   lcmR r1 r2 = +      let f r = numerator r * denominator r+      in fromIntegral (lcm (f r1) (f r2))+   +   merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)]+   merge = foldr op id+    where+      op (e, n1) f ys = +         let n2   = fromMaybe 0 (lookup e ys)+             rest = filter ((/=e) . fst) ys+         in (e, n1 `max` n2) : f rest++-- | Only succeeds if there is no remainder+divisionExpr :: Expr -> Expr -> Maybe Expr+divisionExpr a b = do+   (ar, as) <- match powerProductView a+   (br, bs) <- match powerProductView b+   xs       <- as `without` bs+   return $ build powerProductView (ar/br, xs)+ where+   without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)]+   without [] ys =+      guard (null ys) >> return []+   without ((e,n1):xs) ys = +      let n2   = fromMaybe 0 (lookup e ys)+          rest = filter ((/=e) . fst) ys+      in liftM ((e,n1-n2):) (without xs rest)+      +powerProductView :: View Expr (Rational, [(Expr, Integer)])+powerProductView = makeView f g+ where+   f expr = do+      (b, xs) <- match productView expr+      let (r, ys) = collectPairs xs+      return (if b then -r else r, merge ys)+         +   g (r, xs) =+      build productView (False, fromRational r : map (build pvn) xs)+   +   pvn :: View Expr (Expr, Integer)+   pvn = powerView >>> second integerView++   collectPairs :: [Expr] -> (Rational, [(Expr, Integer)])+   collectPairs = foldr op (1, [])+    where+      op e (r, xs) = +         let mr   = match rationalView e +             h r2 = (r*r2, xs)+             pair = fromMaybe (e,1) (match pvn e)+         in maybe (r, pair:xs) h mr++   merge :: [(Expr, Integer)] -> [(Expr, Integer)]+   merge [] = []+   merge xs@((e, _) : _) = +      let (xs1, xs2) = partition ((==e) . fst) xs+          n = sum (map snd xs1) +      in (e, n) : merge xs2+   +testLCM :: TestSuite+testLCM = suite "lcmExpr" $ do+   addProperty "transitivity" $ f3 $ \a b c -> +      lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c+   addProperty "commutativity" $ f2 $ \a b -> +      lcmExpr a b ~= lcmExpr b a+   addProperty "idempotency" $ f1 $ \a -> +      lcmExpr a a ~= absExpr a+   addProperty "zero" $ f1 $ \a -> +      lcmExpr a 0 ~= 0+   addProperty "one" $ f1 $ \a -> +      lcmExpr a 1 ~= absExpr a+   addProperty "sign" $ f2 $ \a b -> +      lcmExpr a b ~= lcmExpr (-a) b+ where +   f1 g = liftM  g genExpr+   f2 g = liftM2 g genExpr genExpr+   f3 g = liftM3 g genExpr genExpr genExpr+ +   genExpr, genTerm, genAtom :: Gen Expr+   genExpr = do+      n  <- choose (0, 10)+      b  <- arbitrary+      xs <- replicateM n genTerm+      return $ build productView (b, xs)+   +   genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)]+   +   genAtom = do+      v <- oneof $ map (return . Var) ["a", "b", "c"]+      i <- choose (-10, 10)+      n <- choose (0, 10)+      p <- frequency [(3, return v), (1, return (v .+. fromInteger i))]+      frequency [(3, return p), (1, return (p^fromInteger n))]++   (~=)    = equalFactors+   absExpr = simplifyWith (first (const False)) productView++noCommonFactor :: Expr -> Expr -> Bool+noCommonFactor x y = lcmExpr x y `equalFactors` (x*y)+   +equalFactors :: Expr -> Expr -> Bool+equalFactors x y = f x == f y+ where f = simplifyWith (second sort) powerProductView
+ src/Domain/Math/Polynomial/RationalExercises.hs view
@@ -0,0 +1,313 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Domain.Math.Polynomial.RationalExercises +   ( rationalEquationExercise+   , simplifyRationalExercise, divisionRationalExercise+   , eqSimplifyRational+   ) where++import Common.Classes+import Common.Context+import Common.Exercise+import Common.Navigator+import Common.Rewriting+import Common.Strategy hiding (not)+import Common.Uniplate+import Common.Utils (fst3)+import Common.View+import Control.Monad+import Data.List hiding (repeat, replicate)+import Data.Maybe+import Domain.Logic.Formula hiding (disjunctions, Var)+import qualified Domain.Logic as Logic+import qualified Domain.Logic.Views as Logic+import Domain.Logic.Views hiding (simplify)+import Domain.Math.Clipboard+import Domain.Math.Data.OrList+import Domain.Math.Data.Relation+import Domain.Math.Equation.CoverUpRules+import Domain.Math.Equation.Views+import Domain.Math.Examples.DWO4+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.CleanUp+import Domain.Math.Polynomial.Exercises (eqOrList)+import Domain.Math.Polynomial.LeastCommonMultiple+import Domain.Math.Polynomial.RationalRules+import Domain.Math.Polynomial.Rules+import Domain.Math.Polynomial.Strategies+import Domain.Math.Polynomial.Views+import Domain.Math.SquareRoot.Views+import Domain.Math.Power.OldViews+import Prelude hiding (repeat, replicate, until, (^))+import qualified Data.Set as S++rationalEquationExercise :: Exercise (OrList (Equation Expr))+rationalEquationExercise = makeExercise +   { exerciseId    = describe "solve a rational equation (with a variable in a divisor)" $ +                        newId "algebra.equations.rational"+   , status        = Provisional+   , parser        = parseExprWith (pOrList (pEquation pExpr))+   , isSuitable    = isJust . rationalEquations+   , isReady       = solvedRelations+   , eqWithContext = Just eqRationalEquation+   , similarity    = eqOrList cleanUpExpr+   , strategy      = rationalEquationStrategy+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder+   , navigation    = termNavigator+   , examples      = map return (concat brokenEquations)+   }+   +simplifyRationalExercise :: Exercise Expr+simplifyRationalExercise = makeExercise+   { exerciseId    = describe "simplify a rational expression (with a variable in a divisor)" $ +                        newId "algebra.manipulation.rational.simplify"+   , status        = Alpha -- Provisional+   , parser        = parseExpr+-- isSuitable+   , isReady       = simplifiedRational+   -- , eqWithContext = Just eqSimplifyRational+   , similarity    = \x y -> cleanUpExpr x == cleanUpExpr y+   , strategy      = simplifyRationalStrategy+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder+   , navigation    = termNavigator+   , examples      = concat (normBroken ++ normBroken2)+   }+   +divisionRationalExercise :: Exercise Expr+divisionRationalExercise = simplifyRationalExercise+   { exerciseId   = describe "divide a rational expression ('uitdelen')" $ +                       newId "math.divrational"+   , strategy     = label "divide broken fraction" succeed+   , examples     = concat deelUit+   }++rationalEquationStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))+rationalEquationStrategy = cleanUpStrategy (applyTop (fmap (fmap cleaner))) $+   label "Rational equation" $ +       brokenFormToPoly <*> higherDegreeStrategyG <*> checkSolutionStrategy+ where+   -- a custom-made clean-up function. (Standard) cleanUpExpr function +   -- has some strange interaction with the rules+   cleaner = transform (simplify (powerFactorViewWith rationalView)) +           . cleanUpSimple . transform smart+   +   brokenFormToPoly = label "rational form to polynomial" $ until allArePoly $+      (  useC divisionIsZero <|> useC divisionIsOne +     <|> useC sameDivisor <|> useC sameDividend+     <|> use coverUpPlus <|> use coverUpMinusLeft <|> use coverUpMinusRight+     <|> use coverUpNegate+      ) |>    +      (  useC crossMultiply <|> useC multiplyOneDiv  )+   checkSolutionStrategy = label "check solutions" $ +      try (multi (showId checkSolution) (somewhere checkSolution))++allArePoly :: Context (OrList (Equation Expr)) -> Bool+allArePoly = +   let f a = a `belongsTo` polyView+   in maybe False (all f . concatMap crush . crush) .  fromContext++simplifyRationalStrategy :: LabeledStrategy (Context Expr)+simplifyRationalStrategy = cleanUpStrategy (applyTop cleaner) $+   label "Simplify rational expression" $+      phaseOneDiv <*> phaseSimplerDiv+ where+   -- a custom-made clean-up function. (Standard) cleanUpExpr function +   -- has some strange interaction with the rules+   cleaner = transform (simplify (powerFactorViewWith rationalView)) . cleanUpSimple+ +   phaseOneDiv = label "Write as division" $+      until isDivC $ +         use fractionPlus <|> use fractionScale <|> use turnIntoFraction+   phaseSimplerDiv = label "Simplify division" $+      repeat $+         (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv)+            <|> commit (onlyUpperDiv (repeat findFactorsStrategyG) <*> useC cancelTermsDiv))+         |> ( somewhere (use merge) +         <|> multi (showId distributeTimes) (exceptLowerDiv (use distributeTimes))+          )++isDivC :: Context a -> Bool+isDivC = maybe False (isJust . isDivide :: Term -> Bool) . currentT++-- First check that the whole strategy can be executed. Cleaning up is not +-- propagated correctly to predicate in check combinator, hence the use of+-- cleanUpStrategy (which is not desirable here).+commit :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)+commit s = let cs  = cleanUpStrategy (applyTop cleanUpExpr) (label "" s)+               f a = fromMaybe a (do b <- top a; c <- current a; return (change (const c) b))+           in check (applicable cs . f) <*> s++exceptLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)+exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> +   if isDivC a then [1] else [0 .. arity a-1]++onlyUpperDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)+onlyUpperDiv = onceWith "only-upper-div" $ \a -> [ 1 | isDivC a ]+   +onlyLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)+onlyLowerDiv = onceWith "only-lower-div" $ \a -> [ 2 | isDivC a ]+   +simplifiedRational :: Expr -> Bool+simplifiedRational expr =+   case expr of+      Negate a -> simplifiedRational a+      _        -> f expr+ where+   f (a :/: b) = inPolyForm a && noCommonFactor a b && inFactorForm b+   f _ = False++   inPolyForm :: Expr -> Bool+   inPolyForm a =+      a `belongsTo` polyNormalForm identity ||+      S.size (varSet expr) > 1+          +   inFactorForm :: Expr -> Bool+   inFactorForm = flip belongsTo $+      let v = first (polyNormalForm identity >>> second linearPolyView)+      in powerProductView >>> second (listView v)++rationalEquations :: OrList (Equation Expr) -> Maybe (OrList Expr)+rationalEquations = maybe (return true) f . disjunctions+ where +   f xs = do +      yss <- mapM rationalEquation xs+      return (join (orList yss))+ +rationalEquation :: Equation Expr -> Maybe (OrList Expr)+rationalEquation eq = do+   let (lhs :==: rhs) = coverUp eq+       (a, b, c) = rationalExpr (lhs .-. rhs)+   (_, as) <- match productView a+   (_, bs) <- match productView b+   let condition = foldr ((.&&.) . notZero) c bs+   new1    <- match higherDegreeEquationsView $ orList $ map (:==: 0) as+   return (restrictOrList condition new1)++restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr+restrictOrList p0 = maybe true (orList . filter p) . disjunctions+ where+   p zeroExpr = +      case coverUp (zeroExpr :==: 0) of +         Var x :==: a -> -- returns true if a contradiction was not found+            substVar x (cleanUpExpr a) p0 /= F +         _ -> True++   substVar x a = Logic.simplify . catLogic . fmap (simpler . fmap (cleanUpExpr . subst))+    where +      subst (Var s) | x == s = a+      subst expr = descend subst expr+       +   simpler r = fromMaybe (Logic.Var r) $ do+      a <- match (squareRootViewWith rationalView) (leftHandSide r)+      b <- match (squareRootViewWith rationalView) (rightHandSide r)+      case (a==b, relationType r) of+         (True,  EqualTo)    -> return T+         (False, EqualTo)    -> return F +         (True,  NotEqualTo) -> return F+         (False, NotEqualTo) -> return T+         _ -> Nothing++eqRationalEquation :: Context (OrList (Equation Expr)) -> Context (OrList (Equation Expr)) -> Bool+eqRationalEquation ca cb = fromMaybe False $+   liftM2 (==) (solve ca) (solve cb)+ where+   solve ctx = do +      let f = fromMaybe T . conditionOnClipboard+      a  <- fromContext ctx +      xs <- rationalEquations a+      ys <- disjunctions (restrictOrList (f ctx) xs)+      return (sort (nub ys))+   +eqSimplifyRational :: Context Expr -> Context Expr -> Bool+eqSimplifyRational ca cb = fromMaybe False $ do+   a <- fromContext ca+   b <- fromContext cb+   let a1c = cleanUpExpr (fst3 (rationalExpr a))+       b1c = cleanUpExpr (fst3 (rationalExpr b))+       manyVars = S.size (varSet a `S.union` varSet b) > 1+   if manyVars then return True else do+   p1 <- match (polyViewWith rationalView) a1c+   p2 <- match (polyViewWith rationalView) b1c+   return (manyVars || p1==p2)+   +conditionOnClipboard :: Context a -> Maybe (Logic (Relation Expr))+conditionOnClipboard = evalCM $ const $+   lookupClipboardG "condition"++-- write expression as a/b, under certain conditions+rationalExpr :: Expr -> (Expr, Expr, Logic (Relation Expr))+rationalExpr expr =+   case expr of+      a :+: b  -> rationalExpr a `fPlus` rationalExpr b+      a :-: b  -> rationalExpr (a :+: Negate b)+      Negate a -> fNeg (rationalExpr a)+      a :*: b  -> rationalExpr a `fTimes` rationalExpr b+      a :/: b  -> rationalExpr a `fTimes` fRecip (rationalExpr b)+      Sym s [a, b] | isPowerSymbol s -> +         fPower (rationalExpr a) b+      _ -> (expr, 1, T)+ where+   fNeg   (a, b, p)   = (neg a, b, p)+   fRecip (a, b, p)   = (b, a, notZero b .&&. p)+   fPower (a, b, p) n = (a .^. n, b .^. n, p)+   fTimes (a1, a2, p) (b1, b2, q) = (a1 .*. b1, a2 .*. b2, p .&&. q)+   fPlus  (a1, a2, p) (b1, b2, q) =+      case (divisionExpr c2 a2, divisionExpr c2 b2) of +         (Just a3, Just b3) +            | a1 == b1     -> (a1 .*. (a3 .+. b3), c2, pq)+            | a1 == neg b1 -> (a1 .*. (a3 .-. b3), c2, pq)+            | otherwise    -> (a1 .*. a3 .+. b1 .*. b3, c2, pq)+         _ -> (a1 .*. b2 .+. b1 .*. a2, a2 .*. b2, pq)+    where+      c2 = lcmExpr a2 b2+      pq = p .&&. q++notZero :: Expr -> Logic (Relation Expr)+notZero expr =+   case match rationalView expr of+      Just r | r /= 0    -> T+             | otherwise -> F+      _ -> Logic.Var (expr ./=. 0)++-----------------+-- test code++{-+raar = brokenExpr $ x^2/(5*x+6) + 1+ where x = Var "x"+-+go0 = checkExercise rationalEquationExercise++go = checkExercise simplifyRationalExercise++see n = printDerivation ex (examples ex !! (n-1))+ where ex = --rationalEquationExercise  +            simplifyRationalExercise+      +go4 = printDerivation findFactorsExercise $ -a + 4+ where x = Var "x"+       a = Var "a"+       +test = e4+ where +   a  = Var "a"+   b  = Var "b"+   +   e1 = 6*a*b*a+   e2 = -4*b^2*a*2+   e3 = lcmExpr e1 e2+   e4 = divisionExpr e3 e1+   e5 = divisionExpr e3 e2+   +go = putStrLn $ unlines $ map show $ zip [1..] $ map (brokenEq []) (concat brokenEquations)+-}
+ src/Domain/Math/Polynomial/RationalRules.hs view
@@ -0,0 +1,186 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Domain.Math.Polynomial.RationalRules +   ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend+   , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv+   , fractionScale, turnIntoFraction, checkSolution+   ) where++import Common.Context+import Common.Id+import Common.Transformation+import Common.View+import Control.Monad+import Data.Maybe+import Domain.Logic.Formula hiding (disjunctions, Var)+import Domain.Logic.Views+import Domain.Math.Clipboard+import Domain.Math.Data.OrList+import Domain.Math.Data.Relation+import Domain.Math.Equation.CoverUpRules+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.CleanUp+import Domain.Math.Polynomial.LeastCommonMultiple+import Domain.Math.Polynomial.Views+import Domain.Math.Power.Views+import qualified Domain.Logic.Formula as Logic++ratId :: Id+ratId = newId "algebra.equations.rational"++---------------------------------------------------------------+-- Rules for rational expressions and rational equations++-- a/b = 0  iff  a=0 (and b/=0)+divisionIsZero :: Rule (Context (Equation Expr))+divisionIsZero = makeSimpleRule (ratId, "division-zero") $ withCM $ \(lhs :==: rhs) -> do+   guard (rhs == 0)+   (a, b) <- matchM divView lhs+   conditionNotZero b+   return (a :==: 0)+   +-- a/b = 1  iff  a=b (and b/=0)+divisionIsOne :: Rule (Context (Equation Expr))+divisionIsOne = makeSimpleRule (ratId, "division-one") $ withCM $ \(lhs :==: rhs) -> do+   guard (rhs == 1)+   (a, b) <- matchM divView lhs+   conditionNotZero b+   return (a :==: b)++-- a/c = b/c  iff  a=b (and c/=0)+sameDivisor :: Rule (Context (Equation Expr))+sameDivisor = makeSimpleRule (ratId, "same-divisor") $ withCM $ \(lhs :==: rhs) -> do+   (a, c1) <- matchM divView lhs+   (b, c2) <- matchM divView rhs+   guard (c1==c2)+   conditionNotZero c1+   return (a :==: b)+   +-- a/b = a/c  iff  a=0 or b=c (and b/=0 and c/=0)+sameDividend :: Rule (Context (OrList (Equation Expr)))+sameDividend = makeSimpleRule (ratId, "same-dividend") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do+   (a1, b) <- matchM divView lhs+   (a2, c) <- matchM divView rhs+   guard (a1==a2)+   conditionNotZero b+   conditionNotZero c+   return $ orList [a1 :==: 0, b :==: c]+   +-- a/b = c/d  iff  a*d = b*c   (and b/=0 and d/=0)+crossMultiply :: Rule (Context (Equation Expr))+crossMultiply = makeSimpleRule (ratId, "cross-multiply") $ withCM $ \(lhs :==: rhs) -> do+   (a, b) <- matchM divView lhs+   (c, d) <- matchM divView rhs+   conditionNotZero b+   conditionNotZero d+   return (a*d :==: b*c)+   +-- a/b = c  iff  a = b*c  (and b/=0)+multiplyOneDiv :: Rule (Context (Equation Expr))+multiplyOneDiv = makeSimpleRule (ratId, "multiply-one-div") $ withCM $ \(lhs :==: rhs) -> +   f (:==:) lhs rhs `mplus` f (flip (:==:)) rhs lhs+ where+   f eq ab c = do +      guard (not (c `belongsTo` divView))+      (a, b) <- matchM divView ab+      conditionNotZero b+      return (a `eq` (b*c))+      +-- a/c + b/c = a+b/c   (also see Numeric.Rules)+fractionPlus :: Rule Expr -- also minus+fractionPlus = makeSimpleRule (ratId, "rational-plus") $ \expr -> do+   ((a, b), (c, d)) <- match myView expr+   guard (b == d)+   return (build divView (a+c, b))+ where+   myView = plusView >>> (divView *** divView)++-- ab/ac  =>  b/c  (if a/=0)+-- Note that the common term can be squared (in one of the parts)+cancelTermsDiv :: Rule (Context Expr)+cancelTermsDiv = makeSimpleRule (ratId, "cancel-div") $ withCM $ \expr -> do+   ((b, xs), (c, ys)) <- matchM myView expr+   let (ps, qs, rs) = rec (map f xs) (map f ys)+   guard (not (null rs))+   conditionNotZero (build productView (False, map g rs))+   return $ build myView ((b, map g ps), (c, map g qs))+ where+   myView = divView >>> (productView *** productView)+   powInt = powerView >>> second integerView+   f a = fromMaybe (a, 1) (match powInt a)+   g   = build powInt+   rec ((_, 0):xs) ys = rec xs ys+   rec (pair@(a, n):xs) ys =+      case break ((==a) . fst) ys of+         (ys1, (b, m):ys2)+            | m == 0 ->+                 rec (pair:xs) (ys1++ys2)+            | otherwise ->+                 let i = n `min` m +                     (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2)+                 in (ps, qs, (a,i):rs)+         _ -> +            let (ps,qs,rs) = rec xs ys +            in (pair:ps, qs,rs)+   rec xs ys = (xs, ys, [])++fractionScale :: Rule Expr+fractionScale = liftRule myView $ +   makeSimpleRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do+      guard (e1 /= e2)+      let e3 = lcmExpr e1 e2+      ma <- divisionExpr e3 e1+      mb <- divisionExpr e3 e2+      guard (ma /= 1 || mb /= 1)+      return ((ma*a, e3), (mb*b, e3))+ where+   myView = plusView >>> (divView *** divView)+   +turnIntoFraction :: Rule Expr+turnIntoFraction = liftRule plusView $+   makeSimpleRule (ratId, "to-rational") $ \(a, b) ->+      liftM (\c -> (c, b)) (f a b) `mplus` +      liftM (\c -> (a, c)) (f b a)+ where+   f a b = do+      guard (not (a `belongsTo` divView))+      (_, e) <- match divView b+      return $ build divView (a*e, e)++-- A simple implementation that considers the condition stored in the context+checkSolution :: Rule (Context (OrList (Equation Expr)))+checkSolution = makeSimpleRule (ratId, "check-solution") $ +   withCM $ oneDisjunct $ \(x :==: a) -> do+      c  <- lookupClipboardG "condition"+      xs <- matchM andView c+      guard ((x ./=. a) `elem` xs)+      return false++---------------------------------------------------------------+-- Helper-code+   +condition :: Logic (Relation Expr) -> ContextMonad ()+condition c = do+   mp <- maybeOnClipboardG "condition"+   let a = maybe id (.&&.) mp c+   unless (a==T) (addToClipboardG "condition" a)++conditionNotZero :: Expr -> ContextMonad ()+conditionNotZero expr = condition (f xs)+ where+   f  = pushNotWith (Logic.Var . notRelation) . nott+   eq = expr :==: 0+   xs = fmap (build equationView . fmap cleanUpExpr) $ +        case match higherDegreeEquationsView (return eq) of+           Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys))+           Nothing -> Logic.Var (coverUp eq)
src/Domain/Math/Polynomial/Rules.hs view
@@ -9,92 +9,95 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Domain.Math.Polynomial.Rules where+module Domain.Math.Polynomial.Rules +   ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms+   , commonFactorVar, commonFactorVarNew, defPowerNat, distributeDivision+   , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare+   , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero+   , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar+   , parentNotNegCheck, prepareSplitSquare, quadraticRuleOrder, removeDivision+   , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational+   , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRoot+   , squareBothSides, substBackVar, varToLeft+   ) where -import Common.Apply-import Common.Context-import Common.Rewriting-import Common.Transformation-import Common.Traversable-import Common.Uniplate (universe, uniplate)+import Common.Library hiding (terms, simplify)+import Common.Uniplate (universe, descend) import Common.Utils-import Common.View hiding (simplify) import Control.Monad-import Data.List (nub, (\\), sort, sortBy)+import Data.List import Data.Maybe+import Data.Ord import Data.Ratio import Domain.Math.Approximation (precision) import Domain.Math.Clipboard import Domain.Math.Data.OrList+import Domain.Math.Data.Polynomial import Domain.Math.Data.Relation-import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)+import Domain.Math.Equation.BalanceRules+import Domain.Math.Equation.CoverUpRules import Domain.Math.Expr import Domain.Math.Numeric.Views import Domain.Math.Polynomial.CleanUp import Domain.Math.Polynomial.Views-import Domain.Math.Power.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 Domain.Math.Power.OldViews+import Domain.Math.Simplification hiding (simplifyWith)+import Domain.Math.SquareRoot.Views +import Prelude hiding ( (^) ) ---------------------------------------------------------------- Rule collection+quadraticRuleOrder :: [Id]+quadraticRuleOrder = +   [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar)+   , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar)+   , getId coverUpPower+   , getId commonFactorVar, getId simplerPolynomial+   , getId niceFactors, getId noLinFormula+   , getId cancelTerms, getId sameConFactor, getId distributionSquare+   , getId allPowerFactors+   ] -linearRules :: [Rule (Context (Equation Expr))]-linearRules = map liftToContext $-   [ removeDivision, ruleMulti merge, ruleMulti distributeTimesSomewhere-   , varToLeft, coverUpNegate, coverUpTimes-   ] ++-   map ($ oneVar) -   [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith]+lineq, quadreq, polyeq :: String+lineq   = "algebra.equations.linear"+quadreq = "algebra.equations.quadratic"+polyeq  = "algebra.equations.polynomial"  -quadraticRules :: [Rule (OrList (Equation Expr))]-quadraticRules = -- abcFormula-   [ ruleOnce commonFactorVar, ruleOnce noLinFormula, ruleOnce niceFactors-   , 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 distributeTimesSomewhere-   , ruleOnce2 (ruleSomewhere distributionSquare), ruleOnce flipEquation -   , ruleOnce moveToLeft, ruleMulti2 (ruleSomewhere simplerSquareRoot)-   ]-   -higherDegreeRules :: [Rule (OrList (Equation Expr))]-higherDegreeRules = -   [ allPowerFactors, sameFactor-   ] ++ quadraticRules- ------------------------------------------------------------ -- General form rules: ax^2 + bx + c = 0 +quadraticNF :: View Expr (String, (Rational, Rational, Rational))+quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView+ -- ax^2 + bx = 0  commonFactorVar :: Rule (Equation Expr)  commonFactorVar = rhsIsZero commonFactorVarNew +-- Maybe to be replaced by more general factorVariablePower?? commonFactorVarNew :: Rule Expr-commonFactorVarNew = 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 = (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)))+commonFactorVarNew = describe "Common factor variable" $ +   makeSimpleRule (quadreq, "common-factor") $ \expr -> do+      (x, (a, b, c)) <- match quadraticNF expr+      guard (b /= 0 && c == 0)+      -- also search for constant factor+      let d | a<0 && b<0 = -gcdFrac a b+            | otherwise  = gcdFrac a b+      return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) +gcdFrac :: Rational -> Rational -> Rational+gcdFrac r1 r2 = +   if denominator r1 == 1 && denominator r2 == 1+   then fromInteger (numerator r1 `gcd` numerator r2)+   else 1  -- ax^2 + c = 0 noLinFormula :: Rule (Equation Expr)-noLinFormula = makeSimpleRule "no linear term b" $ \(lhs :==: rhs) -> do-   guard (rhs == 0)-   (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs-   guard (b == 0 && c /= 0)-   return $ -      if a>0 then fromRational a .*. (Var x .^. 2) :==: fromRational (-c)-             else fromRational (-a) .*. (Var x .^. 2) :==: fromRational c+noLinFormula = describe "No linear term ('b=0')" $ liftRule myView $ +   makeSimpleRule (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do+      guard (rhs == 0 && b == 0 && c /= 0)+      return $ if a>0 then ((x, (a, 0, 0)), -c)+                      else ((x, (-a, 0, 0)), c)+ where+   myView = constantRight quadraticNF  -- search for (X+A)*(X+B) decomposition  niceFactors :: Rule (Equation Expr)@@ -102,12 +105,11 @@  -- search for (X+A)*(X+B) decomposition  niceFactorsNew :: Rule Expr-niceFactorsNew = makeSimpleRuleList "nice factors" $ \expr -> do+niceFactorsNew = describe "Find a nice decomposition" $ +   makeSimpleRuleList (quadreq, "nice-factors") $ \expr -> do    let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t -   (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) expr)+   (x, (a, b, c)) <- liftM sign (matchM (polyNormalForm integerView >>> 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@@ -115,67 +117,62 @@           | otherwise =               (Var x + fromInteger i) * (Var x + fromInteger j)    map f (filter ok (factors c))--rhsIsZero :: Rule Expr -> Rule (Equation Expr)-rhsIsZero r = makeSimpleRuleList (name r) $ \(lhs :==: rhs) -> do-   guard (rhs == 0)-   a <- applyAll r lhs-   return (a :==: rhs)+ where+   factors :: Integer -> [(Integer, Integer)]+   factors n = [ pair+               | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n)))+               , a <- [1..h], let b = n `div` a, a*b == n +               , pair <- [(a, b), (negate a, negate b)] +               ]  -- Simplify polynomial by multiplying (or dividing) the terms: -- 1) If a,b,c are ints, then find gcd -- 2) If any of a,b,c is a fraction, find lcm of denominators -- 3) If a<0, then also suggest to change sign (return two solutions)-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 thisView (x, (a*d, b*d, c*d)) :==: 0)+simplerPolynomial :: Rule (Equation Expr)+simplerPolynomial = describe "simpler polynomial" $+   rhsIsZero $ liftRuleIn thisView $ +   makeSimpleRuleList (quadreq, "simpler-poly") $ \(a, b, c) -> do+      r <- findFactor (filter (/=0) [a, b, c])+      d <- if a >= 0 then [r] else [-r, r]+      guard (d `notElem` [0, 1])+      return (a*d, b*d, c*d)  where-   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-+   thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView+  -- Simplified variant of simplerPoly: just bring a to 1. -- Needed for quadratic strategy without square formula bringAToOne :: Rule (Equation Expr)-bringAToOne = makeSimpleRule "bring a to one" $ \(lhs :==: rhs) -> do-   guard (rhs == 0)-   let thisView = polyNormalForm rationalView >>> second quadraticPolyView-   (x, (a, b, c)) <- matchM thisView lhs+bringAToOne = rhsIsZero $ liftRuleIn thisView $ +   describe "Bring 'a' to one" $ +   makeSimpleRule (quadreq, "scale") $ \(a, b, c) -> do    guard (a `notElem` [0, 1])-   return (build thisView (x, (1, b/a, c/a)) :==: 0)+   return (1, b/a, c/a)+ where+   thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView  ------------------------------------------------------------ -- General form rules: expr = 0  -- Rule must be symmetric in side of equation mulZero :: Rule (OrList (Equation Expr))-mulZero = makeSimpleRuleList "multiplication is zero" $ onceJoinM bothSides+mulZero = describe "multiplication is zero" $ +   makeSimpleRuleList (quadreq, "product-zero") $ oneDisjunct bothSides  where    bothSides eq = oneSide eq `mplus` oneSide (flipSides eq)    oneSide (lhs :==: rhs) = do       guard (rhs == 0)       (_, xs) <- matchM productView lhs       guard (length xs > 1)-      let f e = case match (polyNormalForm rationalView >>> second linearPolyView) e of-                   -- special cases (simplify immediately, as in G&R)-                   Just (x, (a, b)) -                      | a == 1 -> -                           Var x :==: fromRational (-b)-                      | a == -1 -> -                           Var x :==: fromRational b-                   _ -> e :==: 0 -      return $ orList $ map f xs +      return $ orList $ flip map xs $ \e ->+         case match (polyNormalForm rationalView >>> second linearPolyView) e of+            -- special cases (simplify immediately, as in G&R)+            Just (x, (a, b)) +               | a == 1 -> +                    Var x :==: fromRational (-b)+               | a == -1 -> +                    Var x :==: fromRational b+            _ -> e :==: 0   ------------------------------------------------------------ -- Constant form rules: expr = constant@@ -184,39 +181,40 @@ -- Prevent    (x^2+3x)+5 = 0   to be covered up oneVar :: ConfigCoverUp oneVar = configCoverUp-   { configName        = Just "one var"+   { configName        = "onevar"    , predicateCovered  = \a -> p1 a || p2 a-   , predicateCombined = noVars+   , predicateCombined = hasNoVar    , coverLHS          = True    , coverRHS          = True    }  where -   p1 = (==1) . length . collectVars+   p1 = (==1) . length . vars    -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56    p2 a = fromMaybe False $ do       (x, y) <- match timesView a-      return (hasVars x /= hasVars y)+      return (hasSomeVar x /= hasSomeVar y)  ------------------------------------------------------------ -- Top form rules: expr1 = expr2  -- Do not simplify (5+sqrt 53)/2 simplerSquareRoot :: Rule Expr-simplerSquareRoot = makeSimpleRule "simpler square root" $ \e -> do-   xs <- f e-   guard (not (null xs))-   new <- canonical (SQ.squareRootViewWith rationalView) e-   ys <- f new-   guard (xs /= ys)-   return new+simplerSquareRoot = describe "simpler square root" $ +   makeSimpleRule (quadreq, "simpler-sqrt") $ \e -> do+      xs <- f e+      guard (not (null xs))+      new <- canonical (squareRootViewWith rationalView) e+      ys <- f new+      guard (xs /= ys)+      return new  where    -- return numbers under sqrt symbol    f :: Expr -> Maybe [Rational]-   f e = liftM sort $ sequence [ match rationalView e | Sqrt e <- universe e ]- +   f e = liftM sort $ sequence [ match rationalView a | Sqrt a <- universe e ]  cancelTerms :: Rule (Equation Expr)-cancelTerms = makeSimpleRule "cancel terms" $ \(lhs :==: rhs) -> do+cancelTerms = describe "Cancel terms" $ +   makeSimpleRule (quadreq, "cancel") $ \(lhs :==: rhs) -> do    xs <- match sumView lhs    ys <- match sumView rhs    let zs = filter (`elem` ys) (nub xs)@@ -226,148 +224,146 @@  -- Two out of three "merkwaardige producten" distributionSquare :: Rule Expr-distributionSquare = makeSimpleRule "distribution square" f- where-   f (Sym s [a :+: b, Nat 2]) | s == powerSymbol =-      return ((a .^. 2) .+. (2 .*. a .*. b) + (b .^. 2))-   f (Sym s [a :-: b, Nat 2]) | s == powerSymbol =-      return ((a .^. 2) .-. (2 .*. a .*. b) + (b .^. 2))-   f _ = Nothing+distributionSquare = describe "distribution square" $+   ruleList (quadreq, "distr-square")+      [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2+      , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2+      ]  -- a^2 == b^2 squareBothSides :: Rule (OrList (Equation Expr))-squareBothSides = makeSimpleRule "square both sides" $ onceJoinM f - where-   f (Sym s1 [a, Nat 2] :==: Sym s2 [b, Nat 2]) | all (==powerSymbol) [s1, s2] = -      return $ orList [a :==: b, a :==: -b]-   f _ = Nothing+squareBothSides = describe "square both sides" $ +   rule (quadreq, "square-both") $ \a b -> +   orList [a^2 :==: b^2] :~> orList [a :==: b, a :==: -b]  -- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c prepareSplitSquare :: Rule (Equation Expr)-prepareSplitSquare = 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)+prepareSplitSquare = describe "prepare split square" $ +   liftRule myView $+   makeSimpleRule (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do+      let newC   = (b/2)*(b/2)+          newRHS = r + newC - c+      guard (a==1 && b/=0 && c /= newC)+      return ((x, (a, b, newC)), newRHS)+ where+   myView = constantRight quadraticNF  -- factor left-hand side into (ax + c)^2 factorLeftAsSquare :: Rule (Equation Expr)-factorLeftAsSquare = 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) +factorLeftAsSquare = describe "factor left as square" $+   makeSimpleRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do+      guard (hasNoVar rhs)+      (x, (a, b, c)) <- match quadraticNF lhs+      let h = b/2+      guard (a==1 && b/=0 && h*h == c)+      return ((Var x + build rationalView h)^2 :==: rhs)   -- flip the two sides of an equation flipEquation :: Rule (Equation Expr) flipEquation = doBeforeTrans condition $-   rule "flip equation" $ \a b ->+   describe "flip equation" $+   rule (lineq, "flip") $ \a b ->       (a :==: b) :~> (b :==: a)  where    condition = makeTrans $ \eq@(lhs :==: rhs) -> do-      guard (hasVars rhs && noVars lhs)+      guard (hasSomeVar rhs && hasNoVar lhs)       return eq  -- Afterwards, merge and sort moveToLeft :: Rule (Equation Expr)-moveToLeft = makeSimpleRule "move to left" $ \(lhs :==: rhs) -> do-   guard (rhs /= 0)-   let complex = case fmap (filter hasVars) $ match sumView (applyD merge lhs) of-                    Just xs | length xs >= 2 -> True-                    _ -> False-   guard (hasVars lhs && (hasVars rhs || complex))-   let new = applyD mergeT $ applyD sortT $ lhs - rhs-   return (new :==: 0)+moveToLeft = describe "Move to left" $+   makeSimpleRule (quadreq, "move-left") $ \(lhs :==: rhs) -> do+      guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs))+      return (collectLikeTerms (sorted (lhs - rhs)) :==: 0)+ where+   isComplex = maybe False ((>= 2) . length . filter hasSomeVar) +             . match sumView . applyD merge+ +   -- high exponents first, non power-factor terms at the end+   sorted = simplifyWith (sortBy (comparing toPF)) sumView+   toPF   = fmap (negate . thd3) . match powerFactorView  ruleApproximate :: Rule (Relation Expr)-ruleApproximate = 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)+ruleApproximate = describe "Approximate irrational number" $+   makeSimpleRule (quadreq, "approx") $ \relation -> do+      lhs :==: rhs <- match equationView relation+      guard (not (simplify rhs `belongsTo` rationalView))+      x <- getVariable lhs+      d <- match doubleView rhs+      let new = fromDouble (precision 4 d)+      return (Var x .~=. new)  ruleNormalizeRational :: Rule Expr-ruleNormalizeRational = -   ruleFromView "normalize rational number" rationalView+ruleNormalizeRational =+   describe "normalize rational number" $ +   ruleFromView (lineq, "norm-rational") 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--factors :: Integer -> [(Integer, Integer)]-factors n = concat [ [(a, b), (negate a, negate b)] | a <- [1..h], let b = n `div` a, a*b == n ]- where h = floor (sqrt (abs (fromIntegral n)))--isInt :: MonadPlus m => Rational -> m Integer-isInt r = do-   guard (denominator r == 1)-   return (numerator r)--gcdFrac :: Rational -> Rational -> Rational-gcdFrac r1 r2 = fromMaybe 1 $ do -   a <- isInt r1-   b <- isInt r2-   return (fromInteger (gcd a b))+   describe "normalize mixed fraction" $+   ruleFromView (lineq, "norm-mixed") mixedFractionView  ----------------------------------------------------------- -------- Rules From HDE  -- X*A + X*B = X*C + X*D+-- New implementation, but slightly different than original+-- This one does not factor constants+ allPowerFactors :: Rule (OrList (Equation Expr))-allPowerFactors = makeSimpleRule "all power factors" $ onceJoinM $ \(lhs :==: rhs) -> do-   xs <- match (sumView >>> listView powerFactorView) lhs-   ys <- match (sumView >>> listView powerFactorView) rhs-   case unzip3 (filter ((/=0) . snd3) (xs ++ ys)) of-      (s:ss, _, ns) | all (==s) ss -> do-         let m = minimum ns -             make = build (sumView >>> listView powerFactorView) . map f-             f (s, i, n) = (s, i, n-m)-         guard (m > 0 && length ns > 1)-         return $ orList [Var s :==: 0, make xs :==: make ys]-      _ -> Nothing+allPowerFactors = describe "all power factors" $+   makeSimpleRule (polyeq, "power-factors") $ oneDisjunct $ +   \(lhs :==: rhs) -> do+      let myView = polyNormalForm rationalView+      (s1, p1) <- match myView lhs+      (s2, p2) <- match myView rhs+      let n | p1 == 0   = lowestDegree p2+            | p2 == 0   = lowestDegree p1 +            | otherwise = lowestDegree p1 `min` lowestDegree p2+          ts  = terms p1 ++ terms p2+          f p = build myView (s1, raise (-n) p)+      guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1)+      return $ orList [Var s1 :==: 0, f p1 :==: f p2]  +factorVariablePower :: Rule Expr+factorVariablePower = describe "factor variable power" $ +   makeSimpleRule (polyeq, "factor-varpower") $ \expr -> do+   let myView = polyNormalForm rationalView+   (s, p) <- match (polyNormalForm rationalView) expr+   let n = lowestDegree p+   guard (n > 0 && length (terms p) > 1)+   return $ Var s .^. fromIntegral n * build myView (s, raise (-n) p)+ -- A*B = A*C  implies  A=0 or B=C sameFactor :: Rule (OrList (Equation Expr))-sameFactor = makeSimpleRule "same factor" $ onceJoinM $ \(lhs :==: rhs) -> do-   (b1, xs) <- match productView lhs-   (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]) ]+sameFactor = describe "same factor" $ +   makeSimpleRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do+      (b1, xs) <- match productView lhs+      (b2, ys) <- match productView rhs+      (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong?+      return $ orList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ]  -- N*(A+B) = N*C + N*D   recognize a constant factor on both sides -- Example: 3(x^2+1/2) = 6+6x sameConFactor :: Rule (Equation Expr)-sameConFactor = 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)+sameConFactor = +   describe "same constant factor" $+   liftRule myView $ +   makeSimpleRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do+      let (bs, zs) = unzip (ps1 ++ ps2)+          (rs, es) = unzip (map (f 1 []) zs)+          f r acc []     = (r, reverse acc)+          f r acc (x:xs) = case match rationalView x of+                              Just r2 -> f (r*r2) acc xs+                              Nothing -> f r (x:acc) xs+      c <- whichCon rs+      guard (c /= 1)+      let make b r e          = (b, fromRational (r/c):e)+          (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es)+      return (newLeft :==: newRight)  where+   myView = bothSidesView (sumView >>> listView productView)+     whichCon :: [Rational] -> Maybe Rational    whichCon xs        | all (\x -> denominator x == 1 && x /= 0) xs =@@ -375,9 +371,10 @@       | otherwise = Nothing  abcFormula :: Rule (Context (OrList (Equation Expr)))-abcFormula = makeSimpleRule "abc formula" $ withCM $ onceJoinM $ \(lhs :==: rhs) -> do+abcFormula = describe "quadratic formula (abc formule)" $ +   makeSimpleRule (quadreq, "abc") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do    guard (rhs == 0)-   (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs+   (x, (a, b, c)) <- matchM quadraticNF lhs    addListToClipboard ["a", "b", "c"] (map fromRational [a, b, c])    let discr = b*b - 4 * a * c        sqD   = sqrt (fromRational discr)@@ -392,7 +389,8 @@          ]  higherSubst :: Rule (Context (Equation Expr))-higherSubst = makeSimpleRule "higher subst" $ withCM $ \(lhs :==: rhs) -> do+higherSubst = describe "Substitute variable" $+   makeSimpleRule (polyeq, "subst") $ withCM $ \(lhs :==: rhs) -> do    guard (rhs == 0)    let myView = polyView >>> second trinomialPolyView    (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs@@ -401,26 +399,26 @@    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+substBackVar :: Rule (Context Expr)+substBackVar = describe "Substitute back a variable" $ +   makeSimpleRule (polyeq, "back-subst") $ withCM $ \a -> do    expr <- lookupClipboard "subst"    case fromExpr expr of       Just (Var p :==: rhs) -> do-         guard (p `elem` concatMap collectVars (concatMap crush (crush a)))-         return (fmap (fmap (subst p rhs)) a)+         guard (hasVar p a)+         return (subst p rhs a)       _ -> fail "no subst in clipboard"  where    subst a b (Var c) | a==c = b-   subst a b expr = build (map (subst a b) cs)-    where (cs, build) = uniplate expr+   subst a b expr = descend (subst a b) 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))+exposeSameFactor = describe "expose same factor" $ +   liftRule (bothSidesView productView) $ +   makeSimpleRuleList (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do +      (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] +++                  [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ]+      return ((bx, nx) :==: (by, ny))  where    suitable p = fromMaybe False $ do        (_, _, b) <- match (linearViewWith rationalView) p@@ -433,32 +431,22 @@    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+      guard (s1==s2 && p1/=p2)+      case division p2 p1 of          Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3]          Nothing -> []  --------------------------------------------------------- -- From LinearEquations ----------------------------------------------------------- Transformations--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 :: 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 $ \eq -> do-   r <- match rationalView e-   guard (r /= 0)-   return $ fmap (applyD mergeT . applyD distributionOldT . (./. e)) eq+-- Only used for cleaning up+distributeAll :: Expr -> Expr+distributeAll expr = +   case expr of +      e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1)+                       bs = fromMaybe [e2] (match sumView e2)+                   in build sumView [ a .*. b | a <- as, b <- bs ]+      _ -> expr  -- This rule should consider the associativity of multiplication -- Combine bottom-up, for example:  5*(x-5)*(x+5) @@ -482,89 +470,123 @@    rec _        = []        g :: Expr -> Expr -> [Expr]-   g a b = do -      as <- matchM sumView a-      bs <- matchM sumView b+   g e1 e2 = do +      as <- matchM sumView e1 +      bs <- matchM sumView e2       guard (length as > 1 || length bs > 1)       return $ build sumView [ a .*. b | a <- as, b <- bs ] -mergeT :: Transformation Expr-mergeT = makeTrans $ return . collectLikeTerms---- high exponents first, non power-factor terms at the end-sortT :: Transformation Expr-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-    ------------------------------------------------------- -- Rewrite Rules -varToLeft :: Relational f => Rule (f Expr)-varToLeft = makeRule "variable to left" $ flip supply1 minusT $ \eq -> do-   (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq)-   guard (a/=0)-   return (fromRational a * Var x)+varToLeft :: Rule (Relation Expr)+varToLeft = doAfter (fmap collectLikeTerms) $ +   describe "variable to left" $ +   makeRule (lineq, "var-left") $ flip supply1 minusT $ \eq -> do+      (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq)+      guard (a/=0)+      return (fromRational a * Var x)  -- factor is always positive due to lcm function-removeDivision :: 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-   -- (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-      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)+removeDivision :: Rule (Relation Expr)+removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $+   describe "remove division" $ +   makeRule (lineq, "remove-div") $ flip supply1 timesT $ \eq -> do+      xs <- match sumView (leftHandSide eq)+      ys <- match sumView (rightHandSide eq)+      -- also consider parts without variables+      -- (but at least one participant should have a variable)+      zs <- forM (xs ++ ys) $ \a -> do+               (_, list) <- match productView a+               return [ (hasSomeVar a, e) | e <- list ]+      let f (b, e) = do +             (_, this) <- match (divView >>> second integerView) e+             return (b, this)+      case mapMaybe f (concat zs) of+         [] -> Nothing+         ps -> let (bs, ns) = unzip ps+               in if or bs then return (fromInteger (foldr1 lcm ns))+                           else Nothing  distributeTimes :: Rule Expr-distributeTimes = makeSimpleRuleList "distribution multiplication" $ \expr -> do-   new <- applyAll distributionT expr-   return (applyD mergeT new)+distributeTimes = describe "distribution multiplication" $ +   makeSimpleRuleList (lineq, "distr-times") $+      liftM collectLikeTerms . applyAll distributionT  distributeDivision :: Rule Expr-distributeDivision = makeSimpleRule "distribution division" $ \expr -> do-   (a, b) <- match divView expr-   r      <- match rationalView b-   xs     <- match sumView a-   guard (length xs > 1)-   let ys = map (/fromRational r) xs-   return $ build sumView ys+distributeDivision = describe "distribution division" $+   makeSimpleRule (quadreq, "distr-div") $ \expr -> do+      (xs, r) <- match (divView >>> (sumView *** rationalView)) expr+      guard (length xs > 1)+      let ys = map (/fromRational r) xs+      return $ build sumView ys  merge :: Rule Expr-merge = makeSimpleRule "merge similar terms" $ \old -> do-   new <- apply mergeT old-   guard (old /= new)-   return new+merge = describe "merge similar terms" $ +   makeSimpleRule (lineq, "merge") $ \old -> do+      let new = collectLikeTerms old+          f = maybe 0 length . match sumView+      guard (f old > f new)+      return new++simplerLinearFactor :: Rule Expr+simplerLinearFactor = describe "simpler linear factor" $ +   makeSimpleRule (polyeq, "simpler-linfactor") $ \expr -> do+   let myView = polyNormalForm rationalView >>> second linearPolyView+   (x, (a, b)) <- match myView expr+   let d = (if a<0 then negate else id) (gcdFrac a b)+   guard (a /= 0 && b /= 0 && d /= 1 && d /= -1)+   return $ fromRational d * build myView (x, (a/d, b/d))    ---------------------------- Old+ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a+ruleFromView s v = makeSimpleRuleList s $ \a -> do+   b <- canonicalM v a+   guard (a /= b)+   return b+   +rhsIsZero :: Rule Expr -> Rule (Equation Expr)+rhsIsZero r = makeSimpleRuleList (showId r) $ \(lhs :==: rhs) -> do+   guard (rhs == 0)+   a <- applyAll r lhs+   return (a :==: rhs)+   +constantRight :: View Expr a -> View (Equation Expr) (a, Rational)+constantRight v = makeView f g+ where+   f (lhs :==: rhs) = liftM2 (,) (match v lhs) (match rationalView rhs)+   g (a, r) = build v a :==: build rationalView r --- Temporary fix: here we don't care about the terms we apply it to. Only--- use for cleaning up-distributionOldT :: Transformation Expr-distributionOldT = makeTrans f +bothSidesView :: View a b -> View (Equation a) (Equation b)+bothSidesView v = makeView f (fmap (build v))  where-   f (a :*: b) =-      case (match sumView a, match sumView b) of-         (Just as, Just bs) | length as > 1 || length bs > 1 -> -            return $ build sumView [ a .*. b | a <- as, b <- bs ]-         _ -> Nothing+   f (lhs :==: rhs) = liftM2 (:==:) (match v lhs) (match v rhs)++findFactor :: Monad m => [Rational] -> m Rational+findFactor rs+   | null rs = +        fail "no factor"+   | all ((==1) . denominator) rs = +        return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs+   | otherwise = +        return $ fromIntegral $ foldr1 lcm $ map denominator rs+        +parentNotNegCheck :: Rule (Context Expr)+parentNotNegCheck = minorRule $ makeSimpleRule "parent not negate check" $ \c -> +   case up c >>= current of+      Just (Negate _) -> Nothing+      _               -> Just c+      +noDivisionConstant :: Rule Expr+noDivisionConstant = makeSimpleRule (lineq, "no-div-con") f+ where+   f (a :/: b) | hasNoVar b && hasSomeVar a = +      return ((1/b) * a)+   f _ = Nothing+   +defPowerNat :: Rule Expr+defPowerNat = makeSimpleRule (polyeq, "def-power-nat") f+ where+   f (Sym _ [Var _, _]) = Nothing -- should not work on x^5+   f (Sym s [a, Nat n]) | isPowerSymbol s = +      return (build productView (False, replicate (fromInteger n) a))    f _ = Nothing
src/Domain/Math/Polynomial/Strategies.hs view
@@ -10,15 +10,16 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Strategies -   ( linearStrategy, linearMixedStrategy, quadraticStrategy-   , higherDegreeStrategy, findFactorsStrategy+   ( linearStrategy, linearMixedStrategy, linearStrategyG+   , quadraticStrategy, quadraticStrategyG+   , higherDegreeStrategy, higherDegreeStrategyG+   , findFactorsStrategy, findFactorsStrategyG    ) where  import Prelude hiding (repeat, replicate, fail)-import Common.Apply import Common.Strategy import Common.Navigator-import Common.Transformation+import Common.Id import Common.Uniplate (transform) import Common.View import Common.Context@@ -29,153 +30,154 @@ import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Polynomial.CleanUp+import Data.Maybe+import Common.Rewriting  ------------------------------------------------------------ -- Linear equations -linearStrategy :: LabeledStrategy (Equation Expr)-linearStrategy = linearStrategyWith False+linearStrategy :: LabeledStrategy (Context (Equation Expr))+linearStrategy = cleanUpStrategy (applyTop (fmap cleanUpSimple)) linearStrategyG -linearMixedStrategy :: LabeledStrategy (Equation Expr)-linearMixedStrategy = linearStrategyWith True+linearMixedStrategy :: LabeledStrategy (Context (Equation Expr))+linearMixedStrategy = +   let f   = applyTop (fmap (transform (simplify mixedFractionView) . cleanUpSimple))+       cfg = [ (byName ruleNormalizeMixedFraction, Reinsert)+             , (byName ruleNormalizeRational, Remove)+             ] +   in cleanUpStrategy f (configureNow (configure cfg linearStrategyG)) -linearStrategyWith :: Bool -> LabeledStrategy (Equation Expr)-linearStrategyWith mixed = cleanUpStrategy (fmap clean) $-   label "Linear Equation" -    $  label "Phase 1" (repeat (-              removeDivision -          <|> ruleMulti distributeTimesSomewhere-          <|> ruleMulti merge))+linearStrategyG :: IsTerm a => LabeledStrategy (Context a)+linearStrategyG =+   label "Linear Equation" $+       label "Phase 1" (repeat (+               use removeDivision+          <|>  multi (showId distributeTimes) (somewhere (useC parentNotNegCheck <*> use distributeTimes))+          <|>  multi (showId merge) (once (use merge))))    <*> label "Phase 2" (repeat (-          (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))-   [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith]-+              (use flipEquation |> use varToLeft)+          <|> use (coverUpPlusWith oneVar) +          <|> use (coverUpMinusLeftWith oneVar)+          <|> use (coverUpMinusRightWith oneVar)+          <|> use coverUpTimes +          <|> use coverUpNegate+           ))+   <*> repeat (once +          (  use ruleNormalizeRational+         <|> remove (use ruleNormalizeMixedFraction)+          ))+    ------------------------------------------------------------ -- Quadratic equations  quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))-quadraticStrategy = cleanUpStrategy (change cleanUpRelation) $ -   label "Quadratic Equation Strategy" $ -   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 +quadraticStrategy = +   cleanUpStrategy (applyTop cleanUpRelations) quadraticStrategyG++quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a)+quadraticStrategyG = +   label "Quadratic Equation Strategy" $ repeat $+   -- Relaxed strategy: even if there are "nice" factors, allow use of quadratic formula+      somewhere (generalForm <|> generalABCForm)+      |> somewhere zeroForm +      |> somewhere constantForm+      |> simplifyForm+      |> topForm   where-   fromEquation = mapRules (liftToContext . liftRule (switchView equationView))- -   -- ax^2 + bx + c == 0, without square formula+   -- ax^2 + bx + c == 0, without quadratic 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+          use commonFactorVar+      <|> use noLinFormula+      <|> use simplerPolynomial+      <|> remove (use bringAToOne)+      <|> use niceFactors+      <|> use coverUpPower -- to deal with special case x^2=0+            +   generalABCForm = label "abc form" $ +      useC abcFormula       -   generalABCForm = label "abc form" abcFormula-     zeroForm = label "zero form" $-      toStrategy mulZero+      use 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 -+   constantForm = label "constant form" $+          use (coverUpPlusWith oneVar)+      <|> use (coverUpMinusLeftWith oneVar)+      <|> use (coverUpMinusRightWith oneVar)+      <|> use coverUpTimes+      <|> use coverUpNegate+      <|> use coverUpNumerator+      <|> use squareBothSides +      <|> use factorLeftAsSquare+          -- simplifies square roots, or do an approximation -   simplifyForm = (fromEquation $ -      label "square root simplification" $ -           toStrategy (ruleMulti2 (ruleSomewhere simplerSquareRoot)))-        <|> remove (label "approximate result" $ -            toStrategy $ liftToContext (ruleMulti ruleApproximate))+   simplifyForm =+      label "square root simplification" (+         multi (showId simplerSquareRoot) (somewhere (use simplerSquareRoot)))+      <|> +      remove (label "approximate result" (+         multi (showId ruleApproximate) (somewhere (use ruleApproximate))))     topForm = label "top form" $-      ( 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-   +        somewhere (use cancelTerms  <|> use sameFactor)+      |> (  somewhere (use sameConFactor)+        <|> multi (showId merge) (somewhere (use merge))+        <|> somewhere (use distributionSquare)+        <|> multi (showId distributeTimes) (somewhere +               (useC parentNotNegCheck <*> use distributeTimes))+        <|> multi (showId distributeDivision) (somewhere +               (once (use distributeDivision)))+        <|> somewhere (use flipEquation)+         )+      |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare))+ ----------------------------------------------------------- -- Higher degree equations  higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))-higherDegreeStrategy =-   label "higher degree" $ -      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)--}+higherDegreeStrategy = +   cleanUpStrategy (applyTop cleanUpRelations) higherDegreeStrategyG --- 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 -> []+higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a)+higherDegreeStrategyG = label "higher degree" $ +   higherForm +   <*> label "quadratic"  quadraticStrategyG+   <*> afterSubst  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 -> []+   higherForm = label "higher degree form" $ repeat $+      somewhere (use allPowerFactors)+      |> somewhere (+              use coverUpPower+          <|> use mulZero+          <|> use sameFactor+          <|> use coverUpTimes+          <|> use exposeSameFactor+          <|> use (coverUpPlusWith oneVar)+          <|> use (coverUpMinusLeftWith oneVar)+          <|> use (coverUpMinusRightWith oneVar)+          <|> use sameConFactor+          <|> useC higherSubst)+      |> somewhere (use moveToLeft)+   +   afterSubst = label "afterwards" $ try $+      useC substBackVar  <*> repeat (somewhere (use coverUpPower))   ----------------------------------------------------------- -- Finding factors in an expression -findFactorsStrategy :: LabeledStrategy Expr-findFactorsStrategy = cleanUpStrategy cleanUpSimple $-   label "find factors" $-   repeat (niceFactorsNew <|> commonFactorVarNew)+findFactorsStrategy :: LabeledStrategy (Context Expr)+findFactorsStrategy = cleanUpStrategy (applyTop cleanUpSimple) $+   label "find factors" $ replicate 10 $ try findFactorsStrategyG+   +findFactorsStrategyG :: IsTerm a => LabeledStrategy (Context a)+findFactorsStrategyG = label "find factor step" $+   somewhereTimes $ +      use niceFactorsNew <|> use commonFactorVarNew +      <|> use factorVariablePower <|> use simplerLinearFactor++somewhereTimes :: IsStrategy f => f (Context a) -> Strategy (Context a)+somewhereTimes = somewhereWith "SomewhereTimes" $ \c -> +   if isTimesC c then [0 .. arity c-1] else []+   +isTimesC :: Context a -> Bool+isTimesC = maybe False (isJust . isTimes :: Term -> Bool) . currentT
src/Domain/Math/Polynomial/Tests.hs view
@@ -9,49 +9,37 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Domain.Math.Polynomial.Tests where+module Domain.Math.Polynomial.Tests (tests) where -import Control.Monad-import Common.Apply-import Common.Exercise-import Common.Context-import Common.Strategy-import Common.Derivation+import Common.TestSuite 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 Domain.Math.Numeric.Laws import Test.QuickCheck-import Data.Maybe  ------------------------------------------------------------ -- Testing instances -tests :: IO ()+tests :: TestSuite tests = do     let v = viewEquivalent (polyViewWith rationalView)    testNumLawsWith v "polynomial" (sized polynomialGen)  -- see the derivations for the DWO exercise set+{- seeLE  n = printDerivation linearExercise $ concat linearEquations !! (n-1) seeQE  n = printDerivation quadraticExercise $ orList $ return $ build equationView $ concat quadraticEquations !! (n-1) seeHDE n = printDerivation higherDegreeExercise $ orList $ return $ build equationView $ higherDegreeEquations !! (n-1)  -- test strategies with DWO exercise set+{- testLE  = concat $ zipWith (f linearExercise)       [1..] $ concat linearEquations testQE  = concat $ zipWith (f quadraticExercise)    [1..] $ map (orList . return . build equationView) $ concat quadraticEquations testHDE = concat $ zipWith (f higherDegreeExercise) [1..] $ map (orList . return . build equationView) higherDegreeEquations-+-}+f :: (Show b, Show a) => Exercise a -> b -> a -> [b] f s n e = map p (g (applyAll (strategy s) (inContext s e))) where   g xs | null xs   = error $ show n ++ ": " ++ show e        | otherwise = xs@@ -84,13 +72,13 @@ goQE = eqTest ineqQuadraticExercise  --eqTest :: Exercise a -> IO ()-eqTest ex = do+eqTest ex =    forM_ (examples ex) $ \eq -> do       let tree  = derivationTree (strategy ex) (inContext ex eq)       forM_ (derivations tree) $ \d -> do          let xs = terms d              pp = maybe "??" (prettyPrinter ex) . fromContext-         forM ([ (a, b) | a <- xs, b <- xs ]) $ \(a, b) -> do+         forM [ (a, b) | a <- xs, b <- xs ] $ \(a, b) ->             if equalityIneq a b -- equivalence ex (fromContext a) (fromContext b)              then putChar '.'               else error $ unlines ["", pp a, pp b]@@ -113,4 +101,4 @@    -- temporary fix    g (p :&&: q) = g p :&&: g q    g (p :||: q) = g p :||: g q-   g p          = p+   g p          = p -}
src/Domain/Math/Polynomial/Views.hs view
@@ -10,9 +10,9 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Views-   ( polyView, polyViewFor, polyViewWith, polyViewForWith-   , quadraticView, quadraticViewFor, quadraticViewWith, quadraticViewForWith-   , linearView, linearViewFor, linearViewWith, linearViewForWith+   ( polyView, polyViewWith -- polyViewFor, polyViewForWith+   , quadraticView, quadraticViewWith --, quadraticViewFor quadraticViewForWith+   , linearView, linearViewWith -- linearViewFor linearViewForWith    , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView    , monomialPolyView, binomialPolyView, trinomialPolyView    , polyNormalForm@@ -22,22 +22,22 @@  import Prelude hiding ((^)) import Control.Monad-import Common.Apply import Common.View-import Common.Traversable-import Common.Uniplate (transform, uniplate, children)+import Common.Classes+import Common.Rewriting+import Common.Uniplate (transform, descend, children) import Common.Utils (distinct) import Domain.Math.Data.Polynomial import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Expr import Domain.Math.Numeric.Views-import Domain.Math.Equation.CoverUpRules import Domain.Math.Polynomial.CleanUp+import Domain.Math.Equation.CoverUpRules import Data.Maybe import qualified Domain.Math.Data.SquareRoot as SQ import Domain.Math.SquareRoot.Views-import Domain.Math.Power.Views (powerFactorViewForWith)+import Domain.Math.Power.OldViews (powerFactorViewForWith)  ------------------------------------------------------------------- -- Polynomial view@@ -45,22 +45,15 @@ polyView :: View Expr (String, Polynomial Expr) polyView = polyViewWith identity -polyViewFor :: String -> View Expr (Polynomial Expr)-polyViewFor v = polyViewForWith v identity- polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a)-polyViewWith v = makeView f (uncurry g)+polyViewWith v = makeView matchPoly (uncurry buildPoly)  where-   f expr = do +   matchPoly expr = do        pv <- selectVar expr-      p  <- match (polyViewForWith pv v) expr+      p  <- matchPolyFor pv expr       return (pv, p) -   g pv = build (polyViewForWith pv v)-            -polyViewForWith :: Fractional a => String -> View Expr a -> View Expr (Polynomial a)-polyViewForWith pv v = makeView f g- where-   f expr = ++   matchPolyFor pv expr =       case expr of          Var s | pv == s -> Just var          Nat n    -> Just (fromIntegral n)@@ -71,18 +64,22 @@          a :/: b  -> do             c <- match v b             guard (c /= 0)-            guard (pv `notElem` collectVars b)+            guard (withoutVar pv b)             p <- f a             return (fmap (/c) p)-         Sym s [a, n] | s == powerSymbol ->+         Sym s [a, n] | isPowerSymbol s ->            liftM2 power (f a) (matchNat n)          _ -> do -            guard (pv `notElem` collectVars expr)+            guard (withoutVar pv expr)             liftM con (match v expr)+    where+      f = matchPolyFor pv    -   g        = build sumView . map h . reverse . terms-   h (a, n) = build v a .*. (Var pv .^. fromIntegral n)+   buildPoly pv = +      let f (a, n) = build v a .*. (Var pv .^. fromIntegral n)+      in build sumView . map f . reverse . terms    +       matchNat expr = do       n <- match integralView expr       guard (n >= 0)@@ -94,36 +91,24 @@ quadraticView :: View Expr (String, Expr, Expr, Expr) quadraticView = quadraticViewWith identity -quadraticViewFor :: String -> View Expr (Expr, Expr, Expr)-quadraticViewFor v = quadraticViewForWith v identity- quadraticViewWith :: Fractional a => View Expr a -> View Expr (String, a, a, a) quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> makeView f g  where    f (s, (a, b, c)) = return (s, a, b, c)    g (s, a, b, c)   = (s, (a, b, c)) -quadraticViewForWith :: Fractional a => String -> View Expr a -> View Expr (a, a, a)-quadraticViewForWith pv v = polyViewForWith pv v >>> quadraticPolyView- ------------------------------------------------------------------- -- Linear view  linearView :: View Expr (String, Expr, Expr) linearView = linearViewWith identity -linearViewFor :: String -> View Expr (Expr, Expr)-linearViewFor v = linearViewForWith v identity- linearViewWith :: Fractional a => View Expr a -> View Expr (String, a, a) linearViewWith v = polyViewWith v >>> second linearPolyView >>> makeView f g  where    f (s, (a, b)) = return (s, a, b)    g (s, a, b)   = (s, (a, b)) -linearViewForWith :: Fractional a => String -> View Expr a -> View Expr (a, a)-linearViewForWith pv v = polyViewForWith pv v >>> linearPolyView- ------------------------------------------------------------------- -- Views on polynomials (degree) @@ -166,17 +151,31 @@ polynomialList p = map (`coefficient` p) [d, d-1 .. 0]  where d = degree p -list1 (a)          = [a]-list2 (a, b)       = [a, b]-list3 (a, b, c)    = [a, b, c]+list1 :: a -> [a]+list1 a = [a]++list2 :: (a, a) -> [a]+list2 (a, b)     = [a, b]++list3 :: (a, a, a) -> [a]+list3 (a, b, c) = [a, b, c]++list4 :: (a, a, a, a) -> [a] list4 (a, b, c, d) = [a, b, c, d] -isList1 [a]          = Just a-isList1 _            = Nothing-isList2 [a, b]       = Just (a, b)-isList2 _            = Nothing-isList3 [a, b, c]    = Just (a, b, c)-isList3 _            = Nothing+isList1 :: [a] -> Maybe a+isList1 [a] = Just a+isList1 _   = Nothing++isList2 :: [a] -> Maybe (a, a)+isList2 [a, b] = Just (a, b)+isList2 _      = Nothing++isList3 :: [a] -> Maybe (a, a, a)+isList3 [a, b, c] = Just (a, b, c)+isList3 _         = Nothing++isList4 :: [a] -> Maybe (a, a, a, a) isList4 [a, b, c, d] = Just (a, b, c, d) isList4 _            = Nothing @@ -248,85 +247,77 @@             in build productView (False, map make xs) :==: 0  higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr)-higherDegreeEquationsView = makeView f (fmap g)+higherDegreeEquationsView = makeView f (fmap (:==: 0))  where-   f = let make (a :==: b) = orList (filter (not . hasNegSqrt) $ map cleanUpExpr2 (normHDE (a-b)))-       in Just . normalize . join . fmap make . cuRules+   f    = Just . normalize . join . fmap make . coverUpOrs+   make = orList . filter (not . hasNegSqrt) +        . map (cleanUpExpr . distr) . normHDE . sub+   sub (a :==: b) = a-b -   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+   distr = transform g+    where+      g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c)+      g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c)+      g a = a  hasNegSqrt :: Expr -> Bool hasNegSqrt (Sqrt a) =     case match rationalView a of       Just r | r < 0 -> True       _ -> hasNegSqrt a-hasNegSqrt (Sym s [a, b]) | s == rootSymbol = +hasNegSqrt (Sym s [a, b]) | isRootSymbol s =     case (match rationalView a, match integerView b) of       (Just r, Just n) | r < 0 && even n -> True       _ -> hasNegSqrt a || hasNegSqrt b hasNegSqrt a =     any hasNegSqrt (children a) -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)  -> g x p+      Just (x, p)  -> normPolynomial x p       Nothing -> fromMaybe [e] $ do          (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0)          return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] - where-   g :: String -> Polynomial Rational -> [Expr]-   g x p -       | d==0 = []-       | length (terms p) <= 1 = [Var x]-       | d==1 = [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)]-       | d==2 = let [a,b,c] = [ coefficient n p | n <- [2,1,0] ]-                    discr   = b*b - 4*a*c-                    sdiscr  = SQ.sqrtRational discr-                in if discr < 0 then [] else -                   map ((Var x .+.) . build (squareRootViewWith rationalView))-                   [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr)-                   , SQ.scale (1/(2*a)) (SQ.con b - sdiscr)-                   ]-       | otherwise = -            case terms p of -               [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> -                  let list = [(c, 0), (b, 1), (a, e2 `div` e1)]-                      newp = sum (map (\(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-      ++normPolynomial :: String -> Polynomial Rational -> [Expr]+normPolynomial x p +   | degree p == 0 = +        []+   | length (terms p) <= 1 = +        [Var x]+   | degree p == 1 = +        [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)]+   | degree p == 2 = +        let [a,b,c] = [ coefficient n p | n <- [2,1,0] ]+            discr   = b*b - 4*a*c+            sdiscr  = SQ.sqrtRational discr+        in if discr < 0 then [] else +           map ((Var x .+.) . build (squareRootViewWith rationalView))+           [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr)+           , SQ.scale (1/(2*a)) (SQ.con b - sdiscr)+           ]+   | otherwise = +        case terms p of +           [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> +              let list = [(c, 0), (b, 1), (a, e2 `div` e1)]+                  newp = sum (map (\(y, z) -> scale y (power var z)) list)+                  sub  = map (substitute (x, Var x^fromIntegral e1))+              in concatMap normHDE (sub (normPolynomial x newp))+           [(c, 0), (a, n)]+              | odd n  -> if c/a >= 0 +                          then [Var x + root (fromRational (c/a)) (fromIntegral n)]+                          else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)]+              | even n -> if c/a > 0+                          then []+                          else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n) +                               , Var x - root (fromRational (abs (c/a))) (fromIntegral n)+                               ]+           _ -> +              case factorize p of+                 ps | length ps > 1 -> concatMap (normPolynomial x) ps+                 _ -> [build (polyViewWith rationalView) (x, p)]+ substitute :: (String, Expr) -> Expr -> Expr substitute (s, a) (Var b) | s==b = a-substitute pair expr = f (map (substitute pair) cs)- where -   (cs, f) = uniplate expr+substitute pair expr = descend (substitute pair) expr
+ src/Domain/Math/Power/Equation/Exercises.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Domain.Math.Power.Equation.Exercises    +   ( powerEqExercise+   , expEqExercise+   , logEqExercise+   , higherPowerEqExercise+   ) where++import Prelude hiding ( (^) )++import Common.Context+import Common.Exercise+import Common.View+import Domain.Math.Data.OrList+import Domain.Math.Data.Relation+import Domain.Math.Equation.Views+import Domain.Math.Examples.DWO4+import Domain.Math.Expr hiding (isPower)+import Domain.Math.Numeric.Views+import Domain.Math.Power.Rules+import Domain.Math.Power.Equation.Strategies+import Domain.Math.Power.Equation.NormViews+++------------------------------------------------------------+-- Exercises++powerEqExercise :: Exercise (Relation Expr)+powerEqExercise = let precision = 2 in makeExercise+  { status         = Provisional+  , parser         = parseExprWith (pRelation pExpr)+  , strategy       = powerEqApproxStrategy+  , navigation     = termNavigator+  , exerciseId     = describe "solve power equation algebraically with x > 0" $ +                       newId "algebra.manipulation.exponents.equation"+  , examples       = concatMap (map $ build equationView) $ +                       powerEquations ++ [last higherPowerEquations]+  , isReady        = solvedRelation+  , isSuitable   = (`belongsTo` (normPowerEqApproxView precision))+  , equivalence    = viewEquivalent (normPowerEqApproxView precision)+  }+  +expEqExercise :: Exercise (Equation Expr)+expEqExercise = makeExercise+  { status         = Provisional+  , parser         = parseExprWith (pEquation pExpr)+  , strategy       = expEqStrategy+  , navigation     = termNavigator+  , exerciseId     = describe "solve exponential equation algebraically" $ +                       newId "algebra.manipulation.exponential.equation"+  , examples       = concat expEquations+  , isReady        = \ rel -> isVariable (leftHandSide rel) +                           && rightHandSide rel `belongsTo` rationalView+  , isSuitable     = (`belongsTo` normExpEqView)+  , equivalence    = viewEquivalent normExpEqView+  , ruleOrdering   = ruleOrderingWithId [ getId root2power ]  +  }++logEqExercise :: Exercise (OrList (Relation Expr))+logEqExercise = makeExercise+  { status         = Provisional+  , parser         = parseExprWith (pOrList (pRelation pExpr))+  , strategy       = logEqStrategy+  , navigation     = termNavigator+  , exerciseId     = describe "solve logarithmic equation algebraically" $ +                       newId "algebra.manipulation.logarithmic.equation"+  , examples       = map (orList . return . build equationView) (concat logEquations)+  , isReady        = solvedRelations+  , isSuitable     = (`belongsTo` (switchView equationView >>> normLogEqView))+  , equivalence    = viewEquivalent (switchView equationView >>> normLogEqView)+  , ruleOrdering   = ruleOrderingWithId [ getId calcPower+                                        , getId calcRoot ]+  }++higherPowerEqExercise :: Exercise (OrList (Equation Expr))+higherPowerEqExercise = makeExercise+  { status         = Provisional+  , parser         = parseExprWith (pOrList (pEquation pExpr))+  , strategy       = higherPowerEqStrategy+  , navigation     = termNavigator+  , exerciseId     = describe "solve higher power equation algebraically" $ +                       newId "algebra.manipulation.exponents.equation"+  , examples       = map (orList . return) $ concat $ init higherPowerEquations+  , isReady        = solvedRelations+  , isSuitable     = maybe False and . disjunctions . fmap (`belongsTo` normPowerEqView)+  , equivalence    = let f = normalize . fmap (simplify normPowerEqView')+                     in \ x y -> f x == f y+  , ruleOrdering   = ruleOrderingWithId [ getId calcPower+                                        , getId calcRoot ]+  }+
+ src/Domain/Math/Power/Equation/NormViews.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Power.Equation.NormViews+{-   ( normPowerEqApproxView+   , normPowerEqView+   , normExpEqView+   , normLogEqView+--   , normLogView+   ) -} where++import Common.Classes+import Common.View+import Common.Rewriting hiding (rewrite)+import Control.Arrow ( (>>^) )+import Control.Monad+import Data.List+import Data.Maybe+import Data.Ratio+import Domain.Math.Approximation+import Domain.Math.Data.OrList+import Domain.Math.Data.PrimeFactors+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.CleanUp+import Domain.Math.Polynomial.Views+import Domain.Math.Power.NormViews+import Domain.Math.Power.Utils+import Domain.Math.Power.Views+import Domain.Math.Simplification hiding (simplify, simplifyWith)++import Common.Uniplate++-- Change to configurable strategy!+normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr)+normPowerEqApproxView d = makeView f (uncurry (.~=.))+   where+     f rel = case relationType rel of +      EqualTo       -> fmap (second (simplifyWith (precision d) doubleView)) +                     $ match (equationView >>> normPowerEqView) rel +      Approximately -> return (leftHandSide rel, rightHandSide rel)+      _             -> Nothing++normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0!+normPowerEqView = makeView f (uncurry (:==:))+  where+    f expr = do+      -- selected var to the left, the rest to the right+      (lhs :==: rhs) <- varLeft expr >>= constRight+      -- match power+      (c, ax)        <- match (timesView <&> (identity >>^ (,) 1)) $+                          simplify normPowerView lhs+      (a, x)         <- match myPowerView ax+      -- simplify, scale and take root+      let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)+      return (a, simplify rationalView y)++    myPowerView =  powerView +               <&> (rootView >>> second (makeView (\a->Just (1 ./. a)) (1 ./.)))+               <&> (identity >>^ \a->(a,1))++normPowerEqView' :: View (Equation Expr) (Expr, Expr) -- with x>0!+normPowerEqView' = makeView f (uncurry (:==:))+  where+    f expr = do+      -- selected var to the left, the rest to the right+      (lhs :==: rhs) <- varLeft expr >>= constRight+      -- match power+      (c, (a, x))    <- match unitPowerView lhs+      -- simplify, scale and take root+      let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)+      return (a, simplify myRationalView y)++constRight :: Equation Expr -> Maybe (Equation Expr)+constRight (lhs :==: rhs) = do+  (vs, cs) <- fmap (partition hasSomeVar) (match sumView lhs)+  let rhs' = rhs .+. build sumView (map neg cs)+  return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs'++negateEq :: Equation Expr -> Equation Expr+negateEq (lhs :==: rhs) = +  case lhs of+    Negate lhs' -> lhs' :==: neg rhs+    _           -> lhs  :==: rhs++varLeft :: Equation Expr -> Maybe (Equation Expr)+varLeft (lhs :==: rhs) = do+  (vs, cs) <- fmap (partition hasSomeVar) (match sumView rhs)+  return $ lhs .+. build sumView (map neg vs) :==: build sumView cs++scaleLeft :: Equation Expr -> Maybe (Equation Expr)+scaleLeft (lhs :==: rhs) = +  match timesView lhs >>= \(c, x) -> return $ +    x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c)++normExpEqView :: View (Equation Expr) (String, Rational)+normExpEqView = makeView f id >>> linearEquationView+  where+    try g a = fromMaybe a $ g a+    f e = do+      let (l :==: r) = try scaleLeft $ try constRight e+      return $ case match powerView l of+        Just (b, x) -> x :==: simplify normLogView (logBase b r)+        Nothing     -> l :==: r++normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr))+normLogEqView = makeView (liftM g . switch . fmap f) id  -- AG: needs to be replaced by higherOrderEqView+  where+    f expr@(lhs :==: rhs) = return $+      case match logView lhs of+        Just (b, x) -> x :==: simplify myRationalView (b .^. rhs)+        Nothing     -> expr+    g = fmap (fmap (simplify myRationalView) . simplify normPowerEqView) +      . simplify quadraticEquationsView ++-- liftToOrListView :: View a b -> View (OrList a) (OrList b)+-- liftToOrListView v = makeView (switch . fmap (match v)) ()++normLogView :: View Expr Expr+normLogView = makeView g id+  where+    g expr = +      case expr of +        Sym s [x, y] +          | isLogSymbol s -> do+              b <- match integerView x+              let divExp (be, n) = return $ f be y ./. fromInteger n+              maybe (Just $ f b y) divExp $ greatestPower b+          | otherwise -> Nothing+        _ -> Nothing+    f b expr= +      case expr of+        Nat 1     -> Nat 0+        Nat n     +          | n == b    -> Nat 1+          | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) Nat +                       $ lookup b (allPowers n)+        e1 :*: e2 -> f b e1 .+. f b e2+        e1 :/: e2 -> f b e1 .-. f b e2+        Sqrt e    -> f b (e .^. (1 ./. 2))+        Negate e  -> Negate $ f b e+        Sym s [x,y]+          | isPowerSymbol s -> y .*. f b x+          | isRootSymbol  s -> f b (x .^. (1 ./. y))+        _         -> expr++myRationalView :: View Expr Rational+myRationalView = makeView (return . rewrite simplerPower) id >>> rationalView++simplerPower :: Expr -> Maybe Expr+simplerPower expr = +  case expr of      +    Sqrt x -> simplerPower $ x .^. (1/2)+    Sym s [x, y]+      | isRootSymbol s  -> simplerPower $ x .^. (1/y)+      | isPowerSymbol s -> f+      | otherwise -> Nothing+        where f | y == 0 || x == 1 = Just 1+                | y == 1 = Just x+                | x == 0 = Just 0+                | otherwise =+                  -- geheel getal+                  liftM fromRational (match rationalView expr) +                  `mplus`+                  -- wortel+                  do +                    ry <- match rationalView y+                    rx <- match rationalView x+                    guard $ numerator ry == 1 && denominator rx == 1+                    liftM fromInteger $ takeRoot (numerator rx) (denominator ry)+                  `mplus`+                  -- (a/b)^y -> a^x/b^y+                  do+                    (a, b) <- match divView x+                    return $ build divView (a .^. y, b .^. y)+    _ -> Nothing++-- myRationalView = makeView (exprToNum f) id >>> rationalView+--   where+--     f s [x, y] +--       | isDivideSymbol s = +--           fracDiv x y+--       | isPowerSymbol s = do+--           ry <- match rationalView y+--           rx <- match rationalView x+--           if      ry == 0 then return 1                      -- 0+--           else if ry == 1 then return rx                     -- 1+--           else if denominator ry == 1 then            -- geheel getal+--             let a = x Prelude.^ abs (numerator ry)+--             in return $ if numerator ry < 0 then 1 / a else a+--           else if numerator ry == 1 then              -- breuk / root+--             if denominator ry > 1 then +--               if denominator rx == 1 then+--                 takeRoot (numerator rx) (denominator ry)   -- breuk/root+--               else+--                 f powerSymbol [numerator rx, ] / f powerSymbol []+--             else+--               take+--           else                                       -- no calculation+--       | isRootSymbol s = do+--           n <- match integerView y+--           b <- match integerView x+--           liftM fromInteger $ lookup b $ map swap (allPowers n)+--     f _ _ = Nothing+
+ src/Domain/Math/Power/Equation/Rules.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Power.Equation.Rules +  ( -- * Power equation rules+    commonPower, nthRoot, sameBase, equalsOne, greatestPower+  , approxPower, reciprocalFor+  ) where++import Common.Transformation+import Common.Rewriting+import Common.View hiding (simplify)+import Control.Monad+import Domain.Math.Approximation (precision)+import qualified Domain.Math.Data.PrimeFactors as PF+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Power.Utils+import Domain.Math.Power.Views+import Domain.Math.Simplification (simplify)+++-- | Identifier prefix --------------------------------------------------------++powereq :: String+powereq = "algebra.manipulation.exponents.equation"++-- | Power relation rules -----------------------------------------------------++-- | a^x = b^y  =>  a^(x/c) = b^(y/c)  where c = gcd x y+commonPower :: Rule (Equation Expr)+commonPower = makeSimpleRule (powereq, "common-power") $ \expr -> do+  let v = eqView (powerView >>> second integerView)+  ((a, x), (b, y)) <- match v expr+  let c = gcd x y+  guard $ c > 1+  return $ build v ((a, x `div` c), (b, y `div` c))++-- | a^x = n  =>  a^x = b^e+greatestPower :: Rule (Equation Expr)+greatestPower = makeSimpleRule (powereq, "greatest-power") $ \(lhs :==: rhs) -> do+  n      <- match integerView rhs+  (_, x) <- match (powerView >>> second integerView) lhs+  (b, e) <- PF.greatestPower n+  guard $ gcd x e > 1+  return $ lhs :==: fromInteger b .^. fromInteger e++-- a^x = c*b^y  =>  a = c*b^(y/x)+nthRoot :: Rule (Equation Expr)+nthRoot = makeSimpleRule (powereq, "nth-root") $ \(lhs :==: rhs) -> do+  guard $ hasSomeVar lhs+  (a, x)      <- match powerView lhs+  (c, (b, y)) <- match unitPowerView rhs+  return $ a :==: build unitPowerView (c, (b, simplify (y ./. x)))++-- -- root a x = b  =>  a = b^x+-- nthPower :: Rule (Equation Expr)+-- nthPower = makeSimpleRule (powereq, "nth-power") $ \(lhs :==: rhs) -> do+--   guard $ hasSomeVar lhs+--   (a, x) <- match rootView lhs+--   return $ a :==: rhs .^. x++-- x = a^x  =>  x ~= d+approxPower :: Rule (Relation Expr)+approxPower = makeRule (powereq, "approx-power") $ approxPowerT 2++-- x = a^x  =>  x ~= d+approxPowerT :: Int -> Transformation (Relation Expr)+approxPowerT n = makeTrans $ \ expr ->+  match equationView expr >>= f+  where+    f (Var x :==: d) = +      match doubleView d >>= Just . (Var x .~=.) . Number . precision n+    f (d :==: Var x) = +      match doubleView d >>= Just . (.~=. Var x) . Number . precision n+    f _              = Nothing++-- -- a*x + c = b*y + d  =>  a*x - b*y = d - c   (move vars to the left, cons to the right)+-- varLeftConRight :: Rule (Equation Expr)+-- varLeftConRight = makeSimpleRule (powereq, "var-left-con-right") $ +--   \(lhs :==: rhs) -> do+--     (xs, cs) <- fmap (partition hasSomeVar) (match sumView lhs)+--     (ys, ds) <- fmap (partition hasSomeVar) (match sumView rhs)+--     guard $ length cs > 0 || length ys > 0+--     return $ fmap collectLikeTerms $ +--       build sumView (xs ++ map neg ys) :==: build sumView (ds ++ map neg cs)++-- a^x = a^y  =>  x = y+sameBase :: Rule (Equation Expr)+sameBase = makeSimpleRule (powereq, "same-base") $ \ expr -> do+  ((a, x), (b, y)) <- match (eqView powerView) expr+  guard $ a == b+  return $ x :==: y++-- | c*a^x = d*(1/a)^y  => c*a^x = d*a^-y+-- this reciprocal rule is more strict, it demands a same base on the lhs+-- of the equation. Perhaps do this via the enviroment?+reciprocalFor :: Rule (Equation Expr)+reciprocalFor = makeSimpleRule (powereq, "reciprocal-for-base") $ +  \ (lhs :==: rhs) -> do+    (_, (a,  _)) <- match unitPowerView lhs+    (one, _)     <- match divView rhs+    (d, (a'', y)) <- match consPowerView rhs+    guard $ one == 1 && a'' == a+    return $ lhs :==: d .*. a'' .^. negate y++-- | a^x = 1  =>  x = 0+equalsOne :: Rule (Equation Expr)+equalsOne = makeSimpleRule (powereq, "equals-one") $ \ (lhs :==: rhs) -> do+  guard $ rhs == 1+  (_, x) <- match powerView lhs+  return $ x :==: 0+
+ src/Domain/Math/Power/Equation/Strategies.hs view
@@ -0,0 +1,115 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Power.Equation.Strategies+   -- ( powerEqStrategy+   -- , powerEqApproxStrategy+   -- , expEqStrategy+   -- , logEqStrategy+   -- , higherPowerEqStrategy+   -- ) +   where++import Prelude hiding (repeat, not)++import Common.Classes+import Common.Context+import Common.Id+import Common.Navigator+import Common.Rewriting+import Common.Strategy+import Common.View (belongsTo)+import Control.Arrow+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Data.OrList+import Domain.Math.Expr+import Domain.Math.Equation.CoverUpExercise+import Domain.Math.Equation.CoverUpRules+import Domain.Math.Polynomial.CleanUp+import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy)+import Domain.Math.Polynomial.Rules (flipEquation)+import Domain.Math.Power.Rules+import Domain.Math.Power.Utils+import Domain.Math.Power.Equation.Rules+import Domain.Math.Numeric.Rules++-- | Strategies ---------------------------------------------------------------++powerEqStrategy :: IsTerm a => LabeledStrategy (Context a)+powerEqStrategy = cleanUpStrategy clean strat+  where+    strat =  label "Power equation" $ repeat+          $  myCoverUpStrategy+         <*> option (use greatestPower <*> use commonPower)+         <*> use nthRoot+         <*> remove (label "useApprox" $ try $ use approxPower)++    clean = applyD $ exhaustiveUse rules+    rules = onePower : fractionPlus : naturalRules ++ rationalRules++powerEqApproxStrategy :: LabeledStrategy (Context (Relation Expr))+powerEqApproxStrategy = label "Power equation with approximation" $+  configureNow (configure cfg powerEqStrategy)+    where+      cfg = [ (byName (newId "useApprox"), Reinsert) ]++expEqStrategy :: LabeledStrategy (Context (Equation Expr))+expEqStrategy = cleanUpStrategy cleanup strat+  where +    strat =  label "Exponential equation" +          $  myCoverUpStrategy+         <*> repeat (somewhereNotInExp (use factorAsPower))+         <*> repeat (somewhereNotInExp (use reciprocal))+         <*> powerS +         <*> (use sameBase <|> use equalsOne)+         <*> linearStrategy+           +    cleanup = applyD (exhaustiveUse $ naturalRules ++ rationalRules)+            . applyTop (fmap (mergeConstantsWith isIntRatio))+    +    isIntRatio x = x `belongsTo` myIntegerView || x `belongsTo` v+      where v = divView >>> first myIntegerView >>> second myIntegerView+    +    powerS = exhaustiveUse [ root2power, addExponents, subExponents+                           , mulExponents,  simpleAddExponents ]++logEqStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))+logEqStrategy = label "Logarithmic equation"+              $  use logarithm+             <*> try (use flipEquation)+             <*> repeat (somewhere $  use nthRoot +                                  <|> use calcPower +                                  <|> use calcPowerPlus +                                  <|> use calcPowerMinus+                                  <|> use calcPlainRoot+                                  <|> use calcPowerRatio)+             <*> quadraticStrategy+++higherPowerEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))+higherPowerEqStrategy =  cleanUpStrategy cleanup coverUpStrategy+  where +    cleanup = applyTop $ fmap $ fmap cleanUpExpr++++-- | Help functions -----------------------------------------------------------++myCoverUpStrategy :: IsTerm a => Strategy (Context a)+myCoverUpStrategy = repeat $ alternatives $ map use coverUpRules++somewhereNotInExp :: IsStrategy f => f (Context a) -> Strategy (Context a)+somewhereNotInExp = somewhereWith "somewhere but not in exponent" f+  where+    f a = if isPowC a then [1] else [0 .. arity a-1]+    isPowC = maybe False (isJust . isPower :: Term -> Bool) . currentT
src/Domain/Math/Power/Exercises.hs view
@@ -9,32 +9,37 @@ -- Portability :  portable (depends on ghc) -- -----------------------------------------------------------------------------+ module Domain.Math.Power.Exercises    -   ( simplifyPowerExercise+   ( -- * Power exercises+     simplifyPowerExercise    , powerOfExercise -   , nonNegExpExercise+   , nonNegBrokenExpExercise    , calcPowerExercise    ) where -import Common.Apply +import Prelude hiding ( (^) )++import Common.Classes  import Common.Context import Common.Exercise import Common.Navigator+import Common.Rewriting import Common.Strategy hiding (not, replicate) import Common.Utils (distinct) import Common.View import Data.Maybe import Domain.Math.Examples.DWO3-import Domain.Math.Expr+import Domain.Math.Expr hiding (isPower) import Domain.Math.Numeric.Views import Domain.Math.Power.Rules import Domain.Math.Power.Strategies+import Domain.Math.Power.NormViews import Domain.Math.Power.Views-import Prelude hiding ( (^) ) ---------------------------------------------------------------- Exercises +-- | Exercises ----------------------------------------------------------------+ powerExercise :: LabeledStrategy (Context Expr) -> Exercise Expr powerExercise s = makeExercise     { status        = Provisional@@ -44,82 +49,84 @@    }  simplifyPowerExercise :: Exercise Expr-simplifyPowerExercise = (powerExercise powerStrategy)-   { description  = "simplify expression (powers)"-   , exerciseCode = makeCode "math" "simplifyPower"+simplifyPowerExercise = (powerExercise simplifyPowerStrategy)+   { exerciseId   = describe "simplify expression (powers)" $ +                       newId "algebra.manipulation.exponents.simplify"    , isReady      = isPowerAdd-   , isSuitable   = (`belongsTo` normPowerView')-   , equivalence  = viewEquivalent normPowerView'-   , examples     = concat $  simplerPowers ++ powers1 ++ powers2 +   , isSuitable   = (`belongsTo` normPowerMapView)+   , equivalence  = viewEquivalent normPowerMapView+   , examples     = concat $  simplerPowers +                           ++ powers1 ++ powers2                             ++ negExp1 ++ negExp2                            ++ normPower1 ++ normPower2 ++ normPower3+   , ruleOrdering = ruleOrderingWithId $ map getId+                      [ root2power, subExponents, reciprocalVar, addExponents+                      , mulExponents, distributePower ]    }  powerOfExercise :: Exercise Expr powerOfExercise = (powerExercise powerOfStrategy)-   { description  = "write as a power of a"-   , exerciseCode = makeCode "math" "powerOf"+   { exerciseId   = describe "write as a power of a" $ +                       newId "algebra.manipulation.exponents.powerof"    , isReady      = isSimplePower    , isSuitable   = (`belongsTo` normPowerView)    , equivalence  = viewEquivalent normPowerNonNegRatio-   , examples     = concat $  powersOfA ++ powersOfX ++ brokenExp1' -                           ++ brokenExp2 ++ brokenExp3 ++ normPower5'-                           ++ normPower6+   , examples     = concat $  powersOfA ++ powersOfX +                           ++ brokenExp1' ++ brokenExp2 ++ brokenExp3 +                           ++ normPower5' ++ normPower6+   , ruleOrdering = ruleOrderingWithId $ map getId+                      [ root2power, addExponents, subExponents, mulExponents+                      ,  distributePower, reciprocalVar ]    } -nonNegExpExercise :: Exercise Expr-nonNegExpExercise = (powerExercise nonNegExpStrategy)-   { description  = "write with a non-negative exponent"-   , exerciseCode = makeCode "math" "nonNegExp"-   , isReady      = isPower natView+nonNegBrokenExpExercise :: Exercise Expr+nonNegBrokenExpExercise = (powerExercise nonNegBrokenExpStrategy)+   { exerciseId   = describe "write with a non-negative exponent" $ +                       newId "algebra.manipulation.exponents.nonnegative"+   , isReady      = isPower plainNatView    , isSuitable   = (`belongsTo` normPowerNonNegDouble)    , equivalence  = viewEquivalent normPowerNonNegDouble    , examples     = concat $  nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 -                           ++ brokenExp1 ++ normPower4' ++ normPower5+                           ++ brokenExp1 +                           ++ normPower4' ++ normPower5+   , ruleOrdering = ruleOrderingWithId [ getId mulExponents+                                       , getId reciprocalFrac+                                       , getId reciprocalInv+                                       , getId power2root+                                       , getId distributePower ]    }  calcPowerExercise :: Exercise Expr calcPowerExercise = (powerExercise calcPowerStrategy)-   { description  = "simplify expression (powers)"-   , exerciseCode = makeCode "math" "calcPower"+   { exerciseId   = describe "simplify expression (powers)" $ +                       newId "arithmetic.exponents"    , isReady      = isPowerAdd-   , isSuitable   = (`belongsTo` normPowerView')-   , equivalence  = viewEquivalent normPowerView'+   , isSuitable   = (`belongsTo` normPowerMapView)+   , equivalence  = viewEquivalent normPowerMapView    , examples     = concat $ negExp3 ++ normPower3' ++ normPower4    }  -------------------------------------------------------------------------- Ready checks+-- | Ready checks -------------------------------------------------------------  isSimplePower :: Expr -> Bool-isSimplePower (Sym s [Var _,y]) | s==powerSymbol = y `belongsTo` rationalView+isSimplePower (Sym s [Var _, y]) +                 | isPowerSymbol s = y `belongsTo` rationalView isSimplePower _ = False  isPower :: View Expr a -> Expr -> Bool isPower v expr = -     let Just (_, xs) = match productView expr -         f (Nat 1 :/: a) = g a-         f a = g a-         g (Sym s [Var _, a]) | 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+  let Just (_, xs) = match productView expr +      f (Nat 1 :/: a) = g a+      f a = g a+      g (Sym s [Var _, a]) | isPowerSymbol s = isJust (match v a)+      g (Sym s [x, Nat _]) | isRootSymbol s = isPower v x +      g (Sqrt x) = g x+      g (Var _) = True+      g a = a `belongsTo` rationalView+  in distinct (concatMap vars xs) && all f xs       isPowerAdd :: Expr -> Bool isPowerAdd expr =   let Just xs = match sumView expr   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/NormViews.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Power.NormViews +   ( -- * Normalising views+     normPowerView, normPowerMapView, normPowerNonNegRatio+   , normPowerNonNegDouble+   ) where++import Prelude hiding ((^), recip)+import qualified Prelude+import Control.Monad+import Common.View+import Data.List+import qualified Data.Map as M+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Power.Utils++type PowerMap = (M.Map String Rational, Rational)+++normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational)+normPowerNonNegRatio = makeView (liftM swap . f) (g . swap)+  where+    f expr = +        case expr of+           Sym s [a,b] +              | isPowerSymbol s -> do+                   (r, m) <- f a+                   if r==1 +                     then do+                       r2 <- match rationalView b+                       return (1, M.map (*r2) m)+                     else do+                       n <- match integerView b+                       if n >=0 +                         then return (r Prelude.^ n, M.map (*fromIntegral n) m)+                         else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m)+              | isRootSymbol s ->+                  f (Sym powerSymbol [a, 1/b])+           Sqrt a -> +              f (Sym rootSymbol [a,2])+           a :*: b -> do+             (r1, m1) <- f a+             (r2, m2) <- f b+             return (r1*r2, M.unionWith (+) m1 m2)+           a :/: b -> do+             (r1, m1) <- f a+             (r2, m2) <- f b+             guard (r2 /= 0)+             return (r1/r2, M.unionWith (+) m1 (M.map negate m2))+           Var s -> return (1, M.singleton s 1)+           Nat n -> return (toRational n, M.empty)+           Negate x -> do +             (r, m) <- f x+             return (negate r, m)+           _ -> do+             r <- match rationalView expr+             return (fromRational r, M.empty)+    g (r, m) = +       let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ]+       in build productView (False, fromRational r : xs)++-- | AG: todo: change double to norm view for rationals+normPowerNonNegDouble :: View Expr (Double, M.Map String Rational)+normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g+  where+    roundof n (x, m) = (fromInteger (round (x * 10.0 ** n)) / 10.0 ** n, m)+    f expr = +      case expr of+        Sym s [a,b] +          | isPowerSymbol s -> do+            (x, m) <- f a+            y      <- match rationalView b+            return (x ** fromRational y, M.map (*y) m)+          | isRootSymbol s -> f (Sym powerSymbol [a, 1/b])+        Sqrt a -> f (Sym rootSymbol [a,2])+        a :*: b -> do+          (r1, m1) <- f a+          (r2, m2) <- f b+          return (r1*r2, M.unionWith (+) m1 m2)+        a :/: b -> do+          (r1, m1) <- f a+          (r2, m2) <- f b+          guard (r2 /= 0)+          return (r1/r2, M.unionWith (+) m1 (M.map negate m2))+        Var s -> return (1, M.singleton s 1)+        Negate x -> do +          (r, m) <- f x+          return (negate r, m)+        _ -> do+          d <- match doubleView expr+          return (d, M.empty)+    g (r, m) = +      let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ]+      in build productView (False, fromDouble r : xs)++normPowerMapView :: View Expr [PowerMap]+normPowerMapView = makeView (liftM h . f) g+  where+    f = (mapM (match normPowerNonNegRatio) =<<) . match sumView+    g = build sumView . map (build normPowerNonNegRatio)+    h :: [PowerMap] -> [PowerMap]+    h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy (\x y -> fst x == fst y) . sort++normPowerView :: View Expr (String, Rational)+normPowerView = makeView f g+ where+   f expr = +        case expr of+           Sym s [x,y] +              | isPowerSymbol s -> do+                   (s2, r) <- f x+                   r2 <- match rationalView y+                   return (s2, r*r2)+              | isRootSymbol s -> +                   f (x^(1/y))+           Sqrt x ->+              f (Sym rootSymbol [x, 2])+           Var s -> return (s, 1) +           x :*: y -> do+             (s1, r1) <- f x+             (s2, r2) <- f y+             guard (s1==s2)+             return (s1, r1+r2)+           Nat 1 :/: y -> do+             (s, r) <- f y+             return (s, -r)+           x :/: y -> do+             (s1, r1) <- f x+             (s2, r2) <- f y+             guard (s1==s2)+             return (s1, r1-r2) +           _ -> Nothing+             +   g (s, r) = Var s .^. fromRational r+
+ src/Domain/Math/Power/OldViews.hs view
@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Power.OldViews where++import Common.Rewriting+import Common.View+import Control.Monad+import Domain.Math.Expr hiding ( (^) )++powerFactorView :: View Expr (String, Expr, Int)+powerFactorView = powerFactorViewWith identity++powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int)+powerFactorViewWith v = makeView f g+ where+   f expr = do+      pv <- selectVar expr+      (e, n) <- match (powerFactorViewForWith pv v) expr+      return (pv, e, n)+   g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n)++powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int)+powerFactorViewForWith pv v = makeView f g+ where+   f expr = +      case expr of+         Var s | pv == s -> Just (1, 1)+         Negate e -> do+            (a, b) <- f e+            return (negate a, b)+         e1 :*: e2 -> do +            (a1, b1) <- f e1+            (a2, b2) <- f e2+            return (a1*a2, b1+b2)+         Sym s [e1, Nat n]+            | isPowerSymbol s -> do +                 (a1, b1) <- f e1+                 a <- match v (build v a1 ^ toInteger n)+                 return (a, b1 * fromInteger n)+         _ -> do+            guard (withoutVar pv expr)+            a <- match v expr +            return (a, 0)+   +   g (a, b) = build v a .*. (Var pv .^. fromIntegral b)
src/Domain/Math/Power/Rules.hs view
@@ -9,46 +9,97 @@ -- Portability :  portable (depends on ghc) -- -----------------------------------------------------------------------------+ module Domain.Math.Power.Rules    ( -- * Power rules     calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents-  , subExponents, distributePower, distributePowerDiv, zeroPower, reciprocal-  , reciprocalInv+  , subExponents, distributePower, distributePowerDiv, reciprocal+  , reciprocalInv, reciprocalFrac, calcPowerRatio, calcRoot, simplifyPower+  , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar+  , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents     -- * Root rules-  , power2root, root2power, distributeRoot, mulRoot, mulRootCom, divRoot-  , simplifyRoot+  , power2root, root2power+    -- * Log rules+  , logarithm     -- * Common rules-  , myFractionTimes, simplifyFraction, pushNegOut-    -- * Help functions-  , smartRule+  , myFractionTimes, pushNegOut   ) where  import Prelude hiding ( (^) ) import qualified Prelude-import Common.Apply++import Common.Classes import Control.Arrow ( (>>^) )+import Common.Id import Common.Transformation import Common.View import Control.Monad import Data.List import Data.Maybe+import qualified Domain.Math.Data.PrimeFactors as PF+import Domain.Math.Data.OrList+import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Numeric.Views+import Domain.Math.Power.Utils import Domain.Math.Power.Views-import Domain.Math.Polynomial.CleanUp  +-- | Identifier prefixes ------------------------------------------------------++power, logarithmic :: String+power       = "algebra.manipulation.exponents"+logarithmic = "algebra.manipulation.logarithmic"++ -- | Power rules -------------------------------------------------------------- +-- n  =>  a^e  (with e /= 1)+factorAsPower :: Rule Expr+factorAsPower = makeSimpleRuleList (power, "factor-as-power") $ \ expr -> do+  n      <- matchM myIntegerView expr+  (a, x) <- PF.allPowers $ toInteger n+  if n > 0+    then return $ fromInteger a .^. fromInteger x+    else if odd x+      then return $ fromInteger (negate a) .^. fromInteger x+      else fail "Could not factorise number."+ calcPower :: Rule Expr -calcPower = makeSimpleRule "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)+calcPower = makeSimpleRule "arithmetic.operation.rational.power" $ \ expr -> do +  (a, x) <- match (powerViewWith rationalView plainNatView) expr+  return $ fromRational $ a Prelude.^ x +-- | a^(x/y) => (a^x)^(1/y)+calcPowerRatio :: Rule Expr+calcPowerRatio = makeSimpleRule (power, "power-ratio") $ \ expr -> do+  let v = powerView >>> second (rationalView >>> plainRationalView)+  (a, (x, y)) <- match v expr+  guard $ x /= 1 && y /= 1+  return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y)++-- -- | root n x+calcPlainRoot :: Rule Expr+calcPlainRoot = makeSimpleRule (power, "root") $ \ expr -> do+  (n, x) <- match (rootView >>> (integerView *** integerView)) expr+  y      <- takeRoot n x+  return $ fromInteger y++-- | [root n x, ... ]+calcRoot :: Rule (OrList Expr)+calcRoot = makeSimpleRuleList (power, "root") $ \ ors ->+  fromMaybe [] (disjunctions ors) >>= maybeToList . f+    where +      f expr = do+        (n, x) <- match (rootView >>> (integerView *** integerView)) expr+        y      <- liftM fromInteger $ lookup n $ map swap $ PF.allPowers (abs x)+        let ys | x > 0 && even n = [y, negate y]+               | x > 0 && odd  n = [y]+               | x < 0 && odd  n = [negate y]+               | otherwise       = []+        roots  <- toMaybe (not. null) ys+        return $ orList roots+ calcPowerPlus :: Rule Expr  calcPowerPlus =    makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus @@ -57,227 +108,213 @@ 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 ""+addExponents :: Rule Expr+addExponents = makeSimpleRuleList (power, "add-exponents") $ \ expr -> do+  (sign, fs)     <- matchM (powerFactorView isPow) expr+  ((x, y), fill) <- twoNonAdjacentHoles fs+  prod           <- applyM addExponentsT $ x * y+  return $ build productView (sign, fill prod) +isPow :: Expr -> Expr -> Bool+isPow x y = x `belongsTo` myIntegerView && +             (y `belongsTo` varView || y `belongsTo` powerView) + -- | a*x^y * b*x^q = a*b * x^(y+q)-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)-  +addExponentsT :: Transformation Expr +addExponentsT = makeTrans $ \ expr -> do+  (e1, e2)     <- match timesView expr+  (a, (x,  y)) <- match unitPowerView e1+  (b, (x', q)) <- match unitPowerView e2+  guard $ x == x'+  return $ build unitPowerView (a .*. b, (x, y .+. q))++simpleAddExponents :: Rule Expr+simpleAddExponents = makeRule (power, "simple-add-exponents") addExponentsT+ -- | a*x^y / b*x^q = a/b * x^(y-q) subExponents :: Rule Expr-subExponents = 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)+subExponents = makeSimpleRule (power, "sub-exponents") $ \ expr -> do+  (e1, e2)     <- match divView expr+  (a, (x,  y)) <- match unitPowerView e1+  (b, (x', q)) <- match unitPowerView e2+  guard $ x == x'+  return $ build unitPowerView (a ./. b, (x, y .-. q)) --- | (c*a^x)^y = c*a^(x*y)+-- | (a^x)^y = 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))+mulExponents = makeSimpleRule (power, "mul-exponents") $ \ expr -> do+  ((a, x), y) <- match (strictPowerView >>> first powerView) expr+  return $ build powerView (a, x .*. y) --- | c*(a0..an)^y = c * a0^y * a1^y .. * an^y+-- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x 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)+distributePower = makeSimpleRule (power, "distr-power") $ \ expr -> do+  ((sign, as), x) <- match (powerViewWith productView identity) expr+  guard $ length as > 1+  let y = build productView (False, map (\a -> build powerView (a, x)) as)+  return $ +    maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x --- | c * (a/b)^y = c * (a^y / b^y)+-- | (a/b)^y = (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)+distributePowerDiv = makeSimpleRule (power, "distr-power-div") $ \ expr -> do+  ((a, b), y) <- match (powerViewWith divView identity) expr+  return $ build divView (build powerView (a, y), build powerView (b, y)) --- | c*a^0 = c+-- | a^0 = 1 zeroPower :: Rule Expr-zeroPower = makeSimpleRule "zero power" $ \ expr -> do-  (_, (c, y)) <- match strictPowerView expr-  y' <- match integerView y-  guard (y'==0)-  return c+zeroPower = makeSimpleRule (power, "power-zero") $ \ expr -> do+  (_, x) <- match powerView expr+  guard $ x == 0+  return 1 --- | 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)+-- a ^ 1 = a+onePower :: Rule Expr+onePower = makeSimpleRule (power, "power-one") $ \ expr -> do+  (a, x) <- match powerView expr+  guard $ x == 1+  return a --- | 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))+-- 1 ^ x = 1+powerOne :: Rule Expr+powerOne = makeSimpleRule (power, "one-power") $ \ expr -> do+  (a, _) <- match powerView expr+  guard $ a == 1+  return a +-- 0 ^ x = 0 with x > 0+powerZero :: Rule Expr+powerZero = makeSimpleRule (power, "one-power") $ \ expr -> do+  (a, x) <- match (powerViewWith identity integerView) expr+  guard $ x > 0 && a == 0+  return 0 +-- | all of the above simplification rules+simplifyPower :: Rule Expr+simplifyPower = makeSimpleRuleList (power, "simplify") $ \ expr ->+  mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero]++-- | e/a = e*a^(-1)  where a is an variable+reciprocalVar :: Rule Expr+reciprocalVar = makeSimpleRule (power, "reciprocal-var") $ \ expr -> do+  (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr+  return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c++-- | c/a^x = c*a^x^(-1)+reciprocalPower :: Rule Expr+reciprocalPower = makeSimpleRule (power, "reciprocal-power") $ \ expr -> do+  (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr+  return $ (e .*. build consPowerView (1, (a, neg x))) ./. c++-- | Use with care, will match any fraction!+reciprocal :: Rule Expr  +reciprocal = makeSimpleRule (power, "reciprocal") $+  apply (reciprocalForT identity)++-- | a/b = a*b^(-1)+reciprocalForT :: View Expr a -> Transformation Expr+reciprocalForT v = makeTrans $ \ expr -> do+  (a, b) <- match divView expr+  guard $ b `belongsTo` v+  return $ a .*. build powerView (b, -1)++-- | a^x = 1/a^(-x)+reciprocalInv ::  Rule Expr+reciprocalInv = makeSimpleRule (power, "reciprocal-inverse") $ \ expr -> do+  guard $ hasNegExp expr+  (a, x) <- match strictPowerView expr+  return $ 1 ./. build strictPowerView (a, neg x)++-- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r...+reciprocalFrac :: Rule Expr+reciprocalFrac = makeSimpleRule (power, "reciprocal-frac") $ \ expr -> do+  (e1, e2) <- match divView expr+  (s, xs)  <- match productView e2+  let (ys, zs) = partition hasNegExp xs+  guard (not $ null ys)+  return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs)+    where+      f e = case match consPowerView e of+              Just (c, (a, x)) -> build consPowerView (c, (a, neg x))+              Nothing          -> e++-- | a^x / b^x = (a/b)^x+divBase :: Rule Expr+divBase = describe "divide base of root" $+  makeSimpleRule (power, "divide-base") $ \ expr -> do+  (e1, e2)      <- match divView expr+  (c1, (a, x))  <- match consPowerView e1+  (c2, (b, x')) <- match consPowerView e2+  guard $ x == x' && b /= 0+  return $ build consPowerView (c1 .*. c2, (a ./. b, x))++-- | (-a)^x = -(a^x)+pushNegOut :: Rule Expr+pushNegOut = makeSimpleRule (power, "push-negation-out") $ \ expr -> do+  (a, x) <- match (powerViewWith identity integerView) expr+  a'     <- isNegate a+  return $ (if odd x then neg else id) $ build powerView (a', fromInteger x)++ -- | Root rules ----------------------------------------------------------------  -- | a^(p/q) = root (a^p) q-power2root :: Rule Expr -power2root = makeSimpleRule "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+power2root :: Rule Expr+power2root = makeSimpleRule (power, "write-as-root") $ \ expr -> do+  (a, (p, q)) <- match (strictPowerView >>> second divView) expr+  guard $ q /= 1+  return $ root (a .^. p) q   --- | root (a^p) q = a^(p/q)+-- | root a q = a^(1/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))+root2power = makeSimpleRule (power, "write-as-power") $ \ expr -> do+  (a, q) <- match strictRootView expr+  return $ a .^. (1 ./. 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))+-- | Logarithmic relation rules ----------------------------------------------- --- | 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+logarithm :: Rule (Equation Expr)+logarithm = makeSimpleRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do+    (b, x) <- match logView lhs+    return $ x :==: build powerView (b, rhs)   -- | Common rules --------------------------------------------------------------  -- | a/b * c/d = a*c / b*d  (b or else d may be one)   myFractionTimes :: Rule Expr-myFractionTimes = smartRule $ makeSimpleRule "fraction times" $ \ expr -> do+myFractionTimes = smartRule $ makeSimpleRule (power, "fraction-times") $ \ expr -> do   (e1, e2) <- match timesView expr-  guard $ isJust $ match divView e1 `mplus` match divView e2+  guard $ e1 `belongsTo` divView || e2 `belongsTo` divView   (a, b)   <- match (divView <&> (identity >>^ \e -> (e,1))) e1   (c, d)   <- match (divView <&> (identity >>^ \e -> (e,1))) e2---  (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)))+  makeSimpleRule (power, "calc-power", opName) $ \e -> do+    (e1, e2)     <- m e+    (c1, (a, x)) <- match unitPowerViewVar e1+    (c2, (b, y)) <- match unitPowerViewVar e2+    guard $ a == b && x == y+    return $ build unitPowerViewVar (op c1 c2, (a, x)) +-- use twoNonAdHoles instead of split ??? makeCommutative :: View Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr-makeCommutative view op rule = -  makeSimpleRuleList (name rule) $ \ expr -> do+makeCommutative view op r = +  makeSimpleRuleList (getId r) $ \ expr ->     case match view expr of       Just factors -> do         (e, es) <- split op factors-        case apply rule e of+        case apply r 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 [] = []+          Nothing -> []+      Nothing -> [] -forallVars :: (String -> Rule Expr) -> Rule Expr-forallVars ruleFor = makeSimpleRuleList (name (ruleFor "")) $ \ expr -> -  mapMaybe (\v -> apply (ruleFor v) expr) $ collectVars expr+hasNegExp :: Expr -> Bool+hasNegExp expr = fromMaybe False $ +  fmap ((< 0) . snd . snd) (match consPowerView expr)
src/Domain/Math/Power/Strategies.hs view
@@ -9,148 +9,77 @@ -- Portability :  portable (depends on ghc) -- -----------------------------------------------------------------------------+ module Domain.Math.Power.Strategies-   ( powerStrategy+   ( -- * Power strategies+     simplifyPowerStrategy    , powerOfStrategy    , calcPowerStrategy-   , nonNegExpStrategy+   , nonNegBrokenExpStrategy    ) where -import Common.Apply+import Prelude hiding (repeat, not)++import Common.Classes import Common.Context+import Common.Id+import Common.Navigator import Common.Strategy import Common.Transformation-import Common.View import Domain.Math.Expr+import Domain.Math.Numeric.Rules (divisionNumerator, divisionDenominator) import Domain.Math.Power.Rules-import Domain.Math.Power.Views-import Domain.Math.Numeric.Rules-import Domain.Math.Numeric.Views-import Prelude hiding (repeat)+import Domain.Math.Power.Utils+import Domain.Math.Simplification ---------------------------------------------------------------- Strategies -powerStrategy :: LabeledStrategy (Context Expr)-powerStrategy = makeStrategy "simplify" rules cleanupRules-  where -    rules = powerRules -    cleanupRules = calcPower : naturalRules ++ rationalRules+-- | Strategies --------------------------------------------------------------- +simplifyPowerStrategy :: LabeledStrategy (Context Expr)+simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules + powerOfStrategy :: LabeledStrategy (Context Expr)-powerOfStrategy = makeStrategy "write as power of" rules cleanupRules-  where-   rules = powerRules -   cleanupRules = calcPower -                : simplifyRoot -                : simplifyFraction -                : naturalRules -               ++ rationalRules+powerOfStrategy = cleanUpStrategyRules "Write as power of" powerRules  -nonNegExpStrategy :: LabeledStrategy (Context Expr)-nonNegExpStrategy = makeStrategy "non negative exponent" rules cleanupRules+nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr)+nonNegBrokenExpStrategy = cleanUpStrategy (change cleanup . applyTop cleanup) strategy   where-    rules = [ addExponents-            , subExponents-            , mulExponents-            , reciprocalInv hasNegExp-            , distributePower-            , distributePowerDiv-            , power2root-            , distributeRoot-            , zeroPower-            , calcPowerPlus-            , calcPowerMinus-            , myFractionTimes-            ] ++ fractionRules            -    cleanupRules = calcPower : simplifyFraction  : naturalRules+    rs = [ addExponents, subExponents, mulExponents, reciprocalInv+         , distributePower, distributePowerDiv, power2root, zeroPower+         , calcPowerPlus, calcPowerMinus+         ]+    strategy = label "Write with non-negative exponent" $ exhaustiveStrategy rs+    cleanup = applyD divisionNumerator+            . applyD myFractionTimes+            . mergeConstants +            . simplifyWith simplifyConfig {withMergeAlike = False}  calcPowerStrategy :: LabeledStrategy (Context Expr)-calcPowerStrategy = makeStrategy "calcPower" rules cleanupRules+calcPowerStrategy = cleanUpStrategy cleanup strategy   where-    rules = calcPower -          : mulRootCom-          : divRoot -          : rationalRules-    cleanupRules = rationalRules ++ naturalRules+    strategy = label "Calculate power" $ exhaustiveStrategy rules+    rules = calcPower : divisionDenominator : reciprocalInv : divBase : rationalRules+    cleanup = applyTop (applyD myFractionTimes)+            . applyD (exhaustiveStrategy $ myFractionTimes : 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)+-- | Rule collections --------------------------------------------------------- +powerRules :: [Rule Expr] powerRules =-      [ addExponents-      , subExponents-      , mulExponents-      , distributePower-      , zeroPower-      , reciprocal-      , root2power-      , distributeRoot-      , calcPower-      , calcPowerPlus-      , calcPowerMinus-      , myFractionTimes-      , pushNegOut-      ]+  [ addExponents, subExponents, mulExponents, distributePower, zeroPower+  , reciprocalVar, root2power, calcPower, calcPowerPlus, calcPowerMinus+  , pushNegOut+  ] -hasNegExp expr = -  case match strictPowerView expr of-    Just (_, (_, x)) -> case match rationalView x of-      Just x' -> x' < 0-      _       -> False-    _ -> False +-- | Help functions ----------------------------------------------------------- --- | 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-   ]+cleanUpStrategyRules :: IsId n => n -> [Rule Expr] -> LabeledStrategy (Context Expr)+cleanUpStrategyRules l = +  cleanUpStrategy (change cleanUp. applyTop cleanUp) . label l . exhaustiveStrategy++cleanUp :: Expr -> Expr+cleanUp = mergeConstants +        . simplifyWith simplifyConfig {withMergeAlike = False}+
+ src/Domain/Math/Power/Utils.hs view
@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  alex.gerdes@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- some of these help functions may have a broader scope and could be +-- moved to other parts of the framework (eg. Common)+--+-----------------------------------------------------------------------------++module Domain.Math.Power.Utils where++import Prelude hiding (repeat, replicate)++import Common.Context+import Common.Rewriting+import Common.Strategy hiding (not)+import Common.Transformation+import Common.View+import Control.Monad+import Data.List hiding (repeat, replicate)+import Data.Ratio+import qualified Domain.Math.Data.PrimeFactors as PF+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Domain.Math.Numeric.Rules+import Domain.Math.Numeric.Views+++-- | Strategy functions -------------------------------------------------------++exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a)+exhaustiveStrategy = exhaustiveSomewhere . map liftToContext++exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b)+exhaustiveUse = exhaustiveSomewhere . map use++exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a)+exhaustiveSomewhere = repeat . somewhere . alternatives++-- | Rule functions -----------------------------------------------------------++smartRule :: Rule Expr -> Rule Expr+smartRule = doAfter f+  where+    f (a :*: b) = a .*. b+    f (a :/: b) = a ./. b+    f (Negate a) = neg a+    f (a :+: b) = a .+. b+    f (a :-: b) = a .-. b+    f e = e+         +mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr+mergeConstantsWith p = simplifyWith f productView+  where+    f (sign, xs) = +      let (cs, ys) = partition p xs+          c = simplify rationalView $ build productView (False, cs)+      in if maybe False (> 1) (match rationalView c) +           then (sign, c:ys) +           else (sign, xs)++mergeConstants :: Expr -> Expr+mergeConstants = mergeConstantsWith (`belongsTo` rationalView)++-- | View functions -----------------------------------------------------------++(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b+v <&> w = makeView (\x -> match v x `mplus` match w x) (build v)++infixl 1 <&>++plainNatView :: View Expr Integer+plainNatView = makeView f Nat+  where+    f (Nat n) = Just n+    f _       = Nothing++myIntegerView :: View Expr Integer+myIntegerView = makeView f fromInteger+  where+    f (Nat n)          = Just n+    f (Negate (Nat n)) = Just $ negate n+    f _                = Nothing++plainRationalView :: View Rational (Integer, Integer)+plainRationalView = +  makeView (\x -> return (numerator x, denominator x)) (uncurry (%))++eqView :: View a b -> View (Equation a) (b, b)+eqView v = eqv >>> v *** v+  where+    eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:))+++-- | Rule collections ---------------------------------------------------------++naturalRules :: [Rule Expr]+naturalRules =+   [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView+   , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView+   , doubleNegate, negateZero , plusNegateLeft, plusNegateRight+--   , minusNegateLeft+   , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft+   , divisionNegateRight+   ]++rationalRules :: [Rule Expr]+rationalRules = +   [ calcPlusWith "rational" rationalRelaxedForm+   , calcMinusWith "rational" rationalRelaxedForm+   , calcTimesWith "rational" rationalRelaxedForm+   , calcDivisionWith "integer" integerNormalForm+   , doubleNegate, negateZero, divisionDenominator, divisionNumerator+   , simplerFraction+   ]+   +fractionRules :: [Rule Expr]+fractionRules =+   [ fractionPlus, fractionPlusScale, fractionTimes+   , calcPlusWith "integer" integerNormalForm+   , calcMinusWith "integer" integerNormalForm+   , calcTimesWith "integer" integerNormalForm -- not needed?+   , calcDivisionWith "integer" integerNormalForm+   , doubleNegate, negateZero, smartRule divisionDenominator+   , smartRule divisionNumerator, simplerFraction+   ]+++-- | Common functions ---------------------------------------------------------++takeRoot :: Integer -> Integer -> Maybe Integer+takeRoot n x = do+  y <- if (abs n == 1) +         then Just 1+         else lookup x $ map swap $ PF.allPowers (abs n)+  guard $ n > 0 || (n < 0 && odd x)+  return $ if n > 0 then y else negate y++swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)++split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])]    +split op xs = f xs+      where+        f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys +                 | otherwise     = []+        f [] = []++toMaybe :: (a -> Bool) -> a -> Maybe a+toMaybe p x = if p x then Just x else Nothing++joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]]+joinBy _  [] = []+joinBy eq xs = ys : joinBy eq (xs \\ ys)+  where+    ys = dropUntil eq xs ++dropUntil :: (a -> a -> Bool) -> [a] -> [a]+dropUntil _ []       = []+dropUntil _ [x]      = [x]+dropUntil p (x:y:ys) | p x y     = x : dropUntil p (y:ys) +                     | otherwise = [x]++holes :: [a] -> [(a, [a], a -> [a])]+holes xs = map f [0 .. length xs - 1] +  where +    f i = let (ys, z:zs) = splitAt i xs +          in (z, ys ++ zs, \x -> ys ++ x:zs)++twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])]+twoNonAdjacentHoles xs = concatMap g pairs+  where+    pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]]+    g (x, y) = let (ys, z:zs) = splitAt x xs +                   (ps, q:qs) = splitAt (y - x - 1) zs +               in if null ps+                 then [ ((z, q), \a -> ys ++ a:ps ++ qs) ]+                 else [ ((z, q), \a -> ys ++ a:ps ++ qs)+                      , ((z, q), \a -> ys ++ ps ++ a:qs) ]
src/Domain/Math/Power/Views.hs view
@@ -10,345 +10,151 @@ -- ----------------------------------------------------------------------------- -module Domain.Math.Power.Views +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+     powerView, powerViewWith, powerViewForWith, powerViewFor, powerFactorView+   , consPowerView, consPowerViewForWith, consPowerViewFor,consPowerViewForVar+   , unitPowerViewForVar, unitPowerViewVar, unitPowerView, strictPowerView+   , rootView, strictRootView+     -- * Log view+   , logView      -- * Other views-   , ratioView, natView+   , plainNatView, plainRationalView, varView    ) where -import Prelude hiding ((^), recip)-import qualified Prelude import Control.Arrow ( (>>^) ) import Control.Monad+import Common.Rewriting 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+import Domain.Math.Power.Utils  --- | 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 with constant factor ----------------------------------------- +consPowerView :: View Expr (Expr, (Expr, Expr))+consPowerView = addNegativeView $ addUnitTimesView powerView --- | 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        +consPowerViewForWith :: Num a => View Expr a -> View Expr b -> a -> View Expr (Expr, b)+consPowerViewForWith va vb a = +  addNegativeView $ addUnitTimesView (powerViewForWith va vb a) -strictPowerViewFor :: String -> View Expr (Expr, Expr)-strictPowerViewFor pv = makeView f g+consPowerViewFor :: Expr -> View Expr (Expr, Expr)+consPowerViewFor = consPowerViewForWith identity identity++consPowerViewForVar :: String -> View Expr (Expr, Expr)+consPowerViewForVar = consPowerViewFor . Var++unitPowerViewForVar :: String -> View Expr (Expr, Expr)+unitPowerViewForVar s = makeView f g   where     f expr = do-      (c, (a, x)) <- match strictPowerView expr-      guard (Var pv == a)+      (c, (s', x)) <- match unitPowerViewVar expr+      guard $ s == s'       return (c, x)-    g (c, x) = build strictPowerView (c, (Var pv, x))+    g (c, x) = build unitPowerViewVar (c , (s, x)) -powerConsViewFor :: String -> View Expr (Expr, Rational)-powerConsViewFor pv = timesView >>> second (powerViewFor' pv)+unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr))+unitPowerViewWith v = addNegativeView $ addUnitTimesView $ +  powerViewWith v identity <&> (unitTimes v >>^ swap) -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)+unitPowerViewVar :: View Expr (Expr, (String, Expr))+unitPowerViewVar = unitPowerViewWith varView -unitPowerView :: ViewM Maybe Expr (String, (Expr, Rational))-unitPowerView = unitView <&> negUnitView +-- | Careful! This view will match anything, so use it wise and with care.+unitPowerView :: View Expr (Expr, (Expr, Expr))+unitPowerView = unitPowerViewWith identity++-- | A root view+rootView :: View Expr (Expr, Expr)+rootView = makeView f (uncurry root)    where -    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      +    f expr = do+      (a, (x, y)) <- match (powerView >>> second divView) expr+      guard (x == 1 || x == -1)+      return $ if x == 1 then (a, y) else (a, negate y) -simplePowerView :: View Expr (Expr, Expr)-simplePowerView = makeView f g+-- | only matches sqrt and root+strictRootView :: View Expr (Expr, Expr)+strictRootView = makeView f g   where     f expr =        case expr of-        Sym s [a, b] | s == powerSymbol -> return (a, b)+        Sym s [a, b] | isRootSymbol s -> return (a, b)+        Sqrt e                       -> return (e, 2)         _ -> Nothing-    g (a, b) = a .^. b   +    +    g (a, b) = if b == 2 then Sqrt a else root 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 ---------------------------------------------------------------+-- | Power 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)+strictPowerView :: View Expr (Expr, Expr)+strictPowerView = makeView f (uncurry (.^.))+  where+    f expr = +      case expr of+        Sym s [a, b] | isPowerSymbol s -> return (a, b)         _ -> Nothing-    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)-+powerView :: View Expr (Expr, Expr)+powerView = makeView f g +  where+    f = match ((strictRootView >>^ h) <&> strictPowerView)+    h (a, b) = (a, 1 ./. b)+    g (a, b) = +       case b of +         (Nat 1 :/: b') -> build strictRootView (a, b')+         _              -> build strictPowerView (a, b) --- | Bastiaan's power views ---------------------------------------------------+powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b)+powerViewWith va vb = powerView >>> first va >>> second vb --- | AG: todo: integrate these views with the views above+powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b+powerViewForWith va vb a = makeView f ((build va a .^.) .  build vb)+  where +    f expr = do+      (a', b) <- match (powerViewWith va vb) expr+      guard $ a == a'+      return b -natView :: View Expr Int-natView = makeView f fromIntegral-  where-    f (Nat n) = Just $ fromInteger n-    f _       = Nothing+powerViewFor :: Expr -> View Expr Expr+powerViewFor = powerViewForWith identity identity -ratioView :: View Rational (Int, Int)-ratioView = makeView f g+powerFactorView :: (Expr -> Expr -> Bool) -> View Expr (Bool, [Expr])+powerFactorView p = productView >>> second (makeView f id)   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+    f = Just . map (build productView . (,) False) . joinBy p -powerViewWith :: View Expr b -> View Expr (String, b)-powerViewWith v = makeView f g- where  -   f expr = do-      pv <- selectVar expr-      n  <- match (powerViewForWith' v pv) expr-      return (pv, n)-   g (pv, n) = build (powerViewForWith' v pv) n-   -powerViewFor :: String -> View Expr Int-powerViewFor = powerViewForWith natView-powerViewFor' = powerViewForWith' rationalView+-- | Log views ---------------------------------------------------------------- -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 -> match v 1-         e1 :*: e2 -> liftM2 (+) (f e1) (f e2) -         Sym s [e, n] | s == powerSymbol -> do-           n'<- match v n-           liftM (* n') (f e)-         _ -> Nothing-   -   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+logView :: View Expr (Expr, Expr)+logView = makeView f (uncurry logBase)+  where +    f expr = case expr of+        Sym s [a, b] | isLogSymbol s -> return (a, b)         _ -> Nothing-   -   g a = Var pv .^. build v a -powerFactorView :: View Expr (String, Expr, Int)-powerFactorView = powerFactorViewWith identity -powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int)-powerFactorViewWith v = makeView f g- where-   f expr = do-      pv <- selectVar expr-      (e, n) <- match (powerFactorViewForWith pv v) expr-      return (pv, e, n)-   g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n)--powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int)-powerFactorViewForWith pv v = makeView f g- where-   f expr = -      case expr of-         Var s | pv == s -> Just (1, 1)-         Negate e -> do-            (a, b) <- f e-            return (negate a, b)-         e1 :*: e2 -> do -            (a1, b1) <- f e1-            (a2, b2) <- f e2-            return (a1*a2, b1+b2)-         Sym s [e1, Nat n]-            | s == powerSymbol -> do -                 (a1, b1) <- f e1-                 a <- match v (build v a1 ^ Nat n)-                 return (a, b1 * fromInteger n)-         _ -> do-            guard (pv `notElem` collectVars expr)-            a <- match v expr -            return (a, 0)-   -   g (a, b) = build v a .*. (Var pv .^. fromIntegral b)-+-- | Help (non-power) views --------------------------------------------------- --- | Normalising views ---------------------------------------------------------+unitTimes :: Num t => View a b -> View a (t, b)+unitTimes = (>>^ (,) 1) -normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational)-normPowerNonNegRatio = makeView (liftM swap . f) (g . swap)- where-     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)+addTimesView :: View Expr a -> View Expr (Expr, a)+addTimesView v = timesView >>> second v --- | 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-        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)+addUnitTimesView :: View Expr a -> View Expr (Expr, a)+addUnitTimesView v = addTimesView v <&> unitTimes v +negateView :: (Num a, WithFunctions a) => View a a+negateView = makeView isNegate negate -type PowerMap = (M.Map String Rational, Rational)+addNegativeView :: View Expr a -> View Expr a+addNegativeView v = v <&> (negateView >>> v) -normPowerView' :: View Expr [PowerMap]-normPowerView' = makeView (liftM h . f) g+varView :: View Expr String+varView = makeView f Var   where-    f = (mapM (match normPowerNonNegRatio) =<<) . match sumView-    g = build sumView . map (build normPowerNonNegRatio)-    h :: [PowerMap] -> [PowerMap]-    h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy (\x y -> fst x == fst y) . sort--normPowerView :: View Expr (String, Rational)-normPowerView = makeView f g- where-   f expr = -        case expr of-           Sym s [x,y] -              | 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+    f (Var s) = Just s+    f _       = Nothing
src/Domain/Math/Simplification.hs view
@@ -10,16 +10,19 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Simplification -   ( Simplify(..), smartConstructors+   ( Simplify(..), SimplifyConfig(..), smartConstructors+   , simplifyConfig    , Simplified, simplified, liftS, liftS2    , simplifyRule+   , mergeAlike, distribution, constantFolding+   , mergeAlikeSum, mergeAlikeProduct    ) where  import Common.Context import Common.Navigator import Common.Transformation import Common.Uniplate-import Common.View hiding (simplify)+import Common.View hiding (simplify, simplifyWith) import Control.Monad import Data.List import Data.Maybe@@ -29,29 +32,47 @@ import Domain.Math.SquareRoot.Views import Test.QuickCheck import qualified Common.View as View-import Common.Rewriting ++data SimplifyConfig = SimplifyConfig +  { withSmartConstructors  :: Bool+  , withMergeAlike         :: Bool+  , withDistribution       :: Bool+  , withSimplifySquareRoot :: Bool+  , withConstantFolding    :: Bool+  }+ class Simplify a where+   simplifyWith :: SimplifyConfig -> a -> a    simplify :: a -> a+   simplify = simplifyWith simplifyConfig +simplifyConfig :: SimplifyConfig+simplifyConfig = SimplifyConfig True True True True True+ instance Simplify a => Simplify (Context a) where-   simplify = change simplify+   simplifyWith cfg = change $ simplifyWith cfg  instance Simplify a => Simplify (Equation a) where-   simplify = fmap simplify+   simplifyWith cfg = fmap $ simplifyWith cfg +instance Simplify a => Simplify (Relation a) where+   simplifyWith cfg = fmap $ simplifyWith cfg+ instance Simplify a => Simplify [a] where-   simplify = fmap simplify+   simplifyWith cfg = fmap $ simplifyWith cfg  instance Simplify Expr where-   simplify = smartConstructors -            . mergeAlike -            . distribution -            . View.simplify (squareRootViewWith rationalView)-            . constantFolding+   simplifyWith cfg = let optional p f = if p then f else id in+       optional (withSmartConstructors cfg)  smartConstructors+     . optional (withMergeAlike cfg)         mergeAlike+     . optional (withDistribution cfg)       distribution+     . optional (withSimplifySquareRoot cfg) (View.simplify +                                               (squareRootViewWith rationalView))+     . optional (withConstantFolding cfg)    constantFolding  instance Simplify a => Simplify (Rule a) where-   simplify = doAfter simplify -- by default, simplify afterwards+   simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards  data Simplified a = S a deriving (Eq, Ord) @@ -93,7 +114,7 @@    acosh   = liftS acosh  instance Simplify (Simplified a) where-   simplify = id+   simplifyWith _ = id  instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where    toTerm (S x) = toTerm x@@ -127,7 +148,7 @@       Negate a -> neg a       a :*: b  -> a .*. b       a :/: b  -> a ./. b-      Sym s [a, b] | s == powerSymbol -> +      Sym s [a, b] | isPowerSymbol s ->           a .^. b       _        -> expr @@ -135,8 +156,10 @@ -- Distribution of constants  distribution :: Expr -> Expr-distribution = transformTD $ \expr ->-   fromMaybe expr $ do+distribution = descend distribution . f+ where+  f expr =+   fromMaybe expr $    case expr of       a :*: b -> do          (x, y) <- match plusView a@@ -160,8 +183,7 @@ constantFolding expr =     case match rationalView expr of       Just r  -> fromRational r-      Nothing -> let (xs, f) = uniplate expr-                 in f (map constantFolding xs)+      Nothing -> descend constantFolding expr                   ---------------------------------------------------------------------- -- merge alike for sums and products@@ -177,12 +199,13 @@  mergeAlikeProduct :: [Expr] -> [Expr] mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ]-  where  f []                    = []-         f ((Nothing  , e):xs)   = e:f xs-         f ((Just r   , _):xs)   = -           let  cs    = r :  [ c  | (Just c   , _)  <- xs ]-                rest  =      [ x  | (Nothing  , x)  <- xs ]-           in   build rationalView (product cs):rest+ where  +   f []                    = []+   f ((Nothing  , e):xs)   = e:f xs+   f ((Just r   , _):xs)   = +      let cs   = r : [ c | (Just c, _) <- xs ]+          rest = [ x | (Nothing, x) <- xs ]+      in build rationalView (product cs):rest  mergeAlikeSum :: [Expr] -> [Expr] mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ]@@ -198,10 +221,10 @@                Nothing -> (r, e)        rec [] = []-   rec ((Nothing, e):xs) = e:rec xs-   rec ((Just (r, a), e):xs) = new:rec rest+   rec ((Nothing, e):ys) = e:rec ys+   rec ((Just (r, a), e):ys) = new:rec rest     where-      (js, rest) = partition (maybe False ((==a) . snd) . fst) xs+      (js, rest) = partition (maybe False ((==a) . snd) . fst) ys       rs  = r:map fst (mapMaybe fst js)       new | null js   = e           | otherwise = build rationalView (sum rs) .*. a
src/Domain/Math/SquareRoot/Tests.hs view
@@ -15,12 +15,12 @@ import Test.QuickCheck import Domain.Math.Data.SquareRoot import Domain.Math.Numeric.Laws-import Common.Utils ()+import Common.TestSuite  ------------------------------------------------------------------- -- Testing  -tests :: IO ()+tests :: TestSuite tests =     testNumLaws  "square roots" squareRootGen    -- 	testFracLaws "square roots" squareRootGen
src/Domain/Math/SquareRoot/Views.hs view
@@ -34,7 +34,7 @@          a :*: b  -> liftM2 (*) (f a) (f b)          a :/: b  -> join $ liftM2 fracDiv (f a) (f b)          Sqrt a   -> fmap sqrtRational (match rationalView a)-         Sym s [a, b] | s == powerSymbol ->+         Sym s [a, b] | isPowerSymbol s ->             liftM2 (^) (f a) (match integerView b)          _ -> fmap con (match v expr)
− src/Domain/RegularExpr/Definitions.hs 
@@ -1,70 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Domain.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 
@@ -1,75 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Domain.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 
@@ -1,175 +0,0 @@-{-# 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 
@@ -1,39 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Domain.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 
@@ -1,100 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module Domain.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
@@ -30,7 +30,7 @@ import Test.QuickCheck 
 import System.Random
 import Data.List
-import Common.Apply
+import Common.Classes
 import Common.Context 
 import Control.Monad
− src/Domain/RelationAlgebra/Equivalence.hs 
@@ -1,189 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Equivalence (isEquivalent) where
-
-import Data.List
-import Data.Maybe
-import Domain.RelationAlgebra.Formula
-import Common.Apply
-import Common.Context
-import Domain.RelationAlgebra.Strategies
-{-
-infixr 1 :.:
-infixr 2 :+: 
-infixr 3 :||: 
-infixr 4 :&&:
--}
-{-
--- | The data type RelAlg is the abstract syntax for the domain
--- | of logic expressions.
-data RelAlg = Var String
-            | RelAlg :.:  RelAlg           -- composition
-            | RelAlg :+: RelAlg            -- relative addition
-            | RelAlg :&&:  RelAlg          -- and (conjunction)
-            | RelAlg :||:  RelAlg          -- or (disjunction)
-            | Not RelAlg                   -- not
-            | Inv RelAlg                   -- inverse
-            | U                            -- universe
-            | E                            -- empty
- deriving (Show, Eq, Ord)
-
--------------------------------------
-
-
-isAtom :: RelAlg -> Bool
-isAtom  r = 
-    case r of
-      Var x             -> True
-      Not (Var x)       -> True
-      Inv (Var x)       -> True
-      Not (Inv (Var x)) -> True
-      U                 -> True
-      E                 -> True
-      otherwise         -> False
- 
-isMolecule :: RelAlg -> Bool
-isMolecule (r :.: s) = isMolecule r && isMolecule s
-isMolecule (r :+: s) = isMolecule r && isMolecule s
-isMolecule r = isAtom r
- 
-isDisj :: RelAlg -> Bool
-isDisj (r :||: s) = isDisj r && isDisj s
-isDisj r = isMolecule r
-      
-isCNF :: RelAlg -> Bool
-isCNF (r :&&: s) = isCNF r && isCNF s
-isCNF r = isDisj r
--}
--- | maak er een cnf van
-isEquivalent :: RelAlg -> RelAlg -> Bool
-isEquivalent x1 x2 = 
-    let res1           =  fromContext (applyD toCNF (inContext x1))  -- cnf van x1
-        res2           =  fromContext (applyD toCNF (inContext x2)) -- cnf van x2
-        mols           =  union (getSetOfMolecules res1) (getSetOfMolecules res2) 
-        (rs, r1, r2)   =  remCompls mols res1 res2  
-        vals           =  createValuations rs
-    in all (\ v -> evalFormula r1 v == evalFormula r2 v) vals
-{-
--- | zet 'm in cnf
-solve (Inv (Inv (Not (Var "p")) :+: Not (Var "q"))) = Not (Var "p") :+: Not (Inv (Var "q"))
-solve (Not (Not (Var "p") :+: Not (Inv (Var "q")))) = undefined
-solve (Not (Inv (Inv (Not (Var "p")) :+: Not (Var "q")))) = undefined
-solve (Not (Var "p" :.: Inv (Var "q"))) = Inv (Inv (Not (Var "p")) :+: Not (Var "q"))
-solve x = x
--}
-
-{-
-ra1 = Var "a" :||: (Var "p" :.: Inv (Var "q"))
-ra2 = Var "a" :||: (Inv (Inv (Not (Var "p")) :+: Not (Var "q")))
-
-fa1 = Inv (Var "r" :+: Var "s")
-fa2 = Inv (Var "s") :+: Inv (Var "r")
--}
-
-{-
-mols = union (getSetOfMolecules ra1) (getSetOfMolecules ra2) 
-triple@(t1, t2, t3) = remCompls mols ra1 ra2
-vs = createValuations t1
-bb = and (map (\v -> evalFormula ra1 v == evalFormula ra2 v) vs)
--}
-remCompls :: [RelAlg] -> RelAlg -> RelAlg -> ([RelAlg], RelAlg, RelAlg)
-remCompls rs r1 r2 = 
-     let complements = searchForComplements rs
-         -- sub = [ (r1, Not r2) | (r1, r2) <- complements ]
-     in ( removeCompls rs complements
-        , substCompls  r1 complements
-        , substCompls  r2 complements
-        )
-
--- |
-substCompls ::  RelAlg -> [(RelAlg, RelAlg)] -> RelAlg
-substCompls = foldl subst
-
-
-
-subst :: RelAlg -> (RelAlg, RelAlg) -> RelAlg
-subst r (r1, r2) =
-   case r of
-       p :&&: q  ->  subst p (r1, r2) :&&: subst q (r1, r2)
-       p :||: q  ->  subst p (r1, r2) :||: subst q (r1, r2)
-       _         ->  if r == r1
-                     then Not r2
-                     else r   
-
-
-removeCompls :: [RelAlg] -> [(RelAlg, RelAlg)] -> [RelAlg]
-removeCompls xs ys     = [ x | x <- xs, notElem x (map snd ys)]
-
--- | Search for complements 
-searchForComplements ::[RelAlg] -> [(RelAlg, RelAlg)] 
-searchForComplements []     = []  
-searchForComplements (x:xs) = [(x,z) | z <- xs, isComplement x z] ++ searchForComplements xs    
-
-isComplement :: RelAlg -> RelAlg -> Bool
-isComplement = (==) . fromContext . applyD toCNF . inContext . Not
-
--- FIXME: what should we do with the identity relation?
-evalFormula :: RelAlg -> [(RelAlg, Bool)] -> Bool
-evalFormula f val =
-   case lookup f val of
-      Just b  -> b
-      Nothing ->
-         case f of
-            f1 :&&: f2  -> evalFormula f1 val && evalFormula f2 val
-            f1 :||: f2  -> evalFormula f1 val || evalFormula f2 val
-            Not f       -> not (evalFormula f val)
-            V           -> True
-            E           -> False
-            x           -> let value = lookup x val
-                           in if value == Nothing
-                              then error $ "evalFormula: molecule not in valuation  " ++ show (f, val)
-                              else fromJust value 
-            
-            
-
-          
-
-
--- | Get the set of molecules of an expression in CNF as list. 
-getSetOfMolecules :: RelAlg -> [RelAlg]
-getSetOfMolecules = nub . getMolecules 
-  where
-  getMolecules :: RelAlg -> [RelAlg]
-  getMolecules expr =
-    case expr of
-       p :&&: q  ->  getMolecules p ++ getMolecules q
-       p :||: q  ->  getMolecules p ++ getMolecules q
-       Not p     ->  getMolecules p
-       V         ->  []
-       E         ->  []
-       I         ->  []
-       p         ->  [p] 
-
- 
-{-------------------------------------------------------------------
- Given a varList, for example [x,y], function createValuations
- creates all valuations:
- [[(x,0),(y,0)],[(x,0),(y,1)],[(x,1),(y,0)],[(x,1),(y,1)]],
- where (x,0) means: variable x equals 0.
---------------------------------------------------------------------} 
-
-type Molecule   =   RelAlg
--- type Valuation  =  (RelAlg, Bool)
-
-
-createValuations :: [a] -> [[(a, Bool)]]
-createValuations = foldr op [[]]
- where op a vs = [ (a, b):v | v <- vs, b <- [True, False] ]
-
-prop :: RelAlg -> RelAlg -> Bool
-prop p q = isEquivalent p q == probablyEqual p q
src/Domain/RelationAlgebra/Exercises.hs view
@@ -17,7 +17,7 @@ import Domain.RelationAlgebra.Strategies
 import Domain.RelationAlgebra.Rules
 import Domain.RelationAlgebra.Parser
-import Common.Apply
+import Common.Classes
 import Common.Exercise
 import Common.Context
 import Data.Maybe
@@ -29,8 +29,8 @@ 
 cnfExercise :: Exercise RelAlg
 cnfExercise = testableExercise
-   { description    = "To conjunctive normal form"
-   , exerciseCode   = makeCode "relationalg" "cnf"
+   { exerciseId     = describe "To conjunctive normal form" $
+                         newId "relationalgebra.cnf"
    , status         = Alpha
    , parser         = parseRelAlg
    , prettyPrinter  = ppRelAlg
src/Domain/RelationAlgebra/Formula.hs view
@@ -11,16 +11,15 @@ -----------------------------------------------------------------------------
 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.List
 import qualified Data.Set as S
-import System.Random (StdGen, mkStdGen, split)
+import System.Random (StdGen, mkStdGen, split, randomR)
 import Test.QuickCheck
+import Test.QuickCheck.Gen
 
 infixr 2 :.:
 infixr 3 :+: 
@@ -79,7 +78,7 @@ 
 -- | foldRelAlg is the standard folfd for RelAlg.
 foldRelAlg :: RelAlgAlgebra a -> RelAlg -> a
-foldRelAlg (var, comp, add, conj, disj, not, inverse, universe, ident) = rec
+foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) = rec
  where
    rec term =
       case term of
@@ -88,26 +87,27 @@          p :+: q   -> rec p `add`  rec q
          p :&&: q  -> rec p `conj` rec q
          p :||: q  -> rec p `disj` rec q
-         Not p     -> not (rec p)
-         Inv p           -> inverse (rec p)
-         V         -> universe 
+         Not p     -> neg (rec p)
+         Inv p     -> inv (rec p)
+         V         -> univ 
          I         -> ident
 
 type Relation a = S.Set (a, a)
 
 evalRelAlg :: Ord a => (String -> Relation a) -> [a] -> RelAlg -> Relation a
-evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, not, inverse, universe, ident) 
+evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) 
  where
    pairs = cartesian as as
+   
    comp p q = let f (a1, a2) c = (a1, c) `S.member` p && (c, a2) `S.member` q
               in S.fromAscList [ x | x <- pairs, any (f x) as ] 
    add p q  = let f (a1, a2) c = (a1, c) `S.member` p || (c, a2) `S.member` q
               in S.fromAscList [ x | x <- pairs, all (f x) as ] 
    conj     = S.intersection
    disj     = S.union
-   not p    = S.fromAscList [ x | x <- pairs, x `S.notMember` p ]
-   inverse  = S.map (\(x, y) -> (y, x))
-   universe = S.fromAscList pairs
+   neg p    = S.fromAscList [ x | x <- pairs, x `S.notMember` p ]
+   inv      = S.map (\(x, y) -> (y, x))
+   univ     = S.fromAscList pairs
    ident    = S.fromAscList [ (x, x) | x <- as ]
 
 -- | Try to find a counter-example showing that the two formulas are not equivalent.
@@ -118,16 +118,17 @@ probablyEqualWith rng p q = all (\i -> eval i p == eval i q) (makeRngs 50 rng)
  where
    -- size of (co-)domain
-   as     = [0..1]
+   as :: [Int]
+   as = [0..1]
    -- number of attemps (with different randomly generated relations)
+   makeRngs :: Int -> StdGen -> [StdGen]
    makeRngs n g
       | n == 0    = []
       | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2
-   eval g = evalRelAlg (generate 100 g (arbRelations as)) as
-
-inspect :: [Int]
-inspect = map f [1..100]
- where f i = S.size $ generate 100 (mkStdGen i) (arbRelations [0..9]) "p"
+   eval g = 
+      let MkGen f   = arbRelations as
+          (size, a) = randomR (0, 100) g
+      in evalRelAlg (f a size) as
 
 arbRelations :: Eq a => [a] -> Gen (String -> Relation a)
 arbRelations as = promote (\s -> coarbitrary s (arbRelation as))
@@ -168,42 +169,44 @@          Not s     -> ([s], \[a] -> Not a)
          Inv s     -> ([s], \[a] -> Inv a)
          _         -> ([], \[] -> term)
-
-instance ShallowEq RelAlg where
-   shallowEq expr1 expr2 = 
-      case (expr1, expr2) of
-         (Var a   , Var b   ) -> a==b
-         (_ :.: _ , _ :.: _ ) -> True
-         (_ :+: _ , _ :+: _ ) -> True
-         (_ :&&: _, _ :&&: _) -> True
-         (_ :||: _, _ :||: _) -> True
-         (Not _   , Not _   ) -> True
-         (Inv _   , Inv _   ) -> True
-         (V       , V       ) -> True
-         (I       , I       ) -> True
-         _                    -> False
          
 instance Different RelAlg where
    different = (V, I)
-   
+   --(var, comp, add, conj, disj, not, inverse, universe, ident)
 instance IsTerm RelAlg where
    toTerm = foldRelAlg 
-      ( variable, binary ".", binary "+", binary "&&", binary "||"
-      , unary "~", unary "-", nullary "V", nullary "I"
+      ( variable, binary compSymbol, binary addSymbol
+      , binary conjSymbol
+      , binary disjSymbol, unary notSymbol, unary invSymbol
+      , symbol universeSymbol, symbol identSymbol
       )
 
    fromTerm a = 
       fromTermWith f a `mplus` liftM Var (getVariable a)
     where
       f s []
-         | s == "V"  = return V
-         | s == "I"  = return I
+         | s == universeSymbol  = return V
+         | s == identSymbol     = return I
       f s [x]
-         | s == "~"  = return (Not x)
-         | s == "-"  = return (Inv x)
+         | s == notSymbol       = return (Not x)
+         | s == invSymbol       = 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"+         | s == compSymbol      = return (x :.:  y)
+         | s == addSymbol       = return (x :+:  y)
+         | s == conjSymbol      = return (x :&&: y)
+         | s == disjSymbol      = return (x :||: y)
+      f _ _ = fail "fromTerm"
+      
+compSymbol, addSymbol, conjSymbol, disjSymbol,
+   notSymbol, invSymbol, universeSymbol, identSymbol :: Symbol
+compSymbol     = relalgSymbol "comp"
+addSymbol      = relalgSymbol "add"
+conjSymbol     = relalgSymbol "conj"
+disjSymbol     = relalgSymbol "disj"
+notSymbol      = relalgSymbol "not"
+invSymbol      = relalgSymbol "inv"
+universeSymbol = relalgSymbol "universe"
+identSymbol    = relalgSymbol "ident"
+
+relalgSymbol :: String -> Symbol
+relalgSymbol a = newSymbol ["relalg", a]
src/Domain/RelationAlgebra/Generator.hs view
@@ -23,18 +23,18 @@ instance CoArbitrary RelAlg where
    coarbitrary term =
       case term of
-         Var x    -> variant 0 . coarbitrary 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       
-         p :||: q -> variant 4 . coarbitrary p . coarbitrary q       
-         Not p    -> variant 5 . coarbitrary p
-         Inv p    -> variant 6 . coarbitrary p  
-         V        -> variant 7        
-         I        -> variant 8
+         Var x    -> variant (0 :: Int) . coarbitrary x
+         p :.:  q -> variant (1 :: Int) . coarbitrary p . coarbitrary q
+         p :+:  q -> variant (2 :: Int) . coarbitrary p . coarbitrary q       
+         p :&&: q -> variant (3 :: Int) . coarbitrary p . coarbitrary q       
+         p :||: q -> variant (4 :: Int) . coarbitrary p . coarbitrary q       
+         Not p    -> variant (5 :: Int) . coarbitrary p
+         Inv p    -> variant (6 :: Int) . coarbitrary p  
+         V        -> variant (7 :: Int)        
+         I        -> variant (8 :: Int)
    
 arbRelAlg :: Int -> Gen RelAlg
-arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return vars)), (1, return V), (1, return empty), (1, return I)]
+arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)]
 arbRelAlg n = oneof [ arbRelAlg 0, binop (:.:), binop (:+:), binop (:&&:), binop (:||:)
                     , unop Not, unop Inv 
                     ]
@@ -43,12 +43,18 @@    unop op  = liftM op rec
    rec      = arbRelAlg (n `div` 2)  
 
-vars :: [String]
-vars = ["q", "r", "s"]
+relAlgVars :: [String]
+relAlgVars = ["q", "r", "s"]
   
 -------------------------------------------------------------------
 -- Templates
 
+template1, template2, template3, template4, template7, template8 :: 
+   RelAlg -> RelAlg -> RelAlg -> RelAlg
+
+template5 :: RelAlg -> RelAlg -> RelAlg -> RelAlg -> RelAlg
+template6 :: Maybe RelAlg -> RelAlg -> RelAlg -> Maybe RelAlg -> RelAlg
+
 template1 x y z = x :||: (y :&&: z)
 template2 x y z = Not(x :&&: (y :||: z))
 template3 x y z = Inv(x :||: (y :&&: z))
@@ -77,7 +83,10 @@ gen8 = use3 template2 arbInvNotMol hulpgen1 arbInvNotMol
 gen9 = use3 template8 hulpgen2 arbInvNotMol arbInvNotMol
 
+use3 :: (a -> b -> c -> d) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> t -> Gen d
 use3 temp f g h   n = liftM3 temp (f n) (g n) (h n)
+     
+use4 :: (a -> b -> c -> d -> e) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> (t -> Gen d) -> t -> Gen e
 use4 temp f g h k n = liftM4 temp (f n) (g n) (h n) (k n)
 
 hulpgen1 :: Int -> Gen RelAlg
@@ -87,7 +96,7 @@ hulpgen2 n = liftM3 template7 (arbInvNotMol 1) (arbRelAlg n) (arbRelAlg n)
 
 arbInvNotMol :: Int -> Gen RelAlg
-arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return vars)), (1, return V), (1, return empty), (1, return I)]
+arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)]
 arbInvNotMol n = frequency [ (10, arbInvNotMol 0), (4, binop (:.:)), (4, binop (:+:)), (2, unop Not), (2, unop Inv) ]
  where
    binop op = liftM2 op rec rec
@@ -98,4 +107,4 @@ arbMaybeInvNotMol n = frequency [(3, liftM Just (arbInvNotMol n)), (1, return Nothing)]
 
 arbVar :: Gen RelAlg
-arbVar = liftM Var (oneof $ map return vars)+arbVar = liftM Var (oneof $ map return relAlgVars)
src/Domain/RelationAlgebra/Parser.hs view
@@ -28,6 +28,7 @@    , (NoMix,            [(compSym, (:.:)), (addSym, (:+:))])
    ]
 
+andSym, orSym, addSym, compSym, notSym, invSym :: String
 andSym  = "/\\"
 orSym   = "\\/" 
 addSym  = "!"
@@ -77,8 +78,11 @@ ppRelAlg = ppRelAlgPrio (0, "")
 
 ppRelAlgPrio :: (Int, String) -> RelAlg -> String 
-ppRelAlgPrio n p = foldRelAlg (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/", nott, inv, var "V", var "I") p n ""
+ppRelAlgPrio = (\f n -> f n "") . flip (foldRelAlg alg)
  where
+   alg = (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/"
+         , nott, inv, var "V", var "I"
+         ) 
    binop prio op p q (n, parent) = 
       parIf (n > prio || (prio==4 && n==4 && op/=parent)) (p (prio+1, op) . ((" "++op++" ")++) . q (prio, op))
    var       = const . (++)
src/Domain/RelationAlgebra/Rules.hs view
@@ -13,8 +13,10 @@ 
 import Domain.RelationAlgebra.Formula
 import Domain.RelationAlgebra.Generator()
-import Common.Transformation
+import Common.Id
+import Common.Transformation (Rule, addRuleToGroup, buggyRule)
 import Common.Rewriting
+import qualified Common.Transformation as Rule
 
 invRules :: [Rule RelAlg]
 invRules = [ ruleInvOverUnion, ruleInvOverIntersec, ruleInvOverComp
@@ -38,10 +40,21 @@                    , buggyRuleAssoc, buggyRuleInvOverComp, buggyRuleInvOverAdd
                    , buggyRuleCompOverIntersec, buggyRuleAddOverUnion, buggyRuleRemCompl
                    ]
+
+relalg :: IsId a => a -> Id
+relalg = (#) "relationalgebra"
+
+rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+rule = Rule.rule . relalg
+
+ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+ruleList = Rule.ruleList . relalg
                    
 -- | 1. Alle ~ operatoren naar binnen verplaatsen
 
-conversionGroup s =  addRuleToGroup "Conversion" . rule s
+conversionGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+conversionGroup s = 
+   addRuleToGroup (relalg "Conversion") . rule s
 
 ruleInvOverUnion :: Rule RelAlg
 ruleInvOverUnion = conversionGroup "InvOverUnion" $ 
@@ -71,8 +84,9 @@ 
 
 -- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen 
-
-distributionGroup s =  addRuleToGroup "Distribution" . ruleList s
+distributionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+distributionGroup s = 
+   addRuleToGroup (relalg "Distribution") . ruleList s
 
 ruleCompOverUnion :: Rule RelAlg
 ruleCompOverUnion = distributionGroup "CompOverUnion" 
@@ -106,7 +120,9 @@ 
 -- | 4. De Morgan rules
 
-deMorganGroup s = addRuleToGroup "DeMorgan" . rule s
+deMorganGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+deMorganGroup s = 
+   addRuleToGroup (relalg "DeMorgan") . rule s
 
 ruleDeMorganOr :: Rule RelAlg
 ruleDeMorganOr = deMorganGroup "DeMorganOr" $
@@ -118,7 +134,9 @@ 
 -- | 5. Idempotency
 
-idempotencyGroup s = addRuleToGroup "Idempotency" . rule s
+idempotencyGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+idempotencyGroup s = 
+   addRuleToGroup (relalg "Idempotency") . rule s
 
 ruleIdempOr :: Rule RelAlg
 ruleIdempOr = idempotencyGroup "IdempotencyOr" $
@@ -130,7 +148,9 @@ 
 -- | 6. Complement
 
-complementGroup s = addRuleToGroup "Complement" . ruleList s
+complementGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+complementGroup s = 
+   addRuleToGroup (relalg "Complement") . ruleList s
 
 ruleDoubleNegation :: Rule RelAlg
 ruleDoubleNegation = complementGroup "DoubleNegation"
@@ -159,7 +179,9 @@   
 -- | 7. Absorption complement
 
-absorptionGroup s = addRuleToGroup "Absorption" . ruleList s
+absorptionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+absorptionGroup s = 
+   addRuleToGroup (relalg "Absorption") . ruleList s
 
 ruleAbsorpCompl :: Rule RelAlg
 ruleAbsorpCompl = absorptionGroup "AbsorpCompl" 
@@ -187,7 +209,9 @@ 
 -- | 8. Remove redundant expressions
 
-simplificationGroup s = addRuleToGroup "Simplification" . ruleList s
+simplificationGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+simplificationGroup s = 
+   addRuleToGroup (relalg "Simplification") . ruleList s
 
 ruleRemRedunExprs :: Rule RelAlg
 ruleRemRedunExprs = simplificationGroup "RemRedunExprs"  
@@ -220,7 +244,9 @@       
 -- Buggy rules:
 
-buggyGroup s = addRuleToGroup "Buggy" . buggyRule . ruleList s
+buggyGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+buggyGroup s = addRuleToGroup (relalg "Buggy") . buggyRule 
+             . Rule.ruleList ("relationalgebra.buggy." ++ s)
     
 buggyRuleIdemComp :: Rule RelAlg
 buggyRuleIdemComp = buggyGroup "IdemComp" 
@@ -233,7 +259,7 @@    ]
 
 buggyRuleDeMorgan :: Rule RelAlg
-buggyRuleDeMorgan = buggyGroup "BuggyDeMorgan" 
+buggyRuleDeMorgan = buggyGroup "DeMorgan" 
     [ \q r -> Not (q :&&: r) :~> Not q :||: r
     , \q r -> Not (q :&&: r) :~> q :||: Not r
     , \q r -> Not (q :&&: r) :~> Not (Not q :||: Not r)
@@ -243,7 +269,7 @@     ]
     
 buggyRuleNotOverAdd :: Rule RelAlg
-buggyRuleNotOverAdd = buggyGroup "BuggyNotOverAdd" 
+buggyRuleNotOverAdd = buggyGroup "NotOverAdd" 
      [ \q r -> Not (q :+: r) :~> Not q :+: Not r
      , \q r -> Not (q :+: r) :~> Not q :.: r
      , \q r -> Not (q :+: r) :~> Not q :+: r
@@ -251,7 +277,7 @@      ]
      
 buggyRuleNotOverComp :: Rule RelAlg
-buggyRuleNotOverComp = buggyGroup "BuggyNotOverComp" 
+buggyRuleNotOverComp = buggyGroup "NotOverComp" 
      [ \q r -> Not (q :.: r) :~> Not q :.: Not r
      , \q r -> Not (q :.: r) :~> Not q :.: r
      , \q r -> Not (q :.: r) :~> Not q :+: r
@@ -259,7 +285,7 @@      ]
      
 buggyRuleParenth :: Rule RelAlg
-buggyRuleParenth = buggyGroup "BuggyParenth" 
+buggyRuleParenth = buggyGroup "Parenth" 
     [ \q r -> Not (q :&&: r)     :~> Not q :&&: r
     , \q r -> Not (q :||: r)     :~> Not q :||: r
     , \q r -> Not (Not q :&&: r) :~> q :&&: r 
@@ -275,7 +301,7 @@     ]
     
 buggyRuleAssoc :: Rule RelAlg
-buggyRuleAssoc = buggyGroup "BuggyAssoc"  
+buggyRuleAssoc = buggyGroup "Assoc"  
     [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: s
     , \q r s -> (q :||: r) :&&: s :~> q :||: (r :&&: s)
     , \q r s -> (q :&&: r) :||: s :~> q :&&: (r :||: s)
@@ -291,28 +317,28 @@     ]
 
 buggyRuleInvOverComp :: Rule RelAlg
-buggyRuleInvOverComp = buggyGroup "BuggyInvOverComp"
+buggyRuleInvOverComp = buggyGroup "InvOverComp"
    [ \r s -> Inv (r :.: s) :~> Inv r :.: Inv s
    ]
 
 buggyRuleInvOverAdd :: Rule RelAlg
-buggyRuleInvOverAdd = buggyGroup "BuggyInvOverAdd"
+buggyRuleInvOverAdd = buggyGroup "InvOverAdd"
    [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s
    ]
    
 buggyRuleCompOverIntersec :: Rule RelAlg
-buggyRuleCompOverIntersec = buggyGroup "BuggyCompOverIntersec" 
+buggyRuleCompOverIntersec = buggyGroup "CompOverIntersec" 
    [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s)  --alleen toegestaan als q een functie is!
    , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s)  --idem
    ]
 buggyRuleAddOverUnion :: Rule RelAlg
-buggyRuleAddOverUnion = buggyGroup "BuggyAddOverUnion" 
+buggyRuleAddOverUnion = buggyGroup "AddOverUnion" 
    [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is!
    , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem
    ]
    
 buggyRuleRemCompl :: Rule RelAlg
-buggyRuleRemCompl = buggyGroup "BuggyRemCompl" 
+buggyRuleRemCompl = buggyGroup "RemCompl" 
    [ \r -> r :&&: Not r :~> V
    , \r -> Not r :&&: r :~> V
    , \r -> r :||: Not r :~> empty
src/Main.hs view
@@ -19,7 +19,7 @@ import Data.IORef
 import Data.Time
 import Documentation.Make
-import Main.ExerciseList
+import Main.IDEAS
 import Main.LoggingDatabase
 import Main.Options
 import Network.CGI
@@ -48,7 +48,8 @@       -- documentation mode
       _ | documentationMode flags -> 
              useIDEAS $ 
-         mapM_ makeDocumentation (docItems flags)
+                let f = makeDocumentation (docDir flags) (testDir flags)
+                in mapM_ f (docItems flags)
 
       -- cgi binary
       Nothing -> runCGI $ do
− src/Main/ExerciseList.hs 
@@ -1,100 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)----------------------------------------------------------------------------------module 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/IDEAS.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Main.IDEAS (useIDEAS) where++import Common.Rewriting+import Common.Utils (Some(..), fromShowString)+import Main.Options+import Service.DomainReasoner+import Service.ExercisePackage+import Service.ServiceList+import qualified Domain.LinearAlgebra as LA+import qualified Domain.LinearAlgebra.Checks as LA+import qualified Domain.Logic as Logic+import qualified Domain.Logic.FeedbackText as Logic+import qualified Domain.Math.Expr as Math+import qualified Domain.Math.Data.Interval as MathInterval+import qualified Domain.Math.Derivative.Exercises as Math+import qualified Domain.Math.Equation.CoverUpExercise as Math+import qualified Domain.Math.Numeric.Exercises as Math+import qualified Domain.Math.Numeric.Tests as MathNum+import qualified Domain.Math.Polynomial.Exercises as Math+import qualified Domain.Math.Polynomial.IneqExercises as Math+import qualified Domain.Math.Polynomial.RationalExercises as Math+import qualified Domain.Math.Polynomial.Tests as MathPoly+import qualified Domain.Math.Power.Exercises as Math+import qualified Domain.Math.Power.Equation.Exercises as Math+import qualified Domain.Math.SquareRoot.Tests as MathSqrt+import qualified Domain.Math.Polynomial.LeastCommonMultiple as MathLCM+-- import qualified Domain.RegularExpr.Exercises as RE+import qualified Domain.RelationAlgebra as RA++useIDEAS :: DomainReasoner a -> IO a+useIDEAS action = runDomainReasoner $ do+   -- version information+   setVersion     shortVersion+   setFullVersion fullVersion+   -- exercise packages+   addPackages    packages+   -- services+   addServices    serviceList+   addPkgService  exerciselistS+   -- domain checks+   addTestSuite $ do+      MathNum.main+      MathPoly.tests+      MathSqrt.tests+      MathInterval.testMe+      MathLCM.testLCM+      LA.checks+   -- do the rest+   action++packages :: [Some ExercisePackage]+packages =+   [ -- logic and relation-algebra+     Some (package Logic.dnfExercise)+        { withOpenMath    = True+        , toOpenMath      = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString)+        , fromOpenMath    = (>>= fromTerm) . omobjToTerm+        , getExerciseText = Just logicText+        }+   , Some (package Logic.dnfUnicodeExercise)+        { withOpenMath    = True+        , toOpenMath      = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString)+        , fromOpenMath    = (>>= fromTerm) . omobjToTerm+        , getExerciseText = Just logicText+        }+   -- , somePackage Logic.proofExercise+   , somePackage RA.cnfExercise+     -- basic math+   -- , someTermPackage Math.naturalExercise+   -- , someTermPackage Math.integerExercise+   -- , someTermPackage Math.rationalExercise+   , someTermPackage Math.fractionExercise+   , someTermPackage Math.coverUpExercise+   , someTermPackage Math.linearExercise+   , someTermPackage Math.linearMixedExercise+   , someTermPackage Math.quadraticExercise+   , someTermPackage Math.higherDegreeExercise+   , someTermPackage Math.findFactorsExercise+   , someTermPackage Math.ineqLinearExercise+   , someTermPackage Math.ineqQuadraticExercise+   , someTermPackage Math.ineqHigherDegreeExercise+   , someTermPackage Math.rationalEquationExercise+   , someTermPackage Math.simplifyRationalExercise+   -- , someTermPackage Math.divisionBrokenExercise+   , someTermPackage Math.quadraticNoABCExercise+   , someTermPackage Math.quadraticWithApproximation+   , someTermPackage Math.derivativeExercise+   , someTermPackage Math.derivativePolyExercise+   , someTermPackage Math.derivativeProductExercise+   , someTermPackage Math.derivativeQuotientExercise+   -- , someTermPackage Math.derivativePowerExercise+   , someTermPackage Math.simplifyPowerExercise+   , someTermPackage Math.powerOfExercise     +   , someTermPackage Math.nonNegBrokenExpExercise+   , someTermPackage Math.calcPowerExercise+   , someTermPackage Math.powerEqExercise+   , someTermPackage Math.expEqExercise+   , someTermPackage Math.logEqExercise+     -- linear algebra+   , someTermPackage LA.gramSchmidtExercise+   , someTermPackage LA.linearSystemExercise+   , someTermPackage LA.gaussianElimExercise+   , someTermPackage LA.systemWithMatrixExercise+     -- regular expressions+   -- , somePackage RE.regexpExercise+   ]+   +logicText :: ExerciseText Logic.SLogic+logicText = ExerciseText+   { ruleText              = Logic.ruleText+   , appliedRule           = Logic.appliedRule+   , feedbackSyntaxError   = Logic.feedbackSyntaxError+   , feedbackSame          = Logic.feedbackSame+   , feedbackBuggy         = Logic.feedbackBuggy+   , feedbackNotEquivalent = Logic.feedbackNotEquivalent+   , feedbackOk            = Logic.feedbackOk+   , feedbackDetour        = Logic.feedbackDetour+   , feedbackUnknown       = Logic.feedbackUnknown+   }
src/Main/LoggingDatabase.hs view
@@ -41,7 +41,7 @@      -- insert data into database
      run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" 
              [ toSql $ service req
-             , toSql $ maybe "unknown" show (exerciseID req)
+             , toSql $ maybe "unknown" show (exerciseId req)
              , toSql $ fromMaybe "unknown" (source req)
              , toSql $ show (dataformat req)
              , toSql $ maybe "unknown" show (encoding req)
@@ -60,7 +60,7 @@ {-
 -- | Log table schema
 createStmt =  "CREATE TABLE log ( service      VARCHAR(250)"
-           ++                  ", exerciseID   VARCHAR(250)"
+           ++                  ", exerciseId   VARCHAR(250)"
            ++                  ", source       VARCHAR(250)"
            ++                  ", dataformat   VARCHAR(250)"
            ++                  ", encoding     VARCHAR(250)"
src/Main/Options.hs view
@@ -13,7 +13,6 @@ -----------------------------------------------------------------------------
 module Main.Options where
 
-import Data.Maybe
 import Documentation.Make
 import Main.LoggingDatabase (logEnabled)
 import Main.Revision
@@ -22,7 +21,7 @@ import System.Exit
 
 data Flag = Version | Help | Logging Bool | InputFile String 
-          | FixRNG | DocItem DocItem
+          | FixRNG | DocItem DocItem | DocDir String | TestDir String
    deriving Eq
 
 header :: String
@@ -47,19 +46,21 @@ 
 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"
+     [ Option []  ["version"]    (NoArg Version)              "show version number"
+     , Option "?" ["help"]       (NoArg Help)                 "show options"
+     , Option "l" ["logging"]    (NoArg $ Logging True)       "enable logging"
+     , Option []  ["no-logging"] (NoArg $ Logging False)      "disable logging (default on local machine)"
+     , Option "f" ["file"]       (ReqArg InputFile "FILE")    "use input FILE as request"
+     , Option ""  ["fixed-rng"]  (NoArg FixRNG)               "use a fixed random-number generator"
+     , Option ""  ["make-pages"] (NoArg $ DocItem Pages)      "generate pages for exercises and services"
+     , Option ""  ["self-check"] (NoArg $ DocItem SelfCheck)  "perform a self-check"
+     , Option ""  ["test"]       (OptArg testArg "DIR")       "run tests on directory (default: 'test')"
+     , Option ""  ["docs-dir"]   (ReqArg DocDir "DIR")        "directory for documentation (default: 'docs')" 
+     , Option ""  ["test-dir"]   (ReqArg TestDir "DIR")       "directory with tests (default: 'test')"
      ]
 
-docItemDescr :: (Maybe String -> DocItem) -> ArgDescr Flag
-docItemDescr f = OptArg (DocItem . f) "DIR"
+testArg :: Maybe String -> Flag
+testArg = DocItem . BlackBox
 
 serviceOptions :: IO [Flag]
 serviceOptions = do
@@ -77,6 +78,16 @@ 
 docItems :: [Flag] -> [DocItem]
 docItems flags = [ x | DocItem x <- flags ]
+
+docDir :: [Flag] -> String
+docDir flags = case [ d | DocDir d <- flags ] of
+                  d:_ -> d
+                  _   -> "docs"
+
+testDir :: [Flag] -> String
+testDir flags = case [ d | TestDir d <- flags ] of
+                  d:_ -> d
+                  _   -> "test"
 
 documentationMode :: [Flag] -> Bool
 documentationMode = not . null . docItems
src/Main/Revision.hs view
@@ -1,5 +1,8 @@ -- Automatically generated by Makefile.  Do not change. module Main.Revision where-version = "0.6"-revision = 3065-lastChanged = "ma, 19 apr 2010"+version :: String+version = "0.7"+revision :: Int+revision = 3724+lastChanged :: String +lastChanged = "do, 23 dec 2010"
+ src/Service/BasicServices.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Service.BasicServices 
+   ( -- * Basic Services
+     stepsremaining, findbuggyrules, ready, allfirsts, derivation
+   , onefirst, applicable, allapplications, apply, generate, generateWith
+   ) where
+
+import Common.Library hiding (derivation, applicable, apply)
+import Common.Utils (safeHead)
+import Data.List
+import Data.Maybe
+import System.Random (StdGen, newStdGen)
+import Control.Monad
+import Service.ExercisePackage
+import Service.State
+import qualified Common.Classes as Apply
+      
+-- result must be in the IO monad to access a standard random number generator
+generate :: ExercisePackage a -> Int -> IO (State a)
+generate pkg level = do 
+   stdgen <- newStdGen
+   return (generateWith stdgen pkg level)
+
+generateWith :: StdGen -> ExercisePackage a -> Int -> State a
+generateWith rng pkg level = 
+   emptyState pkg (randomTermWith rng level (exercise pkg))
+
+derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)]
+derivation mcfg state =
+   case (statePrefix 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 newStrategy = configure cfg (strategy ex)
+             newExercise = ex {strategy = newStrategy}
+             newPackage  = pkg {exercise = newExercise}
+         in rec timeout [] (empyStateContext newPackage (stateContext state))
+      _ -> rec timeout [] state
+ where
+   pkg = exercisePkg state
+   ex  = exercise pkg
+   timeout = 50 :: Int
+ 
+   rec i acc st = 
+      case onefirst st of
+         Nothing           -> return (reverse acc)
+         Just (r, _, next)
+            |  i <= 0      -> fail msg
+            | otherwise    -> rec (i-1) ((r, stateContext next) : acc) next
+    where
+      msg = "Time out after " ++ show timeout ++ " steps. " ++ 
+            concatMap f (reverse acc)
+      f (r, c) = let s = maybe "???" (prettyPrinter ex) (fromContext c)
+                 in "[" ++ show r ++ "]  " ++ s ++ "; "
+
+-- Note that we have to inspect the last step of the prefix afterwards, because
+-- the remaining part of the derivation could consist of minor rules only.
+allfirsts :: Monad m => State a -> m [(Rule (Context a), Location, State a)]
+allfirsts state = 
+   case statePrefix state of
+      Nothing -> 
+         fail "Prefix is required"
+      Just p0 ->
+         let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (stateContext state))
+             f (r1, _, _) (r2, _, _) = 
+                ruleOrdering (exercise (exercisePkg state)) r1 r2
+         in return (sortBy f (mapMaybe make (derivations tree)))
+ where
+   stop (Just (RuleStep r)) = isMajorRule r
+   stop _ = False
+   
+   make d = do
+      prefixEnd <- safeHead (reverse (steps d))
+      termEnd   <- safeHead (reverse (terms d))
+      case lastStepInPrefix prefixEnd of
+         Just (RuleStep r) | isMajorRule r -> return
+            ( r
+            , location termEnd
+            , makeState (exercisePkg state) (Just prefixEnd) termEnd
+            )
+         _ -> Nothing
+
+onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a)
+onefirst state = do
+   xs <- allfirsts state
+   case xs of
+      hd:_ -> return hd
+      []   -> fail "No step possible"
+
+applicable :: Location -> State a -> [Rule (Context a)]
+applicable loc state =
+   let p r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (stateContext state))
+   in filter p (ruleset (exercise (exercisePkg state)))
+
+allapplications :: State a -> [(Rule (Context a), Location, State a)]
+allapplications state = xs ++ ys
+ where
+   pkg = exercisePkg state
+   ex  = exercise pkg
+   xs  = concat (allfirsts state)
+   ps  = [ (r, loc) | (r, loc, _) <- xs ]
+   ys  = maybe [] f (top (stateContext state))
+           
+   f c = g c ++ concatMap f (allDowns c)
+   g c = [ (r, location new, makeState pkg Nothing new)
+         | r   <- ruleset ex
+         , (r, location c) `notElem` ps
+         , new <- applyAll r c
+         ]
+
+-- local helper
+setLocation :: Location -> Context a -> Context a 
+setLocation loc c0 = fromMaybe c0 (navigateTo loc c0)
+
+-- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the 
+-- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied
+-- to the current term at the given location, in which case the request is invalid.
+apply :: Monad m => Rule (Context a) -> Location -> State a -> m (State a)
+apply r loc state = maybe applyOff applyOn (statePrefix state)
+ where
+   applyOn _ = -- scenario 1: on-strategy
+      maybe applyOff return $ safeHead
+      [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, showId r == showId r1, loc==loc1 ]
+      
+   applyOff  = -- scenario 2: off-strategy
+      case Apply.apply r (setLocation loc (stateContext state)) of
+         Just new -> return (makeState (exercisePkg state) Nothing new)
+         Nothing  -> fail ("Cannot apply " ++ show r)
+       
+ready :: State a -> Bool
+ready state = isReady (exercise (exercisePkg state)) (stateTerm state)
+
+stepsremaining :: Monad m => State a -> m Int
+stepsremaining = liftM length . derivation Nothing
+
+findbuggyrules :: State a -> a -> [Rule (Context a)]
+findbuggyrules state a =
+   let ex      = exercise (exercisePkg state)
+       buggies = filter isBuggyRule (ruleset ex)
+       p r     = ruleIsRecognized ex r (stateContext state) (inContext ex a)
+   in filter p buggies
src/Service/Diagnose.hs view
@@ -12,38 +12,47 @@ -- ----------------------------------------------------------------------------- module Service.Diagnose -   ( Diagnosis(..), RuleID, diagnose, restartIfNeeded+   ( Diagnosis(..), diagnose, restartIfNeeded+   , diagnosisType, diagnosisTypeSynonym    ) where  -import Common.Apply-import Common.Context-import Common.Exercise-import Common.Strategy (emptyPrefix)-import Common.Transformation+import Common.Library import Common.Utils (safeHead)+import Data.List (sortBy) import Data.Maybe-import Service.TypedAbstractService+import Service.ExercisePackage+import Service.State+import Service.BasicServices+import Service.Types  ---------------------------------------------------------------- -- Result types for diagnose service -type RuleID a = Rule (Context a)- data Diagnosis a-   = Buggy          (RuleID a)+   = Buggy          (Rule (Context a))    | NotEquivalent      | Similar        Bool (State a)-   | Expected       Bool (State a) (RuleID a)-   | Detour         Bool (State a) (RuleID a)+   | Expected       Bool (State a) (Rule (Context a))+   | Detour         Bool (State a) (Rule (Context a))    | Correct        Bool (State a) +instance Show (Diagnosis a) where+   show diagnosis = +      case diagnosis of+         Buggy r        -> "Buggy rule " ++ show (show r)+         NotEquivalent  -> "Unknown mistake" +         Similar _ _    -> "Very similar"+         Expected _ _ r -> "Rule " ++ show (show r) ++ ", expected by strategy"+         Detour _ _ r   -> "Rule " ++ show (show r) ++ ", not following strategy"+         Correct _ _    -> "Unknown step"+ ---------------------------------------------------------------- -- The diagnose service  diagnose :: State a -> a -> Diagnosis a diagnose state new    -- Is the submitted term equivalent?-   | not (equivalence ex (term state) new) =+   | not (equivalenceContext ex (stateContext state) newc) =         -- Is the rule used discoverable by trying all known buggy rules?         case discovered True of            Just r -> -- report the buggy rule@@ -52,7 +61,7 @@               NotEquivalent                   -- Is the submitted term (very) similar to the previous one? -   | similarity ex (term state) new =+   | similarity ex (stateTerm state) new =         -- If yes, report this         Similar (ready state) state         @@ -64,35 +73,34 @@     -- Is the rule used discoverable by trying all known rules?    | otherwise =-        let ns = restartIfNeeded (state { prefix=Nothing, context=inContext ex new })+        let ns = restartIfNeeded (makeState pkg Nothing newc)         in case discovered False of               Just r ->  -- If yes, report the found rule as a detour                  Detour (ready ns) ns r               Nothing -> -- If not, we give up                  Correct (ready ns) ns  where-   ex = exercise state+   pkg  = exercisePkg state+   ex   = exercise pkg+   newc = inContext ex new        expected = do       xs <- allfirsts (restartIfNeeded state)-      let p (_, _, ns) = similarity ex new (term ns)+      let p (_, _, ns) = similarity ex new (stateTerm ns)       safeHead (filter p xs)     discovered searchForBuggy = safeHead       [ r-      | r <- ruleset ex+      | r <- sortBy (ruleOrdering ex) (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+      , ruleIsRecognized ex r sub1 sub2       ]     where -      mode = not searchForBuggy-      diff = difference ex mode (term state) new-      (sub1, sub2) = fromMaybe (term state, new) diff-      +      (sub1, sub2) = +         case difference ex (not searchForBuggy) (stateTerm state) new of +            Just (a, b) -> (inContext ex a, inContext ex b) +            Nothing     -> (stateContext state, newc)+  ---------------------------------------------------------------- -- Helpers @@ -100,14 +108,36 @@ -- 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+restartIfNeeded state +   | isNothing (statePrefix state) && canBeRestarted (exercise pkg) = +        emptyState pkg (stateTerm state)+   | otherwise = state  where-   ex = exercise s+   pkg = exercisePkg state+   +diagnosisType :: Type a (Diagnosis a)+diagnosisType = useSynonym diagnosisTypeSynonym++diagnosisTypeSynonym :: TypeSynonym a (Diagnosis a)+diagnosisTypeSynonym = typeSynonym "Diagnosis" to from tp+ where+   to (Left r) = Buggy r+   to (Right (Left ())) = NotEquivalent+   to (Right (Right (Left (b, s)))) = Similar b s+   to (Right (Right (Right (Left (b, s, r))))) = Expected b s r+   to (Right (Right (Right (Right (Left (b, s, r)))))) = Detour b s r+   to (Right (Right (Right (Right (Right (b, s)))))) = Correct b s+   +   from (Buggy r)        = Left r+   from (NotEquivalent)  = Right (Left ())+   from (Similar b s)    = Right (Right (Left (b, s)))+   from (Expected b s r) = Right (Right (Right (Left (b, s, r))))+   from (Detour b s r)   = Right (Right (Right (Right (Left (b, s, r)))))+   from (Correct b s)    = Right (Right (Right (Right (Right (b, s)))))+   +   tp  =  Rule+      :|: Unit+      :|: Pair   Bool stateTp+      :|: tuple3 Bool stateTp Rule+      :|: tuple3 Bool stateTp Rule+      :|: Pair   Bool stateTp
src/Service/DomainReasoner.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XMultiParamTypeClasses -XTypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -12,23 +12,25 @@ ----------------------------------------------------------------------------- module Service.DomainReasoner     ( -- * Domain Reasoner data type-     DomainReasoner, runDomainReasoner-   , liftEither, liftIO, catchError +     DomainReasoner, runDomainReasoner, runWithCurrent+   , liftEither, MonadIO(..), catchError       -- * Update functions    , addPackages, addPackage, addPkgService-   , addServices, addService+   , addServices, addService, addTestSuite    , setVersion, setFullVersion      -- * Accessor functions    , getPackages, getExercises, getServices-   , getVersion, getFullVersion+   , getVersion, getFullVersion, getTestSuite    , findPackage, findService    ) where -import Common.Exercise+import Common.Library+import Common.TestSuite import Common.Utils (Some(..)) import Control.Monad.Error import Control.Monad.State-import Service.ServiceList+import Data.Maybe+import Service.Types import Service.ExercisePackage  -----------------------------------------------------------------------@@ -39,12 +41,13 @@ data Content = Content    { packages    :: [Some ExercisePackage]    , services    :: [Some ExercisePackage] -> [Service]+   , testSuite   :: TestSuite    , version     :: String    , fullVersion :: Maybe String    }     noContent :: Content-noContent = Content [] (const []) [] Nothing+noContent = Content [] (const []) (return ()) [] Nothing  runDomainReasoner :: DomainReasoner a -> IO a runDomainReasoner m = do@@ -53,6 +56,11 @@       Left msg -> fail msg       Right a  -> return a +-- | Returns a run function, based on the current state, inside the monad+runWithCurrent :: DomainReasoner (DomainReasoner a -> IO a)+runWithCurrent =+   get >>= \st -> return (runDomainReasoner . (put st >>))+ liftEither :: Either String a -> DomainReasoner a liftEither = either fail return @@ -68,6 +76,10 @@    throwError     = fail    catchError m f = DR (unDR m `catchError` (unDR . f)) +instance MonadPlus DomainReasoner where+   mzero       = DR mzero+   a `mplus` b = DR (unDR a `mplus` unDR b)+ instance MonadState Content DomainReasoner where    get   = DR get    put s = DR (put s)@@ -89,11 +101,14 @@    c { services = \xs -> f xs : services c xs }  addServices :: [Service] -> DomainReasoner ()-addServices = mapM_ addPkgService . map const+addServices = mapM_ (addPkgService . const)  addService :: Service -> DomainReasoner () addService s = addServices [s] +addTestSuite :: TestSuite -> DomainReasoner ()+addTestSuite m = modify $ \c -> c { testSuite = testSuite c >> m }+ setVersion :: String -> DomainReasoner () setVersion s = modify $ \c -> c { version = s } @@ -118,18 +133,60 @@ getFullVersion :: DomainReasoner String getFullVersion = gets fullVersion >>= maybe getVersion return -findPackage :: ExerciseCode -> DomainReasoner (Some ExercisePackage)-findPackage code = do+getTestSuite :: DomainReasoner TestSuite+getTestSuite = gets testSuite++findPackage :: Id -> DomainReasoner (Some ExercisePackage)+findPackage i = do    pkgs <- getPackages -   let p (Some pkg) = exerciseCode (exercise pkg) == code-   case filter p pkgs of+   case [ a | a@(Some pkg) <- pkgs, getId pkg == resolveId i ] of       [this] -> return this-      _      -> fail $ "Package " ++ show code ++ " not found"+      _      -> fail $ "Package " ++ show i ++ " not found"        findService :: String -> DomainReasoner Service findService txt = do    srvs <- getServices-   case filter ((==txt) . serviceName) srvs of+   case filter ((==txt) . showId) srvs of       [hd] -> return hd       []   -> fail $ "No service " ++ txt       _    -> fail $ "Ambiguous service " ++ txt++-----------------------------------------------------------------------+-- Identifier aliases (temporary)++resolveId :: Id -> Id+resolveId i = fromMaybe i (lookup i table)+ where+   table = map (newId *** newId)+      [ ("math.coverup",             "algebra.equations.coverup")+      , ("math.lineq",               "algebra.equations.linear")+      , ("math.lineq-mixed",         "algebra.equations.linear.mixed")+      , ("math.quadreq",             "algebra.equations.quadratic")         +      , ("math.quadreq-no-abc",      "algebra.equations.quadratic.no-abc")    +      , ("math.quadreq-with-approx", "algebra.equations.quadratic.approximate")+      , ("math.higherdegree",        "algebra.equations.polynomial")+      , ("math.rationaleq",          "algebra.equations.rational")+      , ("math.linineq",             "algebra.inequalities.linear")+      , ("math.quadrineq",           "algebra.inequalities.quadratic")+      , ("math.ineqhigherdegree",    "algebra.inequalities.polynomial")+      , ("math.factor",              "algebra.manipulation.polynomial.factor")+      , ("math.simplifyrational",    "algebra.manipulation.rational.simplify")+      , ("math.simplifypower",       "algebra.manipulation.exponents.simplify")+      , ("math.nonnegexp",           "algebra.manipulation.exponents.nonnegative")+      , ("math.powerof",             "algebra.manipulation.exponents.powerof")+      , ("math.derivative",          "calculus.differentiation")+      , ("math.fraction",            "arithmetic.fractions")+      , ("math.calcpower",           "arithmetic.exponents")+      , ("linalg.gaussianelim",      "linearalgebra.gaussianelim")+      , ("linalg.gramschmidt",       "linearalgebra.gramschmidt")+      , ("linalg.linsystem",         "linearalgebra.linsystem")+      , ("linalg.systemwithmatrix",  "linearalgebra.systemwithmatrix")+      , ("logic.dnf",                "logic.propositional.dnf")+      , ("logic.dnf-unicode",        "logic.propositional.dnf.unicode")+      , ("relationalg.cnf",          "relationalgebra.cnf")+      -- MathDox compatibility+      , ("gaussianelimination"        , "linearalgebra.gaussianelim")+      , ("gramschmidt"                , "linearalgebra.gramschmidt")+      , ("solvelinearsystem"          , "linearalgebra.linsystem")+      , ("solvelinearsystemwithmatrix", "linearalgebra.systemwithmatrix")+      ]
+ src/Service/Evaluator.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE GADTs, Rank2Types #-}+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Service.Evaluator where++import Common.Library+import Control.Monad+import Data.List+import Service.ExercisePackage+import Service.Types+import Service.DomainReasoner++evalService :: Evaluator inp out a -> Service -> inp -> DomainReasoner out+evalService f = eval f . serviceFunction++data Evaluator inp out a = Evaluator +   { encoder :: Encoder out a+   , decoder :: Decoder inp a+   }++data Encoder s a = Encoder +   { encodeType  :: forall t . Type a t -> t -> DomainReasoner s+   , encodeTerm  :: a -> DomainReasoner s+   , encodeTuple :: [s] -> s+   }++data Decoder s a = Decoder +   { decodeType     :: forall t . Type a t -> s -> DomainReasoner (t, s)+   , decodeTerm     :: s -> DomainReasoner a+   , decoderPackage :: ExercisePackage a+   } ++decoderExercise :: Decoder s a -> Exercise a+decoderExercise = exercise . decoderPackage++eval :: Evaluator inp out a -> TypedValue a -> inp -> DomainReasoner out+eval f (tv ::: tp) s = +   case tp of +      t1 :-> t2 -> do+         (a, s1) <- decodeType (decoder f) t1 s+         eval f (tv a ::: t2) s1+      _ ->+         encodeType (encoder f) tp tv++decodeDefault :: Decoder s a -> Type a t -> s -> DomainReasoner (t, s)+decodeDefault dec tp s =+   case tp of+      Iso f _ t  -> liftM (first f) (decodeType dec t s)+      Pair t1 t2 -> do+         (a, s1) <- decodeType dec t1 s+         (b, s2) <- decodeType dec t2 s1+         return ((a, b), s2)+      t1 :|: t2 ->+         liftM (first Left)  (decodeType dec t1 s) `mplus`+         liftM (first Right) (decodeType dec t2 s)+      Unit -> +         return ((), s)+      Tag _ t1 ->+         decodeType dec t1 s+      ExercisePkg ->+         return (decoderPackage dec, s)+      _ ->+         fail $ "No support for argument type: " ++ show tp++encodeDefault :: Encoder s a -> Type a t -> t -> DomainReasoner s+encodeDefault enc tp tv =+   case tp of+      Iso _ f t  -> encodeType enc t (f tv)+      Pair t1 t2 -> do+         let (a, b) = tv+         x <- encodeType enc t1 a+         y <- encodeType enc t2 b+         return (encodeTuple enc [x, y])+      t1 :|: t2     -> case tv of+                          Left  a -> encodeType enc t1 a+                          Right b -> encodeType enc t2 b+      Unit          -> return (encodeTuple enc [])+      Tag _ t1      -> encodeType enc t1 tv+      IO t1         -> do let pp s | "user error (" `isPrefixOf` s = init (drop 12 s)+                                   | otherwise = s+                          result <- liftIO $ +                             liftM Right tv `catch` (return . Left . pp . show)+                          case result of +                             Left msg -> fail msg+                             Right a  -> encodeType enc t1 a+      Rule          -> encodeType enc String (showId tv)+      Term          -> encodeTerm enc tv+      Context       -> fromContext tv >>= encodeType enc Term+      Location      -> encodeType enc String (show tv)+      ExercisePkg   -> return (encodeTuple enc [])+      _             -> fail ("No support for result type: " ++ show tp)
src/Service/ExercisePackage.hs view
@@ -18,17 +18,18 @@    , package, termPackage, somePackage, someTermPackage      -- Conversion functions to/from OpenMath    , termToOMOBJ, omobjToTerm+     -- ExerciseText datatype+   , ExerciseText(..)    ) where +import Common.Library import Common.Utils (Some(..))-import Common.Exercise-import Control.Monad import Common.Rewriting.Term+import Control.Monad import Data.Char import Data.List-import Service.FeedbackText (ExerciseText) import Text.OpenMath.Object-import Text.OpenMath.Symbol+import qualified Text.OpenMath.Symbol as OM import Text.OpenMath.Dictionary.Fns1  -----------------------------------------------------------------------------@@ -42,6 +43,10 @@    , getExerciseText :: Maybe (ExerciseText a)    } +instance HasId (ExercisePackage a) where+   getId = getId . exercise+   changeId f pkg = pkg { exercise = changeId f (exercise pkg) }+ package :: Exercise a -> ExercisePackage a package ex = P     { exercise        = ex@@ -63,22 +68,20 @@  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))+      Var s     -> OMV s+      Con s     -> OMS (idToSymbol (getId s))+      Meta i    -> OMV ('$' : show i)+      Num n     -> OMI n+      Float d   -> OMF d+      Apply _ _ -> let (f, xs) = getSpine term+                   in make (map termToOMOBJ (f:xs))  where    make [OMS s, OMV x, body] | s == lambdaSymbol =        OMBIND (OMS s) [x] body@@ -90,7 +93,7 @@       OMV x -> case isMeta x of                   Just n  -> return (Meta n)                   Nothing -> return (Var x)-      OMS s -> return (Con (S (dictionary s) (symbolName s)))+      OMS s -> return (symbol (newSymbol (OM.dictionary s # OM.symbolName s)))       OMI n -> return (Num n)       OMF a -> return (Float a)       OMA (x:xs) -> liftM2 makeTerm (omobjToTerm x) (mapM omobjToTerm xs)@@ -100,3 +103,27 @@  where    isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- '    isMeta _        = Nothing++idToSymbol :: Id -> OM.Symbol+idToSymbol a+   | null (qualifiers a) = +        OM.extraSymbol (unqualified a)+   | otherwise = +        OM.makeSymbol (qualification a) (unqualified a)++------------------------------------------------------------+-- Exercise Text data type+--    Note: ideally, this should be defined elsewhere++-- Exercise extension for textual feedback+data ExerciseText a = ExerciseText+   { ruleText              :: Rule (Context a) -> Maybe String+   , appliedRule           :: Rule (Context a) -> String+   , feedbackSyntaxError   :: String -> String+   , feedbackSame          :: String+   , feedbackBuggy         :: Bool -> [Rule (Context a)] -> String+   , feedbackNotEquivalent :: Bool -> String+   , feedbackOk            :: [Rule (Context a)] -> (String, Bool)+   , feedbackDetour        :: Bool -> Maybe (Rule (Context a)) -> [Rule (Context a)] -> (String, Bool)+   , feedbackUnknown       :: Bool -> String+   }
src/Service/FeedbackText.hs view
@@ -14,61 +14,49 @@    , onefirsttext, submittext, derivationtext, submitHelper    ) where -import Control.Arrow-import Common.Context-import Common.Exercise-import Common.Transformation-import Common.Utils+import Common.Library hiding (derivation) import Data.Maybe+import Common.Utils import Service.Diagnose (restartIfNeeded)+import Service.ExercisePackage+import Service.State import Service.Submit-import Service.TypedAbstractService----------------------------------------------------------------- Exercise Text data type---- 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-   }-+import Service.BasicServices+  ------------------------------------------------------------ -- Services -derivationtext :: Monad m => ExerciseText a -> State a -> Maybe String -> m [(String, Context a)]-derivationtext exText st _event = do-   xs <- derivation Nothing st+derivationtext :: Monad m => State a -> Maybe String -> m [(String, Context a)]+derivationtext state _event = do+   exText <- exerciseText state+   xs     <- derivation Nothing state    return (map (first (showRule exText)) xs) -onefirsttext :: 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)+onefirsttext :: Monad m => State a -> Maybe String -> m (Bool, String, State a)+onefirsttext state event =+   case onefirst state of+      Just (r, _, s) -> do+         exText <- exerciseText state+         let mtxt = fromContext (stateContext s) >>= useToRewrite exText r state+             msg  = case mtxt of+                       Just txt | event /= Just "hint button" -> txt+                       _ -> "Use " ++ showRule exText r+         return (True, msg, s)+      _ -> return (False, "Sorry, no hint available", state)       -submittext :: 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)+submittext :: Monad m => State a -> String -> Maybe String -> m (Bool, String, State a)+submittext state input _event = do+   exText <- exerciseText state+   return $+      case parser (exercise (exercisePkg state)) input of+         Left err -> +            (False, feedbackSyntaxError exText err, state)+         Right a  -> +            let result = submit state a+                (txt, b) = submitHelper exText state a result+            in case getResultState result of+                  Just new | b -> (True, txt, restartIfNeeded new)+                  _ -> (False, txt, state)  -- Feedback messages for submit service (free student input). The boolean -- indicates whether the student is allowed to continue (True), or forced @@ -99,23 +87,25 @@  showRule :: ExerciseText a -> Rule (Context a) -> String showRule exText r = -   case ruleText exText r of-      Just s  -> s-      Nothing -> "rule " ++ name r+   fromMaybe ("rule " ++ showId r) (ruleText exText r)  useToRewrite :: ExerciseText a -> Rule (Context a) -> State a -> a -> Maybe String-useToRewrite exText rule old = rewriteIntoText True txt old+useToRewrite exText r old = rewriteIntoText True txt old  where-   txt = "Use " ++ showRule exText rule-         ++ " to rewrite "+   txt = "Use " ++ showRule exText r ++ " to rewrite "  youRewroteInto :: State a -> a -> Maybe String youRewroteInto = rewriteIntoText False "You rewrote "  rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String rewriteIntoText mode txt old a = do-   let ex = exercise old-   p <- fromContext (context old)+   let ex = exercise (exercisePkg old)+   p <- fromContext (stateContext old)    (p1, a1) <- difference ex mode p a     return $ txt ++ prettyPrinter ex p1           ++ " into " ++ prettyPrinter ex a1 ++ ". "++exerciseText :: Monad m => State a -> m (ExerciseText a)+exerciseText = +   let msg = "No support for textual feedback"+   in maybe (fail msg) return . getExerciseText . exercisePkg
src/Service/ModeJSON.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XGADTs #-}
+{-# LANGUAGE GADTs #-}
 -----------------------------------------------------------------------------
 -- Copyright 2010, Open Universiteit Nederland. This file is distributed 
 -- under the terms of the GNU General Public License. For more information, 
@@ -14,18 +14,15 @@ -----------------------------------------------------------------------------
 module Service.ModeJSON (processJSON, jsonTuple) where
 
-import Common.Context
+import Common.Library hiding (exerciseId)
 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 (TypedValue(..), Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..), decoderExercise)
+import Service.State
 import qualified Service.Types as Tp
-import qualified Service.TypedAbstractService as TAS
+import Service.Types hiding (String)
 import Service.Submit
-import Service.ServiceList hiding (Service)
+import Service.Evaluator
 import Service.ExercisePackage 
 import Service.DomainReasoner
 import Control.Monad
@@ -33,14 +30,16 @@ import Data.Char
 
 -- TODO: Clean-up code
-extractCode :: JSON -> ExerciseCode
-extractCode = fromMaybe noCode . readCode . f
+extractExerciseId :: Monad m => JSON -> m Id
+extractExerciseId json =
+   case json of
+      String s -> return (newId s)
+      Array [String _, String _, a@(Array _)] -> extractExerciseId a
+      Array (String s:tl) | any p s -> extractExerciseId (Array tl)
+      Array (hd:_) -> extractExerciseId hd
+      _ -> fail "no code"
  where 
-   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 _ = ""
+   p c = not (isAlphaNum c || isSpace c || c `elem` ".-")
 
 processJSON :: String -> DomainReasoner (Request, String, String)
 processJSON input = do
@@ -64,7 +63,7 @@    srv  <- case lookupM "method" json of
               Just (String s) -> return s
               _               -> fail "Invalid method"
-   code <- liftM (return . extractCode) (lookupM "params" json)
+   let a = (lookupM "params" json >>= extractExerciseId)
    enc  <- case lookupM "encoding" json of
               Nothing         -> return Nothing
               Just (String s) -> liftM Just (readEncoding s)
@@ -75,7 +74,7 @@               _               -> fail "Invalid source"
    return Request 
       { service    = srv
-      , exerciseID = code
+      , exerciseId = a
       , source     = src
       , dataformat = JSON
       , encoding   = enc
@@ -83,38 +82,45 @@ 
 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
+   pkg  <- if fun == "exerciselist" 
+           then return (Some (package emptyExercise))
+           else extractExerciseId arg >>= findPackage
+   srv  <- findService fun
    case jsonConverter pkg of
-      Some conv -> do
-         either fail return (evalService conv srv arg)
+      Some conv ->
+         evalService conv srv arg
 
-jsonConverter :: Some ExercisePackage -> Some (Evaluator (Either String) JSON JSON)
+jsonConverter :: Some ExercisePackage -> Some (Evaluator JSON JSON)
 jsonConverter (Some pkg) =
    Some (Evaluator (jsonEncoder (exercise pkg)) (jsonDecoder pkg))
 
-jsonEncoder :: Monad m => Exercise a -> Encoder m JSON a
+jsonEncoder :: Exercise a -> Encoder JSON a
 jsonEncoder ex = Encoder
    { encodeType  = encode (jsonEncoder ex)
    , encodeTerm  = return . String . prettyPrinter ex
    , encodeTuple = jsonTuple
    }
  where
-   encode :: Monad m => Encoder m JSON a -> Type a t -> t -> m JSON
+   encode :: Encoder JSON a -> Type a t -> t -> DomainReasoner JSON
    encode enc serviceType a
       | length xs > 1 =
            liftM jsonTuple (mapM (\(b ::: t) -> encode enc t b) xs)
       | otherwise = 
            case serviceType of
+              Tp.Tag s t | s == "Result" -> do
+                 result <- isSynonym submitTypeSynonym (a ::: serviceType) 
+                 encodeResult enc result
+                         | s == "elem" -> 
+                 encode enc t a
+                         | s == "State" -> do
+                 st <- isSynonym stateTypeSynonym (a ::: serviceType)
+                 encodeState (encodeTerm enc) st
+                 
               Tp.List t    -> liftM Array (mapM (encode enc t) a)
               Tp.Tag s t   -> liftM (\b -> Object [(s, b)]) (encode enc t a)
               Tp.Int       -> return (toJSON a)
               Tp.Bool      -> return (toJSON a)
               Tp.String    -> return (toJSON a)
-              Tp.State     -> encodeState (encodeTerm enc) a
-              Tp.Result    -> encodeResult enc a
               _            -> encodeDefault enc serviceType a
     where
       xs = tupleList (a ::: serviceType)
@@ -124,8 +130,8 @@    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 :: ExercisePackage a -> Decoder JSON a
 jsonDecoder pkg = Decoder
    { decodeType     = decode (jsonDecoder pkg)
    , decodeTerm     = reader (exercise pkg)
@@ -136,23 +142,25 @@    reader ex (String s) = either (fail . show) return (parser ex s)
    reader _  _          = fail "Expecting a string when reading a term"
  
-   decode :: MonadPlus m => Decoder m JSON a -> Type a t -> JSON -> m (t, JSON) 
+   decode :: Decoder JSON a -> Type a t -> JSON -> DomainReasoner (t, JSON) 
    decode dec serviceType =
       case serviceType of
-         Tp.State    -> useFirst $ decodeState (decoderExercise dec) (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 _:rest)) -> return (decoderExercise dec, Array rest)
-                                    _ -> return (decoderExercise dec, json)
+         Tp.Rule     -> useFirst $ \x -> jsonToId x >>= getRule (decoderExercise dec)
+         Tp.ExercisePkg -> \json -> case json of
+                                       Array (String _:rest) -> return (decoderPackage dec, Array rest)
+                                       _ -> return (decoderPackage dec, json)
          Tp.Int      -> useFirst $ \json -> case json of 
                                                Number (I n) -> return (fromIntegral n)
                                                _        -> fail "not an integer"
          Tp.String   -> useFirst $ \json -> case json of 
                                                String s -> return s
                                                _        -> fail "not a string"
-         _           -> decodeDefault dec serviceType
+         Tp.Tag s _ | s == "State" -> do 
+            f <- equalM stateTp serviceType
+            useFirst (liftM f . decodeState (decoderPackage dec) (decodeTerm dec))
+         _ -> decodeDefault dec serviceType
    
    useFirst :: Monad m => (JSON -> m a) -> JSON -> m (a, JSON)
    useFirst f (Array (x:xs)) = do
@@ -160,20 +168,23 @@       return (a, Array xs)
    useFirst _ _ = fail "expecting an argument"
 
+jsonToId :: Monad m => JSON -> m Id
+jsonToId = liftM (newId :: String -> Id) . fromJSON
+
 decodeLocation :: Monad m => JSON -> m [Int]
 decodeLocation (String s) = readM s
 decodeLocation _          = fail "expecting a string for a location"
 
 --------------------------
 
-encodeState :: Monad m => (a -> m JSON) -> TAS.State a -> m JSON
+encodeState :: Monad m => (a -> m JSON) -> State a -> m JSON
 encodeState f st = do 
-   theTerm <- f (TAS.term st)
+   theTerm <- f (stateTerm st)
    return $ Array
-      [ String (show (exerciseCode (TAS.exercise st)))
-      , String (maybe "NoPrefix" show (TAS.prefix st))
+      [ String (showId (exercisePkg st))
+      , String (maybe "NoPrefix" show (statePrefix st))
       , theTerm
-      , encodeContext (getEnvironment (TAS.context st))
+      , encodeContext (getEnvironment (stateContext st))
       ]
 
 encodeContext :: Environment -> JSON
@@ -181,16 +192,14 @@  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, jsonContext]) = do
+decodeState :: Monad m => ExercisePackage a -> (JSON -> m a) -> JSON -> m (State a)
+decodeState pkg f (Array [a]) = decodeState pkg f a
+decodeState pkg f (Array [String _code, String p, ce, jsonContext]) = do
+   let ex  = exercise pkg
+       mpr = readM p >>= (`makePrefix` strategy ex)
    a    <- f ce 
    env  <- decodeContext jsonContext
-   return TAS.State 
-      { TAS.exercise = ex
-      , TAS.prefix   = readM p >>= (`makePrefix` strategy ex)
-      , TAS.context  = makeContext ex env a
-      }
+   return $ makeState pkg mpr (makeContext ex env a)
 decodeState _ _ s = fail $ "invalid state" ++ show s
 
 decodeContext :: Monad m => JSON -> m Environment
@@ -201,26 +210,26 @@    add _ _ = fail "invalid item in context"
 decodeContext json = fail $ "invalid context: " ++ show json
    
-encodeResult :: Monad m => Encoder m JSON a -> Result a -> m JSON
+encodeResult :: Encoder JSON a -> Result a -> DomainReasoner JSON
 encodeResult enc result =
    case result of
-      -- TAS.SyntaxError _ -> [("result", String "SyntaxError")]
-      Buggy rs      -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)]
+      -- SyntaxError _ -> [("result", String "SyntaxError")]
+      Buggy rs      -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . showId) rs)]
       NotEquivalent -> return $ Object [("result", String "NotEquivalent")]   
       Ok rs st      -> do
-         json <- encodeType enc Tp.State st
-         return $ Object [("result", String "Ok"), ("rules", Array $ map (String . name) rs), ("state", json)]
+         json <- encodeType enc stateTp st
+         return $ Object [("result", String "Ok"), ("rules", Array $ map (String . showId) rs), ("state", json)]
       Detour rs st  -> do
-         json <- encodeType enc Tp.State st
-         return $ Object [("result", String "Detour"), ("rules", Array $ map (String . name) rs), ("state", json)]
+         json <- encodeType enc stateTp st
+         return $ Object [("result", String "Detour"), ("rules", Array $ map (String . showId) rs), ("state", json)]
       Unknown st    -> do
-         json <- encodeType enc Tp.State st
+         json <- encodeType enc stateTp st
          return $ Object [("result", String "Unknown"), ("state", json)]
 
 jsonTuple :: [JSON] -> JSON
 jsonTuple xs = 
    case mapM f xs of 
-      Just xs | distinct (map fst xs) -> Object xs
+      Just ys | distinct (map fst ys) -> Object ys
       _ -> Array xs
  where
    f (Object [p]) = Just p
src/Service/ModeXML.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XGADTs #-}
+{-# LANGUAGE GADTs #-}
 -----------------------------------------------------------------------------
 -- Copyright 2010, Open Universiteit Nederland. This file is distributed 
 -- under the terms of the GNU General Public License. For more information, 
@@ -17,10 +17,7 @@    , resultOk, resultError, addVersion
    ) where
 
-import Common.Navigator
-import Common.Context
-import Common.Exercise
-import Common.Strategy hiding (not, fail)
+import Common.Library hiding (exerciseId)
 import Common.Utils (Some(..), readM)
 import Control.Monad
 import Data.Char
@@ -30,15 +27,14 @@ import Service.ProblemDecomposition
 import Service.Request
 import Service.RulesInfo (rulesInfoXML)
-import Service.ServiceList 
 import Service.StrategyInfo
-import Service.TypedAbstractService hiding (exercise)
+import Service.State
 import Service.Diagnose
-import Service.Types hiding (State)
+import Service.Types
+import qualified Service.Types as Tp
+import Service.Evaluator
 import Text.OpenMath.Object
 import Text.XML
-import qualified Common.Transformation as Rule
-import qualified Service.Types as Tp
 import Service.DomainReasoner
 
 processXML :: String -> DomainReasoner (Request, String, String)
@@ -46,7 +42,7 @@    xml  <- liftEither (parseXML input)
    req  <- liftEither (xmlRequest xml)
    resp <- xmlReply req xml
-              `catchError` \msg -> return (resultError msg)
+              `catchError` (return . resultError)
    vers <- getVersion
    let out = showXML (if null vers then resp else addVersion vers resp)
    return (req, out, "application/xml")
@@ -61,59 +57,38 @@    unless (name xml == "request") $
       fail "expected xml tag request"
    srv  <- findAttribute "service" xml
-   let code = extractExerciseCode xml
+   let a = extractExerciseId xml
    enc  <- case findAttribute "encoding" xml of
               Just s  -> liftM Just (readEncoding s)
               Nothing -> return Nothing 
    return Request 
       { service    = srv
-      , exerciseID = code
+      , exerciseId = a
       , source     = findAttribute "source" xml
       , dataformat = XML
       , encoding   = enc
       }
 
 xmlReply :: Request -> XML -> DomainReasoner XML
-xmlReply request xml 
-   | service request == "mathdox" = do
-        code <- maybe (fail "unknown exercise code") return (exerciseID request)
-        Some pkg <- findPackage code
-        (st, sloc, answer) <- liftEither $ xmlToRequest xml (fromOpenMath pkg) (exercise pkg)
-        return (replyToXML (toOpenMath pkg) (problemDecomposition st sloc answer))
-
 xmlReply request xml = do
    srv <- findService (service request)
    pkg <- 
-      case exerciseID request of
+      case exerciseId request of
          Just code -> findPackage code
          Nothing   
             | service request == "exerciselist" ->
                  return (Some (package emptyExercise))
             | otherwise -> 
                  fail "unknown exercise code"
-   Some conv <- return $ 
+   Some conv <-
       case encoding request of
-         Just StringEncoding -> stringFormatConverter pkg
-         _                   -> openMathConverter pkg
-   res <- liftEither $ evalService conv srv xml
+         Just StringEncoding -> return (stringFormatConverter pkg)
+         _                   -> return (openMathConverter pkg)
+   res <- 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, _)    -> maybe (fail "invalid code") return (readCode as)
-      -- being backwards compatible with early MathDox
-      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" 
+extractExerciseId :: Monad m => XML -> m Id
+extractExerciseId = liftM newId . findAttribute "exerciseid"
 
 resultOk :: XMLBuilder -> XML
 resultOk body = makeXML "reply" $ do 
@@ -128,91 +103,109 @@ ------------------------------------------------------------
 -- Mixing abstract syntax (OpenMath format) and concrete syntax (string)
 
-stringFormatConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder)
+stringFormatConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder)
 stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg)
 
-stringFormatConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a
+stringFormatConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a
 stringFormatConverterTp pkg = 
-   Evaluator (xmlEncoder False f ex) (xmlDecoder False g pkg)
+   Evaluator (xmlEncoder False f pkg) (xmlDecoder False g pkg)
  where
    ex = exercise pkg
    f  = return . element "expr" . text . prettyPrinter ex
-   g xml = do
-      xml <- findChild "expr" xml -- quick fix
+   g xml0 = do
+      xml <- findChild "expr" xml0 -- quick fix
       -- guard (name xml == "expr")
       let input = getData xml
       either (fail . show) return (parser ex input)
 
-openMathConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder)
+openMathConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder)
 openMathConverter (Some pkg) = Some (openMathConverterTp pkg)
         
-openMathConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a
+openMathConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a
 openMathConverterTp pkg =
-   Evaluator (xmlEncoder True f ex) (xmlDecoder True g pkg)
+   Evaluator (xmlEncoder True f pkg) (xmlDecoder True g pkg)
  where
-   ex = exercise pkg
    f = return . builder . toXML . toOpenMath pkg
    g xml = do
       xob   <- findChild "OMOBJ" xml
-      omobj <- xml2omobj xob
+      omobj <- liftEither (xml2omobj xob)
       case fromOpenMath pkg omobj of
          Just a  -> return a
          Nothing -> fail "Unknown OpenMath object"
 
-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
+xmlEncoder :: Bool -> (a -> DomainReasoner XMLBuilder) -> ExercisePackage a -> Encoder XMLBuilder a
+xmlEncoder b f pkg = Encoder
+   { encodeType  = xmlEncodeType b (xmlEncoder b f pkg) pkg
    , encodeTerm  = f
    , encodeTuple = sequence_
    }
- where
-   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 -> 
-            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 => Bool -> (XML -> m a) -> ExercisePackage a -> Decoder m XML a
+xmlEncodeType :: Bool -> Encoder XMLBuilder a -> ExercisePackage a -> Type a t -> t -> DomainReasoner XMLBuilder
+xmlEncodeType b enc pkg serviceType =
+   case serviceType of
+      Tp.Tag s _ 
+         | s == "Diagnosis" -> \a -> do
+              d <- isSynonym diagnosisTypeSynonym (a ::: serviceType)
+              encodeDiagnosis b (encodeTerm enc) d
+         | s == "DecompositionReply" -> \a -> do
+              reply <- isSynonym replyTypeSynonym (a ::: serviceType)
+              encodeReply (encodeState b (encodeTerm enc)) reply
+         | s == "RulesInfo" -> \_ ->
+              rulesInfoXML (exercise pkg) (encodeTerm enc)
+         | s == "State" -> \a -> do
+              st <- isSynonym stateTypeSynonym (a ::: serviceType)
+              encodeState b (encodeTerm enc) st
+      Tp.List t1  -> \xs -> 
+         case allAreTagged t1 of
+            Just f -> do
+               let make = element "elem" . mapM_ (uncurry (.=.)) . f
+               let elems = mapM_ make xs
+               return (element "list" elems)
+            _ -> do
+               bs <- mapM (xmlEncodeType b enc pkg t1) xs
+               let elems = mapM_ (element "elem") bs
+               return (element "list" elems)
+      Tp.Tag s t1  -> liftM (element s) . xmlEncodeType b enc pkg t1  -- quick fix
+      Tp.Strategy  -> return . builder . strategyToXML
+      Tp.Rule      -> return . ("ruleid" .=.) . showId
+      Tp.Term      -> encodeTerm enc
+      Tp.Context   -> encodeContext b (encodeTerm enc)
+      Tp.Location  -> return . {-element "location" .-} text . show
+      Tp.Id        -> return . text . show
+      Tp.Bool      -> return . text . map toLower . show
+      Tp.String    -> return . text
+      Tp.Int       -> return . text . show
+      _            -> encodeDefault enc serviceType
+
+xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> ExercisePackage a -> Decoder XML a
 xmlDecoder b f pkg = Decoder
-   { decodeType     = decode (xmlDecoder b f pkg)
+   { decodeType     = xmlDecodeType b (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 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)
+
+xmlDecodeType :: Bool -> Decoder XML a -> Type a t -> XML -> DomainReasoner (t, XML)
+xmlDecodeType b dec serviceType = 
+   case serviceType of
+      Tp.Context     -> keep $ decodeContext b (decoderPackage dec) (decodeTerm dec)
+      Tp.Location    -> keep $ liftM (read . getData) . findChild "location"
+      Tp.Id          -> keep $ \xml -> do
+                           a <- findChild "location" xml
+                           return (newId (getData a))
+      Tp.Rule        -> keep $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . newId . getData) . findChild "ruleid"
+      Tp.Term        -> keep $ decodeTerm dec
+      Tp.StrategyCfg -> decodeConfiguration
+      Tp.Tag s t
+         | s == "State" -> \xml -> do 
+              g  <- equalM stateTp serviceType
+              st <- decodeState b (decoderPackage dec) (decodeTerm dec) xml
+              return (g st, xml)
+         | s == "answer" -> \xml ->
+              findChild "answer" xml >>= xmlDecodeType b dec t
+      _ -> decodeDefault dec serviceType
+ where         
+   keep :: Monad m => (XML -> m a) -> XML -> m (a, XML)
+   keep f xml = liftM (\a -> (a, xml)) (f xml)
          
 allAreTagged :: Type a t -> Maybe (t -> [(String, String)])
 allAreTagged (Iso _ f t) = fmap (. f) (allAreTagged t)
@@ -220,32 +213,39 @@    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 (Tag s Bool)   = Just $ \b -> [(s, map toLower (show b))]
+allAreTagged (Tag s String) = Just $ \a -> [(s, a)]
 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
+decodeState :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (State a)
+decodeState b pkg f xmlTop = do
+   xml <- findChild "state" xmlTop
    unless (name xml == "state") (fail "expected a state tag")
-   mpr <- 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
-   env  <- decodeEnvironment b xml
-   let state  = State ex mpr term
-       term   = makeContext ex env expr
-   return (state, top)
+   mpr  <- decodePrefix pkg xml
+   term <- decodeContext b pkg f xml
+   return (makeState pkg mpr term)
+
+decodePrefix :: Monad m => ExercisePackage a -> XML -> m (Maybe (Prefix (Context a)))
+decodePrefix pkg xml
+   | all isSpace prefixText =
+        return (Just (emptyPrefix str))
+   | prefixText ~= "no prefix" =
+        return Nothing 
+   | otherwise = do
+        a  <- readM prefixText
+        pr <- makePrefix a str
+        return (Just pr)
  where
+   prefixText = maybe "" getData (findChild "prefix" xml)
+   str = strategy (exercise pkg)
    a ~= b = g a == g b
    g = map toLower . filter (not . isSpace)
+   
+decodeContext :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (Context a)
+decodeContext b pkg f xml = do
+   expr <- f xml
+   env  <- decodeEnvironment b xml
+   return (makeContext (exercise pkg) env expr)
 
 decodeEnvironment :: Monad m => Bool -> XML -> m Environment
 decodeEnvironment b xml =
@@ -256,18 +256,18 @@    add env item = do 
       unless (name item == "item") $ 
          fail $ "expecting item tag, found " ++ name item
-      name  <- findAttribute "name"  item
+      n  <- findAttribute "name"  item
       case findChild "OMOBJ" item of
          -- OpenMath object found inside item tag
-         Just this | b -> do
+         Just this | b ->
             case xml2omobj this >>= omobjToTerm of
                Left err -> fail err
                Right term -> 
-                  return (storeEnv name term env)
+                  return (storeEnv n term env)
          -- Simple value in attribute
          _ -> do
             value <- findAttribute "value" item
-            return (storeEnv name value env)
+            return (storeEnv n value env)
 
 decodeConfiguration :: MonadPlus m => XML -> m (StrategyConfiguration, XML)
 decodeConfiguration xml =
@@ -282,22 +282,25 @@             Just a  -> return a
             Nothing -> fail $ "unknown action " ++ show (name item)
       cfgloc <- findAttribute "name" item
-      return $ (ByName cfgloc, action)
-
+      return (byName (newId 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
+encodeState b f state = do
+   body <- f (stateTerm state)
+   return $ element "state" $ do
+      encodePrefix (statePrefix state)
+      let env = getEnvironment (stateContext state)
+      encodeEnvironment b (location (stateContext state)) env
       body
 
+encodePrefix :: Maybe (Prefix a) -> XMLBuilder
+encodePrefix = element "prefix"  . text . maybe "no prefix" show
+   
 encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder
 encodeEnvironment b loc env0
    | nullEnv env = return ()
-   | otherwise   = element "context" $ do
-        forM_ (keysEnv env) $ \k -> do
+   | otherwise   = element "context" $
+        forM_ (keysEnv env) $ \k ->
            element "item" $ do 
               "name"  .=. k
               case lookupEnv k env of 
@@ -310,18 +313,18 @@ 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
+      Buggy r        -> return $ element "buggy" $ "ruleid" .=. showId r
       NotEquivalent  -> return $ tag "notequiv"
       Similar  b s   -> ok "similar"  b s Nothing
-      Expected b s r -> ok "expected" b s (Just r)
-      Detour   b s r -> ok "detour"   b s (Just r)
+      Expected b s r -> ok "expected" b s (Just (showId r))
+      Detour   b s r -> ok "detour"   b s (Just (showId r))
       Correct  b s   -> ok "correct"  b s Nothing
  where
    ok t b s mr = do
       body <- encodeState mode f s
       return $ element t $ do
          "ready" .=. map toLower (show b)
-         maybe (return ()) (("ruleid" .=.) . Rule.name) mr
+         maybe (return ()) ("ruleid" .=.) mr
          body
   
 encodeContext :: Monad m => Bool -> (a -> m XMLBuilder) -> Context a -> m XMLBuilder
src/Service/ProblemDecomposition.hs view
@@ -11,101 +11,85 @@ -----------------------------------------------------------------------------
 module Service.ProblemDecomposition 
    ( problemDecomposition
-   , Reply, replyToXML, xmlToRequest
+   , replyType, replyTypeSynonym, encodeReply
    ) where
 
-import Common.Apply
-import Common.Context
-import Common.Exercise
-import Common.Derivation
-import Common.Strategy hiding (not, repeat, fail)
-import Common.Transformation 
+import Common.Library
 import Common.Utils
-import Data.Char
+import Control.Monad
 import Data.Maybe
-import Service.TypedAbstractService (State(..), stepsremaining)
+import Service.ExercisePackage
+import Service.State
+import Service.Types
 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 (State ex mpr requestedTerm) sloc answer 
+problemDecomposition :: Monad m => Maybe Id -> State a -> Maybe a -> m (Reply a)
+problemDecomposition msloc state answer 
    | isNothing $ subStrategy sloc (strategy ex) =
-        replyError "request error" "invalid location for strategy"
+        fail "request error: invalid location for strategy"
    | otherwise =
-   let pr = fromMaybe (emptyPrefix $ strategy ex) mpr in
+   let pr = fromMaybe (emptyPrefix $ strategy ex) (statePrefix state) in
          case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of            
-            ([], _) -> replyError "strategy error" "not able to compute an expected answer"
+            ([], _) -> fail "strategy error: not able to compute an expected answer"
             (answers, Just answeredTerm)
-               | not (null witnesses) ->
-                    Ok ReplyOk
-                       { repOk_Code     = ex
-                       , repOk_Location = nextTaskLocation sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses)
-                       , repOk_Context  = show newPrefix ++ ";" ++ 
-                                          show (getEnvironment $ fst $ head witnesses)
-                       , repOk_Steps    = fromMaybe 0 $ stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses)
-                       }
+               | not (null witnesses) -> return $
+                    Ok newLocation newState
                   where 
                     witnesses   = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers
-                    newPrefix   = snd (head witnesses)            
-            ((expected, prefix):_, maybeAnswer) ->
-                    Incorrect ReplyIncorrect
-                       { repInc_Code       = ex
-                       , repInc_Location   = subTaskLocation sloc loc
-                       , repInc_Expected   = fromJust (fromContext expected)
-                       , repInc_Derivation = derivation
-                       , repInc_Arguments  = args
-                       , repInc_Steps      = fromMaybe 0 $ stepsremaining $ State ex (Just pr) requestedTerm
-                       , repInc_Equivalent = maybe False (equivalenceContext ex expected) maybeAnswer
-                       }
+                    (newCtx, newPrefix) = head witnesses
+                    newLocation = nextTaskLocation (strategy ex) sloc $ 
+                                     fromMaybe topId $ nextMajorForPrefix newPrefix newCtx
+                    newState    = makeState pkg (Just newPrefix) newCtx
+            ((expected, pref):_, maybeAnswer) -> return $
+                    Incorrect isEquiv newLocation expState arguments
              where
-               (loc, args) = firstMajorInPrefix pr prefix requestedTerm
-               derivation  = 
-                  let len      = length $ prefixToSteps pr
-                      rules    = stepsToRules $ drop len $ prefixToSteps prefix
-                      f (s, a) = (s, fromJust (fromContext a))
-                  in map f (makeDerivation requestedTerm rules)
-
+               newLocation = subTaskLocation (strategy ex) sloc loc
+               expState = makeState pkg (Just pref) expected
+               isEquiv  = maybe False (equivalenceContext ex expected) maybeAnswer
+               (loc, arguments) = fromMaybe (topId, []) $ 
+                                     firstMajorInPrefix pr pref requestedTerm
+ where
+   pkg   = exercisePkg state
+   ex    = exercise pkg
+   topId = getId (strategy ex)
+   sloc  = fromMaybe topId msloc
+   requestedTerm = stateContext state
+   
 similarityCtx :: Exercise a -> Context a -> Context a -> Bool
 similarityCtx ex a b = fromMaybe False $
    liftM2 (similarity ex) (fromContext a) (fromContext b)
 
 -- | Continue with a prefix until a certain strategy location is reached. At least one
 -- major rule should have been executed
-runPrefixLocation :: StrategyLocation -> Prefix a -> a -> [(a, Prefix a)]
-runPrefixLocation loc p0 = 
-   concatMap (check . f) . derivations . 
+runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)]
+runPrefixLocation loc p0 =
+   concatMap (checkPair . f) . derivations . 
    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 (Exit info)) = getId info == loc
    stop _ = False
  
-   check result@(a, p)
+   checkPair result@(a, p)
       | null rules            = [result]
       | all isMinorRule rules = runPrefixLocation loc p a
       | otherwise             = [result]
     where
       rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
 
-firstMajorInPrefix :: Prefix a -> Prefix a -> a -> (StrategyLocation, Args)
-firstMajorInPrefix p0 prefix a = fromMaybe (topLocation, []) $ do
-   let steps = prefixToSteps prefix
-       newSteps = drop (length $ prefixToSteps p0) steps
+firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, Args)
+firstMajorInPrefix p0 p a = do
+   let newSteps = drop (length $ prefixToSteps p0) (prefixToSteps p)
    is <- firstLocation newSteps
    return (is, argumentsForSteps a newSteps)
  where
-   firstLocation :: [Step a] -> Maybe StrategyLocation
+   firstLocation :: HasId l => [Step l a] -> Maybe Id
    firstLocation [] = Nothing
-   firstLocation (Begin is _:Step r:_) | isMajorRule r = Just is
+   firstLocation (Enter info:RuleStep r:_) | isMajorRule r = Just (getId info)
    firstLocation (_:rest) = firstLocation rest
  
-argumentsForSteps :: a -> [Step a] -> Args
-argumentsForSteps a = flip rec a . stepsToRules
+argumentsForSteps :: a -> [Step l a] -> Args
+argumentsForSteps a0 = flip rec a0 . stepsToRules
  where
    rec [] _ = []
    rec (r:rs) a
@@ -114,22 +98,15 @@                          in maybe [] (zip ds) (expectedArguments r a)
       | otherwise      = []
  
-nextMajorForPrefix :: Prefix a -> a -> StrategyLocation
-nextMajorForPrefix p0 a = fromMaybe topLocation $ do
+nextMajorForPrefix :: Prefix a -> a -> Maybe Id
+nextMajorForPrefix p0 a = do
    (_, p1)  <- safeHead $ runPrefixMajor p0 a
-   let steps = prefixToSteps p1
-   rec (reverse steps)
+   rec (reverse (prefixToSteps p1))
  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) = 
-   let new = applyD r a
-   in [ (name r, new) | isMajorRule r ] ++ makeDerivation new rs 
+   rec (Enter info:_) = Just (getId info)
+   rec (Exit  info:_) = Just (getId info)
+   rec (_:rest)       = rec rest
    
 -- Copied from TypedAbstractService: clean me up
 runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)]
@@ -137,154 +114,55 @@    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 (Just (RuleStep 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
-   }
+data Reply a = Ok Id (State a)
+             | Incorrect Bool Id (State a) Args
 
 type Args = [(String, String)]
 
 ------------------------------------------------------------------------
 -- Conversion functions to XML
 
-replyToXML :: (a -> OMOBJ) -> Reply a -> XML
-replyToXML toOpenMath reply =
+encodeReply :: Monad m => (State a -> m XMLBuilder) -> Reply a -> m XMLBuilder
+encodeReply showState reply = 
    case reply of
-      Ok r        -> replyOkToXML r
-      Incorrect r -> replyIncorrectToXML toOpenMath r 
-      Error r     -> replyErrorToXML r
+      Ok loc state -> do
+         stateXML <- showState state
+         return $
+            element "correct" $ do
+               element "location" (text $ show loc)
+               stateXML
+      Incorrect b loc state args -> do 
+         stateXML <- showState state 
+         return $ 
+            element "incorrect" $ do
+               "equivalent" .=. show b
+               element "location" (text $ show loc)
+               stateXML
+               let f (x, y) = element "elem" $ do 
+                     "descr" .=. x 
+                     text y
+               unless (null args) $
+                  element "arguments" $ mapM_ f args
 
-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)
+replyType :: Type a (Reply a)
+replyType = useSynonym replyTypeSynonym
 
-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)
+replyTypeSynonym :: TypeSynonym a (Reply a)
+replyTypeSynonym = typeSynonym "DecompositionReply" to from tp
+ where
+   to (Left (a, b))        = Ok a b
+   to (Right (a, b, c, d)) = Incorrect a b c d
    
-   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)
+   from (Ok a b)            = Left (a, b)
+   from (Incorrect a b c d) = Right (a, b, c, d)
    
-makeReply :: String -> XMLBuilder -> XML
-makeReply kind body = makeXML "reply" $ do
-   "result" .=. kind
-   body+   tp  =  tuple2 Id stateTp
+      :|: tuple4 Bool Id stateTp argsTp
+
+   argsTp = List (Pair String String)
src/Service/Request.hs view
@@ -11,12 +11,12 @@ ----------------------------------------------------------------------------- module Service.Request where -import Common.Exercise+import Common.Library hiding (exerciseId) import Data.Char  data Request = Request    { service    :: String-   , exerciseID :: Maybe ExerciseCode+   , exerciseId :: Maybe Id    , source     :: Maybe String    , dataformat :: DataFormat    , encoding   :: Maybe Encoding
src/Service/RulesInfo.hs view
@@ -10,51 +10,41 @@ -- ----------------------------------------------------------------------------- module Service.RulesInfo -   ( RulesInfo, mkRulesInfo, rulesInfoXML-   , rewriteRuleToFMP, collectExamples+   ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap, rulesInfoType    ) where +import Common.Library 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 Service.Types 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)+   let pairs = M.findWithDefault [] (getId r) exampleMap+   xs <- forM (take 3 pairs) $ \(a, b) ->+            liftM2 (,) (enc a) (enc b)                          return $ element "rule" $ do-      "name"        .=. name r+      "name"        .=. showId r       "buggy"       .=. f (isBuggyRule r)       "rewriterule" .=. f (isRewriteRule r)       -- More information-      let descr = ruleDescription r+      let descr = description r           -- to do: rules should carry descriptions -          txt   = if null descr then (name r) else descr +          txt   = if null descr then showId r else descr        unless (null txt) $          element "description" $ text txt       forM_ (ruleGroups r) $ \s -> -         element "group" $ text s+         element "group" $ text (showId s)       forM_ (ruleSiblings r) $ \s -> -         element "sibling" $ text s+         element "sibling" $ text $ showId s       -- FMPs and CMPs       forM_ (getRewriteRules r) $ \(Some rr, b) -> do          let fmp = rewriteRuleToFMP b rr@@ -64,7 +54,7 @@          element "FMP" $              builder (omobj2xml (toObject fmp))       -- Examples-      forM_ examples $ \(a, b) ->+      forM_ xs $ \(a, b) ->          element "example" (a >> b)  where    f          = map toLower . show@@ -76,13 +66,18 @@    | sound     = eqFMP    a b    | otherwise = buggyFMP a b   where-   a :~> b = fmap termToOMOBJ (rulePair r 0)-              -collectExamples :: Exercise a -> M.Map String [(a, a)]+   a :~> b = fmap termToOMOBJ (ruleSpecTerm r)++type ExampleMap a = M.Map Id [(a, a)]++collectExamples :: Exercise a -> ExampleMap a collectExamples ex = foldr add M.empty (examples ex)  where    add a m = let tree = derivationTree (strategy ex) (inContext ex a)                  f Nothing = m                  f (Just d) = foldr g m (zip3 (terms d) (steps d) (drop 1 (terms d)))-                 g (a, r, b) = M.insertWith (++) (name r) (liftM2 (,) (fromContext a) (fromContext b))+                 g (x, r, y) = M.insertWith (++) (getId r) (liftM2 (,) (fromContext x) (fromContext y))              in f (derivation tree) ++rulesInfoType :: Type a ()+rulesInfoType = useSynonym (typeSynonym "RulesInfo" id id Unit)
src/Service/ServiceList.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XRankNTypes #-}+{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -10,32 +10,21 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Service.ServiceList -   ( serviceList, exerciselistS-   , Service(..), evalService-   ) where+module Service.ServiceList (serviceList, exerciselistS) where -import Common.Exercise hiding (Exercise)-import Common.Strategy (toStrategy)-import Common.Transformation+import Common.Library hiding (apply, applicable, derivation) import Common.Utils (Some(..)) import Data.List (sortBy)-import Service.FeedbackText hiding (ExerciseText)-import Service.ProblemDecomposition+import Data.Ord+import Service.FeedbackText+import Service.ProblemDecomposition (problemDecomposition, replyType) import Service.ExercisePackage+import Service.Types 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 = Service -   { serviceName        :: String-   , serviceDescription :: String-   , serviceDeprecated  :: Bool-   , serviceFunction    :: forall a . TypedValue a-   }+import Service.State+import Service.BasicServices+import qualified Service.Diagnose as Diagnose+import qualified Service.Submit as Submit  ------------------------------------------------------ -- Querying a service@@ -43,22 +32,14 @@ serviceList :: [Service] serviceList =    [ derivationS, allfirstsS, onefirstS, readyS-   , stepsremainingS, applicableS, applyS, generateS-   , submitS, diagnoseS+   , stepsremainingS, applicableS, allapplicationsS+   , applyS, generateS+   , examplesS, submitS, diagnoseS    , onefirsttextS, findbuggyrulesS    , submittextS, derivationtextS    , problemdecompositionS    , rulelistS, rulesinfoS, strategyinfoS    ]--makeService :: String -> String -> (forall a . TypedValue a) -> Service-makeService name descr f = Service name descr False f--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@@ -69,7 +50,7 @@    \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))+   derivation ::: maybeTp StrategyCfg :-> stateTp :-> errorTp (List (tuple2 Rule Context))  allfirstsS :: Service allfirstsS = makeService "allfirsts" @@ -77,7 +58,7 @@    \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))+   allfirsts ::: stateTp :-> errorTp (List (tuple3 Rule Location stateTp))          onefirstS :: Service onefirstS = makeService "onefirst" @@ -85,55 +66,70 @@    \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))+   onefirst ::: stateTp :-> elemTp (errorTp (tuple3 Rule Location stateTp))    readyS :: Service readyS = makeService "ready"     "Test if the current expression is in a form accepted as a final answer. \    \For this, the strategy is not used." $ -   S.ready ::: State :-> Bool+   ready ::: stateTp :-> Bool  stepsremainingS :: Service stepsremainingS = makeService "stepsremaining"     "Computes how many steps are remaining to be done, according to the \    \strategy. For this, only the first derivation is considered, which \    \corresponds to the one returned by the derivation service." $-   S.stepsremaining ::: State :-> Error Int+   stepsremaining ::: stateTp :-> errorTp Int  applicableS :: Service applicableS = makeService "applicable"     "Given a current expression and a location in this expression, this service \    \yields all rules that can be applied at this location, regardless of the \    \strategy." $ -   S.applicable ::: Location :-> State :-> List Rule+   applicable ::: Location :-> stateTp :-> List Rule +allapplicationsS :: Service+allapplicationsS = makeService "allapplications" +   "Given a current expression, this service yields all rules that can be \+   \applied at a certain location, regardless wether the rule used is buggy \+   \or not. Some results are within the strategys, others are not." $  +   allapplications ::: stateTp :-> List (tuple3 Rule Location stateTp)+ applyS :: Service applyS = makeService "apply"     "Apply a rule at a certain location to the current expression. If this rule \    \was not expected by the strategy, we deviate from it. If the rule cannot \    \be applied, this service call results in an error." $ -   S.apply ::: Rule :-> Location :-> State :-> Error State+   apply ::: Rule :-> Location :-> stateTp :-> errorTp stateTp  generateS :: Service generateS = makeService "generate"     "Given an exercise code and a difficulty level (optional), this service \    \returns an initial state with a freshly generated expression. The meaning \    \of the difficulty level (an integer) depends on the exercise at hand." $ -   S.generate ::: Exercise :-> Optional 5 Int :-> IO State+   generate ::: ExercisePkg :-> optionTp 5 Int :-> IO stateTp +examplesS :: Service+examplesS = makeService "examples"+   "This services returns a list of example expresssions that can be solved \+   \with an exercise. These are the examples that appear at the page generated \+   \for each exercise. Also see the generate service, which returns a random \+   \start term." $+   (examples . exercise) ::: ExercisePkg :-> List Term+ findbuggyrulesS :: Service findbuggyrulesS = makeService "findbuggyrules"     "Search for common misconceptions (buggy rules) in an expression (compared \    \to the current state). It is assumed that the expression is indeed not \    \correct. This service has been superseded by the diagnose service." $ -   S.findbuggyrules ::: State :-> Term :-> List Rule+   findbuggyrules ::: stateTp :-> Term :-> List Rule  submitS :: Service submitS = deprecate $ makeService "submit"     "Analyze an expression submitted by a student. Possible answers are Buggy, \    \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \    \by the diagnose service." $ -   S.submit ::: State :-> Term :-> Result+   Submit.submit ::: stateTp :-> Term :-> Submit.submitType  diagnoseS :: Service diagnoseS = makeService "diagnose" @@ -145,7 +141,7 @@    \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+   Diagnose.diagnose ::: stateTp :-> Term :-> Diagnose.diagnosisType  ------------------------------------------------------ -- Services with a feedback component@@ -157,7 +153,7 @@    \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)+   onefirsttext ::: stateTp :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp))  submittextS :: Service submittextS = makeService "submittext" @@ -167,24 +163,25 @@    \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)+   submittext ::: stateTp :-> String :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp))  derivationtextS :: Service derivationtextS = makeService "derivationtext"     "Similar to the derivation service, but the rules appearing in the derivation \    \have been replaced by a short description of the rule. The optional string is \    \for announcing the event leading to this service call." $ -   derivationtext ::: ExerciseText :-> State :-> Maybe String :-> Error (List (tuple2 String Context))+   derivationtext ::: stateTp :-> maybeTp String :-> errorTp (List (tuple2 String Context))  ------------------------------------------------------ -- Problem decomposition service + problemdecompositionS :: Service problemdecompositionS = makeService "problemdecomposition"     "Strategy service developed for the SURF project Intelligent Feedback for a \    \binding with the MathDox system on linear algebra exercises. This is a \    \composite service, and available for backwards compatibility." $-   problemDecomposition ::: State :-> StrategyLoc :-> Maybe Term :-> DecompositionReply+   problemDecomposition ::: maybeTp Id  :-> stateTp :-> maybeTp (Tag "answer" Term) :-> errorTp replyType  ------------------------------------------------------ -- Reflective services@@ -193,7 +190,7 @@ 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))+   allExercises list ::: List (tuple3 (Tag "exerciseid" String) (Tag "description" String) (Tag "status" String))  rulelistS :: Service rulelistS = makeService "rulelist" @@ -201,30 +198,30 @@    \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))+   allRules ::: ExercisePkg :-> List (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool))        rulesinfoS :: Service rulesinfoS = makeService "rulesinfo"     "Returns a list of all rules of a particular exercise, with many details \    \including Formal Mathematical Properties (FMPs) and example applications." $-   mkRulesInfo ::: RulesInfo+   () ::: rulesInfoType  strategyinfoS :: Service strategyinfoS = makeService "strategyinfo"    "Returns the representation of the strategy of a particular exercise." $ -   (toStrategy . strategy) ::: Exercise :-> Strategy +   (toStrategy . strategy . exercise) ::: ExercisePkg :-> Strategy    -allExercises :: [Some ExercisePackage] -> [(String, String, String, String)]-allExercises = map make . sortBy cmp+allExercises :: [Some ExercisePackage] -> [(String, String, String)]+allExercises = map make . sortBy (comparing f)  where-   cmp e1 e2  = f e1 `compare` f e2-   f (Some pkg) = exerciseCode (exercise pkg)+   f (Some pkg) = showId (exercise pkg)    make (Some pkg) = -      let ex   = exercise pkg-          code = exerciseCode ex -      in (domain code, identifier code, description ex, show (status ex))+      (showId pkg, description pkg, show (status (exercise pkg))) -allRules :: E.Exercise a -> [(String, Bool, Bool)]-allRules = map make . ruleset+allRules :: ExercisePackage a -> [(String, Bool, Bool)]+allRules = map make . ruleset . exercise  where  -   make r  = (name r, isBuggyRule r, isRewriteRule r)+   make r  = (showId r, isBuggyRule r, isRewriteRule r)+   +elemTp :: Type a t -> Type a t+elemTp = Tag "elem"
+ src/Service/State.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------
+-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
+-- under the terms of the GNU General Public License. For more information, 
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- The information maintained for a learner trying to complete a
+-- derivation.
+--
+-----------------------------------------------------------------------------
+module Service.State 
+   ( -- * Exercise state
+     State, makeState, empyStateContext, emptyState 
+   , exercisePkg, statePrefix, stateContext, stateTerm
+     -- * Types
+   , stateTp, stateTypeSynonym
+   ) where
+
+import Common.Library
+import Common.Utils (readM)
+import Service.Types
+import Data.Maybe
+import Service.ExercisePackage
+
+data State a = State 
+   { exercisePkg  :: ExercisePackage a
+   , statePrefix  :: Maybe (Prefix (Context a))
+   , stateContext :: Context a
+   }
+
+stateTerm :: State a -> a
+stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext
+
+-----------------------------------------------------------
+
+makeState :: ExercisePackage a -> Maybe (Prefix (Context a)) -> Context a -> State a
+makeState = State
+
+empyStateContext :: ExercisePackage a -> Context a -> State a
+empyStateContext pkg = makeState pkg (Just pr)
+ where
+   ex = exercise pkg
+   pr = emptyPrefix (strategy ex)
+
+emptyState :: ExercisePackage a -> a -> State a
+emptyState pkg = empyStateContext pkg . inContext (exercise pkg)
+
+--------------------------------------------------------------
+
+stateTp :: Type a (State a)
+stateTp = useSynonym stateTypeSynonym
+
+stateTypeSynonym :: TypeSynonym a (State a)
+stateTypeSynonym = typeSynonym "State" to from tp
+ where
+   to (pkg, mp, ctx) =
+      let str = strategy (exercise pkg)
+          f   = fromMaybe [] . readM
+      in makeState pkg (mp >>= flip makePrefix str . f) ctx
+   from st = 
+      ( exercisePkg st
+      , fmap show (statePrefix st)
+      , stateContext st
+      )
+   tp = tuple3 ExercisePkg prefixTp Context
+
+prefixTp :: Type a (Maybe String)
+prefixTp = Tag "Prefix" (maybeTp String)
src/Service/StrategyInfo.hs view
@@ -16,20 +16,12 @@ import Data.Char import Data.Maybe import Control.Monad+import Common.Library import Common.Strategy.Core (Core(..), noLabels) import Common.Strategy.Abstract import Text.XML-import Common.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 @@ -38,7 +30,7 @@  infoToXML :: LabelInfo -> XMLBuilder infoToXML info = do-   "name" .=. labelName info+   "name" .=. showId info    when (removed   info) ("removed"   .=. "true")    when (collapsed info) ("collapsed" .=. "true")    when (hidden    info) ("hidden"    .=. "true")@@ -49,7 +41,7 @@       Label l a -> infoToXML l >> coreBuilder infoToXML a       _         -> coreBuilder infoToXML core -coreBuilder :: (l -> XMLBuilder) -> Core l a -> XMLBuilder+coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder coreBuilder f = rec  where    rec core = @@ -59,10 +51,11 @@          _ :|>: _  -> asList  "orelse"   isOrElse          Many a    -> element "many"     (rec a)          Repeat a  -> element "repeat"   (rec a)+         Label l (Rule r) | getId l == getId r -> element "rule"     (f l)          Label l a -> element "label"    (f l >> rec a)          Rec n a   -> element "rec"      (("var" .=. show n) >> rec a)          Not a     -> element "not"      (recNot a)-         Rule l r  -> element "rule"     (maybe ("name" .=. show r) f l)+         Rule r    -> element "rule"     ("name" .=. show r)          Var n     -> element "var"      ("var" .=. show n)          Succeed   -> tag     "succeed"          Fail      -> tag     "fail"@@ -92,9 +85,9 @@ 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+   g info = case f (showId info) of                Just r  -> return r-               Nothing -> fail $ "Unknown rule: " ++ show (labelName info) +               Nothing -> fail $ "Unknown rule: " ++ showId info  xmlToInfo :: Monad m => XML -> m LabelInfo xmlToInfo xml = do@@ -114,14 +107,9 @@       "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)+readStrategy toLabel findRule xml = do+   xs <- mapM (readStrategy toLabel findRule) (children xml)    let s = name xml    case lookup s table of       Just f  -> f s xs@@ -138,12 +126,12 @@       | null xs   = return Fail       | otherwise = return (foldr1 (:|>:) xs)    buildLabel x = do-      info <- f xml+      info <- toLabel xml       return (Label info x)    buildRule = do-      info <- f xml-      rule <- g info-      return (Rule (Just info) rule)+      info <- toLabel xml+      r    <- findRule info+      return (Label info (Rule r))    buildRec x = do       s <- findAttribute "var" xml       i <- maybe (fail "var: not an int") return (readInt s)@@ -153,11 +141,11 @@       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"+   comb0 a _ [] = return a+   comb0 _ s _  = fail $ "Strategy combinator " ++ s ++ "expects 0 args"  -   unary f _ [x] = return (f x)-   unary _ s _   = fail $ "Strategy combinator " ++ s ++ "expects 1 arg"+   comb1 f _ [x] = return (f x)+   comb1 _ s _   = fail $ "Strategy combinator " ++ s ++ "expects 1 arg"      join2 f g a b = join (f g a b)  @@ -165,13 +153,13 @@       [ ("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) +      , ("many",     comb1 Many)+      , ("repeat",   comb1 Repeat)+      , ("label",    join2 comb1 buildLabel)+      , ("rec",      join2 comb1 buildRec)+      , ("not",      comb1 (Not . noLabels))+      , ("rule",     join2 comb0 buildRule)+      , ("var",      join2 comb0 buildVar)+      , ("succeed",  comb0 Succeed)+      , ("fail",     comb0 Fail)        ]
src/Service/Submit.hs view
@@ -11,13 +11,16 @@ -- Diagnose a term submitted by a student. Deprecated (see diagnose service). -- ------------------------------------------------------------------------------module Service.Submit (submit, Result(..), getResultState) where+module Service.Submit +   ( submit, Result(..), getResultState+   , submitType, submitTypeSynonym+   ) where -import Common.Transformation-import Common.Context+import Common.Library import qualified Service.Diagnose as Diagnose import Service.Diagnose (Diagnosis, diagnose)-import Service.TypedAbstractService+import Service.State+import Service.Types  -- Note that in the typed setting there is no syntax error data Result a = Buggy  [Rule (Context a)]   @@ -27,8 +30,8 @@               | Unknown                   (State a)  -- equivalent   fromDiagnose :: Diagnosis a -> Result a-fromDiagnose diagnose =-   case diagnose of+fromDiagnose diagnosis =+   case diagnosis of       Diagnose.Buggy r        -> Buggy [r]       Diagnose.NotEquivalent  -> NotEquivalent       Diagnose.Similar _ s    -> Ok [] s@@ -37,7 +40,7 @@       Diagnose.Correct _ s    -> Unknown s            submit :: State a -> a -> Result a -submit state new = fromDiagnose (diagnose state new)+submit state = fromDiagnose . diagnose state     getResultState :: Result a -> Maybe (State a) getResultState result =@@ -46,3 +49,27 @@       Detour _ st -> return st       Unknown st  -> return st       _           -> Nothing+      +submitType :: Type a (Result a)+submitType = useSynonym submitTypeSynonym++submitTypeSynonym :: TypeSynonym a (Result a)+submitTypeSynonym = typeSynonym "Result" to from tp+ where+   to (Left rs) = Buggy rs+   to (Right (Left ())) = NotEquivalent+   to (Right (Right (Left (rs, s)))) = Ok rs s+   to (Right (Right (Right (Left (rs, s))))) = Detour rs s+   to (Right (Right (Right (Right s)))) = Unknown s++   from (Buggy rs)      = Left rs+   from (NotEquivalent) = Right (Left ())+   from (Ok rs s)       = Right (Right (Left (rs, s)))+   from (Detour rs s)   = Right (Right (Right (Left (rs, s))))+   from (Unknown s)     = Right (Right (Right (Right s))) ++   tp  =  List Rule +      :|: Unit+      :|: Pair (List Rule) stateTp+      :|: Pair (List Rule) stateTp+      :|: stateTp
− src/Service/TypedAbstractService.hs 
@@ -1,152 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.TypedAbstractService 
-   ( -- * Exercise state
-     State(..), emptyState, term
-     -- * Services
-   , 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, 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
-   }
-
-term :: State a -> a
-term = fromMaybe (error "invalid term") . fromContext . context
-
------------------------------------------------------------
-
-emptyState :: Exercise a -> a -> State a
-emptyState ex a = State
-   { exercise = ex
-   , prefix   = Just (emptyPrefix (strategy ex))
-   , context  = inContext ex a
-   }
-      
--- result must be in the IO monad to access a standard random number generator
-generate :: Exercise a -> Int -> IO (State a)
-generate ex level = do 
-   stdgen <- newStdGen
-   return (generateWith stdgen ex level)
-
-generateWith :: StdGen -> Exercise a -> Int -> State a
-generateWith rng ex level = emptyState ex (randomTermWith rng level ex)
-
-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 :: Monad m => State a -> m [(Rule (Context a), Location, State a)]
-allfirsts state = 
-   case prefix state of
-      Nothing -> 
-         fail "Prefix is required"
-      Just p0 ->
-         let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (context state))
-         in return (mapMaybe make (derivations tree))
- where
-   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
-            ( r
-            , location termEnd
-            , state { context = termEnd
-                    , prefix  = Just prefixEnd
-                    }
-            )
-         _ -> Nothing
-
-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 :: 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
-      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 -> return state { context=new, prefix=Nothing }
-         Nothing  -> fail ("Cannot apply " ++ show r)
-       
-ready :: State a -> Bool
-ready state = isReady (exercise state) (term state)
-
-stepsremaining :: Monad m => State a -> m Int
-stepsremaining = liftM length . derivation Nothing
-
-findbuggyrules :: State a -> a -> [Rule (Context a)]
-findbuggyrules state a =
-   let ex      = exercise state
-       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
src/Service/TypedExample.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XGADTs #-}+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed  -- under the terms of the GNU General Public License. For more information, @@ -16,40 +16,40 @@ import Service.DomainReasoner import Service.ModeXML import Service.ExercisePackage-import Service.ServiceList+import Service.Evaluator import Service.Types-import Common.Exercise+import Common.Library import Text.XML     typedExample :: ExercisePackage a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool) typedExample pkg service args = do    -- Construct a request in xml-   xmlRequest <- +   request <-        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+            stdReply (showId service) enc (exercise pkg) (return ())+         Just (reqTuple ::: reqTp) -> do+            xml <- encodeType (encoder evaluator) reqTp reqTuple+            return $ +               stdReply (showId service) enc (exercise pkg) xml    -- Construct a reply in xml-   xmlReply <- return $+   reply <-       case foldl dynamicApply (serviceFunction service) args of-         reply ::: replyTp ->-            case encodeType (encoder evaluator) replyTp reply of-               Left err  -> resultError err-               Right xml -> resultOk xml+         reply ::: replyTp -> do+            xml <- encodeType (encoder evaluator) replyTp reply+            return (resultOk xml) +    `catchError` +      (return . resultError)    -- Check request/reply pair    vers <- getVersion    xmlTest <- do-      (_, txt, _) <- processXML (show xmlRequest)+      (_, txt, _) <- processXML (show request)       let p   = filter (not . isSpace)-          out = showXML (if null vers then xmlReply else addVersion vers xmlReply)+          out = showXML (if null vers then reply else addVersion vers reply)       return (p txt == p out)      `catchError`        const (return False)-   return (xmlRequest, xmlReply, xmlTest)+   return (request, reply, xmlTest)  where    (evaluator, enc)       | withOpenMath pkg = (openMathConverterTp pkg, "openmath")@@ -58,14 +58,14 @@ stdReply :: String -> String -> Exercise a -> XMLBuilder -> XML stdReply s enc ex body = makeXML "request" $ do     "service"    .=. s-   "exerciseid" .=. show (exerciseCode ex)+   "exerciseid" .=. showId ex    "source"     .=. "test"    "encoding"   .=. enc    body  makeArgType :: [TypedValue a] -> Maybe (TypedValue a) makeArgType []   = fail "makeArgType: empty list"-makeArgType [_ ::: Exercise] = fail "makeArgType: empty list"+makeArgType [_ ::: ExercisePkg] = fail "makeArgType: empty list" makeArgType [tv] = return tv makeArgType ((a1 ::: t1) : rest) = do    a2 ::: t2 <- makeArgType rest@@ -79,13 +79,3 @@             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
@@ -10,26 +10,78 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Service.Types where+module Service.Types +   ( -- * Services+     Service, makeService, deprecate +   , serviceDeprecated, serviceFunction+     -- * Types+   , Type(..), TypedValue(..), tuple2, tuple3, tuple4, maybeTp, optionTp+   , errorTp, equal, isSynonym, useSynonym, TypeSynonym, typeSynonym+   , equalM+   ) where -import Common.Context (Context, fromContext)-import Common.Exercise (Exercise)-import Common.Navigator (Location)-import Common.Transformation (Rule, name)-import Common.Strategy (Strategy, StrategyLocation, StrategyConfiguration)+import Common.Library import Common.Utils (commaList)-import Control.Arrow import Control.Monad import Data.Maybe-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+import Service.ExercisePackage +-----------------------------------------------------------------------------+-- Services++data Service = Service +   { serviceId         :: Id+   , serviceDeprecated :: Bool+   , serviceFunction   :: forall a . TypedValue a+   }+   +instance HasId Service where+   getId = serviceId+   changeId f a = a { serviceId = f (serviceId a) }+   +makeService :: String -> String -> (forall a . TypedValue a) -> Service+makeService s descr f = describe descr (Service (newId s) False f)++deprecate :: Service -> Service+deprecate s = s { serviceDeprecated = True }++equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2)+equalM t1 t2 = maybe (fail msg) return (equal t1 t2)+ where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2++equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2)+equal type1 type2 =+   case (type1, type2) of+      (Pair a b,    Pair c d   ) -> equalPairs a b c d+      (a :|: b,     c :|: d    ) -> equalChoice a b c d+      (List a,      List b     ) -> liftM map (equal a b)+      (Rule,        Rule       ) -> Just id+      (Unit,        Unit       ) -> Just id+      (StrategyCfg, StrategyCfg) -> Just id+      (Location,    Location   ) -> Just id+      (Id,          Id         ) -> Just id+      (Term,        Term       ) -> Just id+      (ExercisePkg, ExercisePkg) -> Just id+      (Context,     Context    ) -> Just id+      (Bool,        Bool       ) -> Just id+      (String,      String     ) -> Just id+      (Int,         Int        ) -> Just id+      (Iso _ f a,   _          ) -> fmap (. f) (equal a type2)+      (_,           Iso f _ b  ) -> fmap (f .) (equal type1 b)+      (Tag s1 a,    Tag s2 b   ) -> guard (s1==s2) >> equal a b+      _                          -> Nothing+ where+   equalPairs a b c d = +      liftM2 (\f g (x, y) -> (f x, g y)) (equal a c) (equal b d)+   +   equalChoice a b c d =+      liftM2 (\f g -> either (Left . f) (Right . g)) (equal a c) (equal b d)++infixr 5 :|:++-----------------------------------------------------------------------------+-- Types+ infix  2 ::: infixr 3 :-> @@ -50,6 +102,21 @@    f (a, (b, (c, d))) = (a, b, c, d)    g (a, b, c, d)     = (a, (b, (c, d))) +maybeTp :: Type a t1 -> Type a (Maybe t1)+maybeTp t = Iso f g (t :|: Unit)+ where+   f = either Just (const Nothing)+   g = maybe (Right ()) Left++optionTp :: t1 -> Type a t1 -> Type a t1+optionTp a t = Iso (fromMaybe a) Just (maybeTp t)++errorTp :: Type a t -> Type a (Either String t)+errorTp t = Iso f g (t :|: IO Unit)+ where+   f = either Right (const (Left "errorTp"))+   g = either (Right . fail) Left+ data Type a t where    -- Type isomorphisms (for defining type synonyms)    Iso          :: (t1 -> t2) -> (t2 -> t1) -> Type a t1 -> Type a t2@@ -57,29 +124,21 @@    (:->)        :: 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)-   Error        :: Type a t -> Type a (Either String t)    -- Type constructors    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+   (:|:)        :: Type a t1 -> Type a t2 -> Type a (Either t1 t2)+   Unit         :: Type a ()    IO           :: Type a t -> Type a (IO t)    -- Exercise-specific types-   State        :: Type a (State a)-   Exercise     :: Type a (Exercise a)+   ExercisePkg  :: Type a (ExercisePackage 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+   Id           :: Type a Id    StrategyCfg  :: Type a StrategyConfiguration-   DecompositionReply :: Type a (Decomposition.Reply a)    -- Basic types    Bool         :: Type a Bool    Int          :: Type a Int@@ -89,17 +148,14 @@    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 (t1 :|: t2)    = show t1 ++ " | " ++ show t2+   show (Tag s _)      = s -- ++ "@(" ++ 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) ++ ")"+showTuple tp = "(" ++ commaList (collect tp) ++ ")"  where    collect :: Type a t -> [String]    collect (Pair t1 t2) = collect t1 ++ collect t2@@ -109,98 +165,42 @@ groundType :: Type a t -> Maybe String groundType tp =    case tp of -      State        -> Just "State"-      Exercise     -> Just "Exercise"+      ExercisePkg  -> Just "ExercisePkg"       Strategy     -> Just "Strategy"-      ExerciseText -> Just "ExerciseText"       Rule         -> Just "Rule"-      RulesInfo    -> Just "RulesInfo"       Term         -> Just "Term"       Context      -> Just "Context"-      Result       -> Just "Result"-      Diagnosis    -> Just "Diagnosis"+      Unit         -> Just "()"       Bool         -> Just "Bool"       Int          -> Just "Int"       String       -> Just "String"       Location     -> Just "Location"-      StrategyLoc  -> Just "StrategyLocation"+      Id           -> Just "Id"       StrategyCfg  -> Just "StrategyConfiguration"       _            -> Nothing--data Evaluator m inp out a = Evaluator -   { encoder :: Encoder m out a-   , decoder :: Decoder m inp a-   }+      +-----------------------------------------------------------------------------+-- Type Synonyms -data Encoder m s a = Encoder -   { encodeType  :: forall t . Type a t -> t -> m s-   , encodeTerm  :: a -> m s-   , encodeTuple :: [s] -> s+data TypeSynonym a t = TS +   { synonymName :: String +   , useSynonym  :: Type a t+   , isSynonym   :: Monad m => TypedValue a -> m t    }--data Decoder m s a = Decoder -   { decodeType     :: forall t . Type a t -> s -> m (t, s)-   , decodeTerm     :: s -> m a-   , decoderPackage :: ExercisePackage a+   +typeSynonym :: String -> (t2 -> t) -> (t -> t2) -> Type a t2 -> TypeSynonym a t+typeSynonym name to from tp = TS+   { synonymName = name+   , useSynonym  = Tag name (Iso to from tp)+   , isSynonym   = maybe (fail name) return . matchSynonym    }--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 -      t1 :-> t2 -> do-         (a, s1) <- decodeType (decoder f) t1 s-         eval f (tv a ::: t2) s1-      _ ->-         encodeType (encoder f) tp tv--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)-      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+ where+   matchSynonym (a ::: t0) = do+      (s, t) <- isTag t0+      guard (s == name)+      f <- equal t tp+      return (to (f a)) -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])-      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 tv-      Context       -> fromContext tv >>= encodeType enc Term-      Location      -> encodeType enc String (show tv)-      _             -> fail ("No support for result type: " ++ show tp)+isTag :: Type a t -> Maybe (String, Type a t)+isTag (Tag s t) = Just (s, t)+isTag _         = Nothing
src/Text/HTML.hs view
@@ -13,14 +13,17 @@ ----------------------------------------------------------------------------- module Text.HTML     ( HTML, HTMLBuilder, showHTML-   , 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+   , htmlPage, errorPage, link, linkTitle+   , h1, h2, h3, h4, preText, ul, table+   , text, image, space, tt, spaces, highlightXML+   , font, bold, italic, para, ttText, hr, br, pre, center, bullet, divClass    ) where  import Text.XML hiding (text) import qualified Text.XML as XML import Control.Monad+import Data.Char+import Data.List  type HTML = XML @@ -33,7 +36,8 @@ htmlPage :: String -> Maybe String -> HTMLBuilder -> HTML htmlPage title css body = makeXML "html" $ do    element "head" $ do-      element "title" (text title)+      unless (null title) $+         element "title" (text title)       case css of          Nothing -> return ()          Just n  -> element "link" $ do@@ -51,6 +55,10 @@ link url body = element "a" $     ("href" .=. url) >> body +linkTitle :: String -> String -> HTMLBuilder -> HTMLBuilder+linkTitle url title body = element "a" $ +   ("href" .=. url) >> ("title" .=. title) >> body+ center :: HTMLBuilder -> HTMLBuilder center = element "center" @@ -66,6 +74,8 @@ h4 :: String -> HTMLBuilder h4 = element "h4" . text +font :: String -> HTMLBuilder -> HTMLBuilder+font n = element "font" . ("class" .=. n >>)  bold, italic :: HTMLBuilder -> HTMLBuilder bold   = element "b" @@ -98,12 +108,15 @@ table :: [[HTMLBuilder]] -> HTMLBuilder table rows = element "table" $ do    "border" .=. "1"-   mapM_ (element "tr" . mapM_ (element "td")) rows--noBorderTable :: [[HTMLBuilder]] -> HTMLBuilder-noBorderTable rows = element "table" $ do-   "border"      .=. "0"-   mapM_ (element "tr" . mapM_ (element "td")) rows+   forM_ (zip [0::Int ..] rows) $ \(i, r) ->+      element "tr" $ do+         "class" .=. getClass i+         mapM_ (element "td") r+ where+   getClass i+      | i == 0    = "topRow"+      | even i    = "evenRow"+      | otherwise = "oddRow"   spaces :: Int -> HTMLBuilder spaces n = replicateM_ n space@@ -117,3 +130,36 @@  text :: String -> HTMLBuilder text = XML.text++divClass :: String -> HTMLBuilder -> HTMLBuilder+divClass n body = element "div" ("class" .=. n >> body)++-- A simple XML highlighter+highlightXML :: Bool -> XML -> HTMLBuilder+highlightXML nice+   | nice      = builder . highlight . makeXML "pre" . text . showXML+   | otherwise = builder . highlight . makeXML "tt"  . text . compactXML+ where+   highlight :: HTML -> HTML+   highlight html = html {content = map (either (Left . f) Right) (content html)}+   +   -- find <+   f :: String -> String+   f [] = []+   f list@(x:xs)+      | "&lt;/" `isPrefixOf` list = -- close tag+           let (as, bs) = span isAlphaNum (drop 5 list) +           in "<font color='blue'>&lt;/" ++ as ++ "<font color='green'>" ++ g bs+      | "&lt;" `isPrefixOf` list = -- open tag+           let (as, bs) = span isAlphaNum (drop 4 list) +           in "<font color='blue'>&lt;" ++ as ++ "<font color='green'>" ++ g bs+      | otherwise = x : f xs+   -- find >+   g [] = []+   g list@(x:xs) +      | "/&gt;" `isPrefixOf` list =+           "</font>/&gt;</font>" ++ f (drop 5 list)+      | "&gt;" `isPrefixOf` list =+           "</font>&gt;</font>" ++ f (drop 4 list)+      | x=='=' = "<font color='orange'>=</font>" ++ g xs+      | otherwise = x : g xs
src/Text/JSON.hs view
@@ -17,7 +17,7 @@    , InJSON(..)                           -- type class"
    , lookupM
    , parseJSON, showCompact, showPretty   -- parser and pretty-printers
-   , jsonRPC, JSON_RPC_Handler, testMe
+   , jsonRPC, JSON_RPC_Handler, propEncoding
    ) where
 
 import Text.Parsing
@@ -228,7 +228,7 @@ lookupM _ _ = fail "expecting a JSON object"
 
 indent :: Int -> String -> String
-indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines
+indent n = unlines . map (replicate n ' ' ++) . lines
 
 --------------------------------------------------------
 -- JSON-RPC over HTTP
@@ -255,18 +255,18 @@ 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
+         Number a  -> variant (0 :: Int) . coarbitrary a
+         String s  -> variant (1 :: Int) . coarbitrary s
+         Boolean b -> variant (2 :: Int) . coarbitrary b
+         Array xs  -> variant (3 :: Int) . coarbitrary xs
+         Object xs -> variant (4 :: Int) . coarbitrary xs
+         Null      -> variant (5 :: Int)
 
 instance Arbitrary Number where
    arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary]
 instance CoArbitrary Number where
-   coarbitrary (I n) = variant 0 . coarbitrary n
-   coarbitrary (D d) = variant 1 . coarbitrary d
+   coarbitrary (I n) = variant (0 :: Int) . coarbitrary n
+   coarbitrary (D d) = variant (1 :: Int) . coarbitrary d
 
 arbJSON :: Int -> Gen JSON
 arbJSON n 
@@ -293,10 +293,6 @@    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+propEncoding :: Property
+propEncoding = property $ \a ->  
+   parseJSON (show a) == Just a
src/Text/OpenMath/Object.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -XDeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 -----------------------------------------------------------------------------
 -- Copyright 2010, Open Universiteit Nederland. This file is distributed 
 -- under the terms of the GNU General Public License. For more information, 
@@ -15,6 +15,7 @@    ) where
 
 import Data.Char (isSpace)
+import Data.Generics.Uniplate hiding (children)
 import Data.List (nub)
 import Data.Maybe
 import Data.Typeable
@@ -35,22 +36,24 @@    toXML   = omobj2xml
    fromXML = either fail return . xml2omobj
 
+instance Uniplate OMOBJ where
+   uniplate omobj =
+      case omobj of
+         OMA xs        -> (xs, OMA)
+         OMBIND a ss b -> ([a, b], \[x, y] -> OMBIND x ss y)
+         _             -> ([], \_ -> omobj)
+
 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 _              = []
+getOMVs omobj = nub [ x | OMV x <- universe omobj ]
 
 ----------------------------------------------------------
 -- conversion functions: XML <-> OMOBJ
    
 xml2omobj :: XML -> Either String OMOBJ
-xml2omobj xml =
-   case xml of  
+xml2omobj xmlTop =
+   case xmlTop of  
       Element "OMOBJ" _ [Right e] -> rec e
-      _ -> fail $ "expected an OMOBJ tag" ++ show xml
+      _ -> fail $ "expected an OMOBJ tag" ++ show xmlTop
  where
    rec xml =
       case content xml of
@@ -61,8 +64,8 @@             
          [] | name xml == "OMS" -> do
             let mcd = findAttribute "cd" xml
-            name <- findAttribute "name" xml
-            return (OMS (Symbol mcd name))
+            n <- findAttribute "name" xml
+            return (OMS (Symbol mcd n))
 
          [Left s] | name xml == "OMI" ->
             case scanInt (Pos 0 0) s of
+ src/Text/OpenMath/Tests.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------+module Text.OpenMath.Tests (propEncoding) where++import Control.Monad+import Text.OpenMath.Object+import Test.QuickCheck+import Text.OpenMath.Dictionary.Arith1+import Text.OpenMath.Dictionary.Calculus1+import Text.OpenMath.Dictionary.Fns1+import Text.OpenMath.Dictionary.Linalg2+import Text.OpenMath.Dictionary.List1+import Text.OpenMath.Dictionary.Logic1+import Text.OpenMath.Dictionary.Nums1+import Text.OpenMath.Dictionary.Quant1+import Text.OpenMath.Dictionary.Relation1+import Text.OpenMath.Dictionary.Transc1++arbOMOBJ :: Gen OMOBJ+arbOMOBJ = sized rec + where+   symbols = arith1List ++ calculus1List ++ fns1List ++ linalg2List +++      list1List ++ logic1List ++ nums1List ++ quant1List ++ +      relation1List ++ transc1List+ +   rec 0 = frequency +      [ (1, liftM OMI arbitrary)+      , (1, liftM OMF arbitrary)+      , (1, liftM OMV arbitrary)+      , (5, oneof $ map (return . OMS) symbols)+      ]+   rec n = frequency+      [ (1, rec 0)+      , (3, choose (1,4) >>= liftM OMA . (`replicateM` f))+      , (1, liftM3 OMBIND f arbitrary f)+      ]+    where+      f = rec (n `div` 2)++propEncoding :: Property+propEncoding = forAll arbOMOBJ $ \x -> xml2omobj (omobj2xml x) == Right x
src/Text/Parsing.hs view
@@ -24,7 +24,7 @@      -- * Derived token parsers
    , pParens, pBracks, pCurly, pCommas, pLines, pInteger
      -- * UU parser combinators
-   , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1
+   , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1, pSepList
    , pChainl, pChainr, pChoice, pFail
     -- * Operator table (parser)
    , OperatorTable, Associativity(..), pOperators
@@ -48,8 +48,6 @@ -- | A parser with tokens as symbol type
 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)
@@ -107,19 +105,31 @@ pQConid = makeTokT isTokenQConId TokenQConId
 pString = makeTokS isTokenString TokenString
 pInt    = makeTokN isTokenInt    TokenInt
-pReal   = makeTokN isTokenReal   TokenReal
+pReal   = makeTokR 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)
+makeTokS :: (Token -> Maybe a) -> (String -> Pos -> Token) -> TokenParser a
+makeTokS f con = makeTok (fromJust . f) (con minString) (con maxString)
 
-makeTok f a con1 con2 = 
-   (fromMaybe a . f) UU.<$> con1 minPos UU.<..> con2 maxPos
+makeTokT :: (Token -> Maybe a) -> (String -> String -> Pos -> Token) -> TokenParser a
+makeTokT f con = makeTok (fromJust . f) (con minString minString) (con maxString maxString)
 
+makeTokN :: (Token -> Maybe Int) -> (Int -> Pos -> Token) -> TokenParser Int
+makeTokN f con = makeTok (fromJust . f) (con minBound) (con maxBound)
+
+makeTokR :: (Token -> Maybe Double) -> (Double -> Pos -> Token) -> TokenParser Double
+makeTokR f con = makeTok (fromJust . f) (con (-d)) (con d)
+ where d = (10 :: Double) ^ (500 :: Int)
+
+makeTokA :: (a -> Pos -> Token) -> a -> TokenParser a
+makeTokA con a = makeTok (const a) (con a) (con a)
+
+makeTok :: (Token -> a) -> (Pos -> Token) -> (Pos -> Token) -> TokenParser a
+makeTok f con1 con2 = 
+   f UU.<$> con1 minPos UU.<..> con2 maxPos
+
 minPos, maxPos :: Pos
 minPos = Pos minBound minBound
 maxPos = Pos maxBound maxBound
@@ -128,14 +138,6 @@ 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
  
@@ -178,10 +180,10 @@ (*>) = (UU.*>)
 
 (<*) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s a
-(<*)   a = (UU.<*) a
+(<*) = (UU.<*)
 
 (<|>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s a -> Parser s a
-(<|>)   a = (UU.<|>) a
+(<|>) = (UU.<|>)
 
 optional :: (Ord s, UU.Symbol s) => Parser s a -> a -> Parser s a
 optional = UU.opt
@@ -190,6 +192,9 @@ pList = UU.pList
 pList1 = UU.pList1
 
+pSepList :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s [a]
+pSepList p q = (:) <$> p <*> pList (q *> p)
+
 pChainl, pChainr :: (Ord s, UU.Symbol s) => Parser s (a -> a -> a) -> Parser s a -> Parser s a
 pChainl = UU.pChainl
 pChainr = UU.pChainr
@@ -212,8 +217,8 @@ 
 -- | Construct a parser using an operator table
 pOperators :: OperatorTable a -> TokenParser a -> TokenParser a
-pOperators table p = foldr op p table 
- where op (a, ops) q = 
+pOperators table p = foldr combine p table 
+ where combine (a, ops) q = 
           case a of
              -- The NoMix variant is actually hard to define efficiently. Since we should not mix operators
              -- that have the same priority, we have to inspect which operator we are dealing with before
src/Text/Scanning.hs view
@@ -29,6 +29,7 @@ import Control.Monad import Data.List import Data.Char+import qualified UU.Parsing as UU  ---------------------------------------------------------- -- * Data types@@ -50,6 +51,8 @@    | TokenReal    Double Pos  deriving (Eq, Ord) +instance UU.Symbol Token+ instance Show Pos where    show (Pos l c) = "(" ++ show l ++ "," ++ show c ++ ")" @@ -189,7 +192,7 @@                  make f = f s pos : rec newp xs                  newp   = incr (length s) pos               _ -> error "unexpected case in scanner"-      | isNumber input =+      | isNum input =            case scanNumber pos input of               Just (Left i,  newp, xs) -> TokenInt  i pos : rec newp xs               Just (Right d, newp, xs) -> TokenReal d pos : rec newp xs@@ -217,16 +220,16 @@            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+   isNum :: String -> Bool+   isNum ('-':x:_) = isDigit x && unaryMinus scanner+   isNum (x:_)     = isDigit x+   isNum _         = False  scanIdentifier :: Scanner -> String -> Maybe (Maybe String, String, String) scanIdentifier scanner (x:rest) | isAlpha x = -   case break (not . isIdentifierCharacter scanner) rest of+   case span (isIdentifierCharacter scanner) rest of       (xs, '.':y:rest2) | qualifiedIdentifiers scanner && isAlpha y -> -         let (ys, zs) = break (not . isIdentifierCharacter scanner) rest2+         let (ys, zs) = span (isIdentifierCharacter scanner) rest2          in Just (Just (x:xs), y:ys, zs)       (xs, ys) ->           Just (Nothing, x:xs, ys)@@ -259,7 +262,7 @@ fractionPart _ _ = Nothing  powerPart :: Pos -> String -> Maybe (Pos, String)-powerPart pos (s:rest) | s == 'e' || s == 'E' = do+powerPart pos (s:rest) | s `elem` "eE" = do    (_, p, ys) <- scanInt pos rest    return (incr 1 p, ys) powerPart _ _ = Nothing@@ -273,7 +276,7 @@  scanNatural :: Pos -> String -> Maybe (Int, Pos, String) scanNatural pos input = do-   let (xs, ys) = break (not . isDigit) input+   let (xs, ys) = span isDigit input    guard (not (null xs))    let nat = foldl' (\a b -> a*10+ord b-48) 0 xs    return (nat, incr (length xs) pos, ys)
src/Text/UTF8.hs view
@@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- module Text.UTF8     ( encode, encodeM, decode, decodeM-   , isUTF8, allBytes, testEncoding+   , isUTF8, allBytes, propEncoding    ) where  import Data.Char@@ -105,10 +105,8 @@ -- Test encoding  -- | QuickCheck internal encoding/decoding functions-testEncoding :: IO () -testEncoding = do-   putStrLn "** UTF8 encoding"-   quickCheck $ forAll (sized gen) valid+propEncoding :: Property+propEncoding = forAll (sized gen) valid  where    gen n = replicateM n someChar    someChar = liftM chr $ oneof
src/Text/XML.hs view
@@ -63,7 +63,7 @@  where 
    rec i (Element n as xs) =
       let ipl  = i+2 
-          cd n = Left ('\n' : replicate n ' ')
+          cd j = Left ('\n' : replicate j ' ')
           f    = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)])
           body | null xs   = xs
                | otherwise = concatMap f xs ++ [cd i]
src/Text/XML/Interface.hs view
@@ -21,7 +21,8 @@ import Control.Monad.Error () import qualified Text.XML.Document as D import System.FilePath (takeDirectory, pathSeparator)-import Data.Char (chr)+import Data.Char (chr, ord)+import Data.Maybe  data Element = Element    { name       :: Name@@ -64,9 +65,7 @@    refToContent :: D.Reference -> Content    refToContent (D.CharRef i)   = [Left [chr i]]    refToContent (D.EntityRef s) = -      case lookup s entities of-         Just c  -> c-         Nothing -> undefined -- [] -- error+      fromJust (lookup s entities)     entities :: [(String, Content)]    entities = @@ -92,13 +91,21 @@  where    toElement :: Element -> D.Element    toElement (Element n as c) =-      D.Element n (map toAttribute as) (map toXML c)+      D.Element n (map toAttribute as) (concatMap toXML c)        toAttribute :: Attribute -> D.Attribute    toAttribute (n := s) = (D.:=) n (map Left s)    -   toXML :: Either String Element -> D.XML-   toXML = either D.CharData (D.Tagged . toElement)+   toXML :: Either String Element -> [D.XML]+   toXML = either fromString (return . D.Tagged . toElement)+   +   fromString :: String -> [D.XML]+   fromString [] = []+   fromString xs@(hd:tl) +      | null xs1  = D.Reference (D.CharRef (ord hd)) : fromString tl+      | otherwise = D.CharData xs1 : fromString xs2+    where+      (xs1, xs2) = break ((> 127) . ord) xs  -----------------------------------------------------
src/Text/XML/ParseLib.hs view
@@ -62,11 +62,11 @@             P.notFollowedBy (P.try (string xs >> return ' '))             return x       -symbol :: Char -> Parser Char-symbol = P.char+symbol :: Char -> Parser ()+symbol c = P.char c >> return () -string :: String -> Parser String-string = P.string+string :: String -> Parser ()+string s = P.string s >> return ()  ranges :: [(Char, Char)] -> Parser Char ranges xs = P.choice [ a <..> b | (a, b) <- xs ]
src/Text/XML/Parser.hs view
@@ -13,8 +13,7 @@ --    http://www.w3.org/TR/2006/REC-xml-20060816  -------------------------------------------------------------------------------module Text.XML.Parser where+module Text.XML.Parser (document, extParsedEnt, extSubset) where  import Prelude hiding (seq) import Control.Monad@@ -41,7 +40,7 @@ -- [1]   	document	   ::=   	 prolog element Misc* document :: Parser XMLDoc document = do -   (mxml, dtd) <- prolog+   (mxml, mdtd) <- prolog    rt <- element    miscs    let (ver, enc, sa) = @@ -52,7 +51,7 @@       { D.versionInfo = ver       , D.encoding    = enc       , D.standalone  = sa-      , D.dtd         = dtd+      , D.dtd         = mdtd       , D.externals   = []       , root        = rt       }@@ -61,19 +60,21 @@ -- ** 2.2 Characters  -- [2]   	Char	   ::=   	#x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]+{- char :: Parser Char char = ranges xs <|> oneOf "\x9\xA\xD"  where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')]+-}  -------------------------------------------------- -- ** 2.3 Common Syntactic Constructs  -- [3]   	S	   ::=   	(#x20 | #x9 | #xD | #xA)+-space :: Parser String-space = many1 (oneOf "\x20\x9\xA\xD")+space :: Parser ()+space = many1 (oneOf "\x20\x9\xA\xD") >> return () -mspace :: Parser String -- for S?-mspace = many (oneOf "\x20\x9\xA\xD")+mspace :: Parser () -- for S?+mspace = many (oneOf "\x20\x9\xA\xD") >> return ()  -- [4]   	NameChar	   ::=   	 Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender nameChar :: Parser Char@@ -86,17 +87,21 @@    cs <- many nameChar    return (c:cs) +{- -- [6]   	Names	   ::=   	 Name (#x20 Name)* names :: Parser [String] names = sepBy1 name (symbol '\x20')+-}  -- [7]   	Nmtoken	   ::=   	(NameChar)+ nmtoken :: Parser String nmtoken = many1 nameChar +{- -- [8]   	Nmtokens	   ::=   	 Nmtoken (#x20 Nmtoken)* nmtokens :: Parser [String] nmtokens = sepBy1 nmtoken (symbol '\x20')+-}  -- [9]   	EntityValue	   ::=   	'"' ([^%&"] | PEReference | Reference)* '"'  --                           |  "'" ([^%&'] | PEReference | Reference)* "'"@@ -128,7 +133,7 @@  where    xs = [('a', 'z'), ('A', 'Z'), ('0', '9')]    singleQuote-      | withSingleQuote = symbol '\''+      | withSingleQuote = symbol '\'' >> return '\''       | otherwise       = fail "pubidChar"  --------------------------------------------------@@ -153,9 +158,7 @@ pInstr :: Parser String pInstr = packed (string "<?") p (string "?>")  where -   p = do -      piTarget-      option "" (space >> stopOn ["?>"])+   p = piTarget >> option "" (space >> stopOn ["?>"])  -- [17]   	PITarget	   ::=   	 Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) piTarget :: Parser String@@ -216,7 +219,9 @@  -- [26]   	VersionNum	   ::=   	'1.0' versionNum :: Parser String-versionNum = string "1.0"+versionNum = do+   string "1.0"+   return "1.0"  -- [27]   	Misc	   ::=   	 Comment | PI | S misc :: Parser ()
src/Text/XML/TestSuite.hs view
@@ -17,7 +17,6 @@ import Text.XML.Interface import Text.XML.Document (trim) import Control.Monad.Error-import Data.List import Data.Maybe  {-testje = do
src/Text/XML/Unicode.hs view
@@ -22,6 +22,7 @@  data Tree a = Node (Tree a) a (Tree a) | Leaf +isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool isLetter        = checkTree $ makeTree letterMap isExtender      = checkTree $ makeTree extenderMap isDigit         = checkTree $ makeTree digitMap@@ -47,6 +48,7 @@ f :: Char -> (Char, Char) f c = (c, c) +letterMap :: [(Char, Char)] letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap  merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)]@@ -55,8 +57,10 @@    | otherwise = y:merge (x:xs) ys merge xs ys = xs++ys +extraMap :: [(Char, Char)] extraMap = map f "\161\170\184\185" +controlMap :: [(Char, Char)] controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'),    ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'),    ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'),@@ -65,6 +69,7 @@    ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'),    ('\x10FFFE', '\x10FFFF')] +baseCharMap :: [(Char, Char)] baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'),     ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'),     ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'), @@ -121,9 +126,11 @@    f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'),    ('\x3105','\x312C'), ('\xAC00','\xD7A3') ] +ideographicMap :: [(Char, Char)] ideographicMap = [ ('\x4E00','\x9FA5'),     f '\x3007' , ('\x3021','\x3029') ] -   ++combiningCharMap :: [(Char, Char)] combiningCharMap = [('\x0300','\x0345'),     ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'),     ('\x05A3','\x05B9'), ('\x05BB','\x05BD'),  f '\x05BF' , ('\x05C1','\x05C2'), @@ -151,6 +158,7 @@    ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' ,     ('\x302A','\x302F'), f '\x3099' , f '\x309A' ]  +digitMap :: [(Char, Char)] digitMap = [ ('\x0030','\x0039'),     ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'),     ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'), @@ -158,6 +166,7 @@    ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'),     ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')] +extenderMap :: [(Char, Char)] extenderMap = [f '\x00B7' , f '\x02D0' ,     f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035')     , ('\x309D','\x309E'), ('\x30FC','\x30FE') ]