diff --git a/CREDITS.txt b/CREDITS.txt --- a/CREDITS.txt +++ b/CREDITS.txt @@ -1,6 +1,6 @@ AUTHORS -Bastiaan Heeren, Alex gerdes, Johan Jeuring +Bastiaan Heeren, Alex Gerdes, Johan Jeuring CREDITS diff --git a/ideas.cabal b/ideas.cabal --- a/ideas.cabal +++ b/ideas.cabal @@ -1,5 +1,5 @@ name: ideas -version: 0.5.8 +version: 0.6 synopsis: Feedback services for intelligent tutoring systems homepage: http://ideas.cs.uu.nl/ description: @@ -9,7 +9,7 @@ and Activemath. category: Education -copyright: (c) 2009 +copyright: (c) 2010 license: GPL license-file: LICENSE.txt author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring @@ -17,157 +17,192 @@ stability: provisional extra-source-files: CREDITS.txt build-type: Simple -cabal-version: >= 1.2.1 -tested-with: GHC == 6.10.1 +cabal-version: >= 1.8.0.2 +tested-with: GHC == 6.12.1 -------------------------------------------------------------------------------- -Executable ideas - Main-is: Service/Main.hs - ghc-options: -W -fwarn-tabs -fwarn-duplicate-exports - hs-source-dirs: src +Executable ideas + Main-is: Main.hs + ghc-options: -W -fwarn-tabs -fwarn-duplicate-exports + hs-source-dirs: src other-modules: - Common.Apply , - Common.Context , - Common.Derivation , - Common.Exercise , - Common.Grammar , - Common.Rewriting , - Common.Rewriting.AC , - Common.Rewriting.Confluence , - Common.Rewriting.Difference , - Common.Rewriting.MetaVar , - Common.Rewriting.RewriteRule , - Common.Rewriting.Substitution , - Common.Rewriting.Unification , - Common.Strategy , - Common.Transformation , - Common.Traversable , - Common.Uniplate , - Common.Utils , - Common.View , - Domain.LinearAlgebra , - Domain.LinearAlgebra.Checks , - Domain.LinearAlgebra.EquationsRules , - Domain.LinearAlgebra.Exercises , - Domain.LinearAlgebra.GramSchmidtRules , - Domain.LinearAlgebra.LinearSystem , - Domain.LinearAlgebra.LinearView , - Domain.LinearAlgebra.Matrix , - Domain.LinearAlgebra.MatrixRules , - Domain.LinearAlgebra.Parser , - Domain.LinearAlgebra.Strategies , - Domain.LinearAlgebra.Symbols , - Domain.LinearAlgebra.Vector , - Domain.Logic , - Domain.Logic.BuggyRules , - Domain.Logic.Exercises , - Domain.Logic.FeedbackText , - Domain.Logic.Formula , - Domain.Logic.GeneralizedRules , - Domain.Logic.Generator , - Domain.Logic.Parser , - Domain.Logic.Rules , - Domain.Logic.Strategies , - Domain.Math.Approximation , - Domain.Math.Data.Equation , - Domain.Math.Data.OrList , - Domain.Math.Data.Polynomial , - Domain.Math.Data.PrimeFactors , - Domain.Math.Data.SquareRoot , - Domain.Math.DerivativeExercise , - Domain.Math.DerivativeRules , - Domain.Math.Equation.CoverUpExercise , - Domain.Math.Equation.CoverUpRules , - Domain.Math.Equation.Views , - Domain.Math.Examples.DWO1 , - Domain.Math.Examples.DWO2 , - Domain.Math.Expr , - Domain.Math.Expr.Conversion , - Domain.Math.Expr.Data , - Domain.Math.Expr.Parser , - Domain.Math.Expr.Symbolic , - Domain.Math.Expr.Symbols , - Domain.Math.Expr.Views , - Domain.Math.Numeric.Exercises , - Domain.Math.Numeric.Generators , - Domain.Math.Numeric.Laws , - Domain.Math.Numeric.Rules , - Domain.Math.Numeric.Strategies , - Domain.Math.Numeric.Views , - Domain.Math.Polynomial.BuggyRules , - Domain.Math.Polynomial.CleanUp , - Domain.Math.Polynomial.Exercises , - Domain.Math.Polynomial.Generators , - Domain.Math.Polynomial.Rules , - Domain.Math.Polynomial.Strategies , - Domain.Math.Polynomial.Views , - Domain.Math.Power.Views , - Domain.Math.Simplification , - Domain.Math.SquareRoot.Views , - Domain.Math.Strategy.BrokenEquations , - Domain.Math.Strategy.Modulus , - Domain.Math.Strategy.SquareRootEquations , - Domain.Math.Strategy.SquareRootSimplification , - Domain.Programming , - Domain.RelationAlgebra , - Domain.RelationAlgebra.Equivalence , - Domain.RelationAlgebra.Exercises , - Domain.RelationAlgebra.Formula , - Domain.RelationAlgebra.Generator , - Domain.RelationAlgebra.Parser , - Domain.RelationAlgebra.Rules , - Domain.RelationAlgebra.Strategies , - Service.ExerciseList , - Service.FeedbackText , - Service.LoggingDatabase , - Service.Main , - Service.ModeJSON , - Service.ModeXML , - Service.Options , - Service.ProblemDecomposition , - Service.Request , - Service.Revision , - Service.SearchSpace , - Service.ServiceList , - Service.TypedAbstractService , - Service.Types , - Text.HTML , - Text.JSON , - Text.OpenMath.ContentDictionary , - Text.OpenMath.Dictionary.Arith1 , - Text.OpenMath.Dictionary.Calculus1 , - Text.OpenMath.Dictionary.Fns1 , - Text.OpenMath.Dictionary.Linalg2 , - Text.OpenMath.Dictionary.List1 , - Text.OpenMath.Dictionary.Logic1 , - Text.OpenMath.Dictionary.Nums1 , - Text.OpenMath.Dictionary.Relation1 , - Text.OpenMath.Dictionary.Transc1 , - Text.OpenMath.MakeSymbols , - Text.OpenMath.Object , - Text.OpenMath.Reply , - Text.OpenMath.Request , - Text.OpenMath.Symbol , - Text.Parsing , - Text.UTF8 , - Text.XML , - Text.XML.Document , - Text.XML.Interface , - Text.XML.ParseLib , - Text.XML.Parser , - Text.XML.TestSuite , - Text.XML.Unicode - build-depends: base >= 3.0 && < 4.0, + Common.Apply + Common.Context + Common.Derivation + Common.Exercise + Common.Navigator + Common.Rewriting.AC + Common.Rewriting.Difference + Common.Rewriting.MetaVar + Common.Rewriting.RewriteRule + Common.Rewriting.Substitution + Common.Rewriting.Term + Common.Rewriting.Unification + Common.Rewriting + Common.Strategy.Abstract + Common.Strategy.BiasedChoice + Common.Strategy.Combinators + Common.Strategy.Configuration + Common.Strategy.Core + Common.Strategy.Grammar + Common.Strategy.Location + Common.Strategy.Prefix + Common.Strategy + Common.Transformation + Common.Traversable + Common.Uniplate + Common.Utils + Common.View + Documentation.DefaultPage + Documentation.ExercisePage + Documentation.LatexRules + Documentation.Make + Documentation.OverviewPages + Documentation.SelfCheck + Documentation.ServicePage + Documentation.TestsPage + Domain.LinearAlgebra.Checks + Domain.LinearAlgebra.EquationsRules + Domain.LinearAlgebra.Exercises + Domain.LinearAlgebra.GramSchmidtRules + Domain.LinearAlgebra.LinearSystem + Domain.LinearAlgebra.LinearView + Domain.LinearAlgebra.Matrix + Domain.LinearAlgebra.MatrixRules + Domain.LinearAlgebra.Parser + Domain.LinearAlgebra.Strategies + Domain.LinearAlgebra.Symbols + Domain.LinearAlgebra.Vector + Domain.LinearAlgebra + Domain.Logic.BuggyRules + Domain.Logic.Exercises + Domain.Logic.FeedbackText + Domain.Logic.Formula + Domain.Logic.GeneralizedRules + Domain.Logic.Generator + Domain.Logic.Parser + Domain.Logic.Rules + Domain.Logic.Strategies + Domain.Logic + Domain.Math.Approximation + Domain.Math.Clipboard + Domain.Math.Data.Interval + Domain.Math.Data.OrList + Domain.Math.Data.Polynomial + Domain.Math.Data.PrimeFactors + Domain.Math.Data.Relation + Domain.Math.Data.SquareRoot + Domain.Math.DerivativeExercise + Domain.Math.DerivativeRules + Domain.Math.Equation.CoverUpExercise + Domain.Math.Equation.CoverUpRules + Domain.Math.Equation.Views + Domain.Math.Examples.DWO1 + Domain.Math.Examples.DWO2 + Domain.Math.Examples.DWO3 + Domain.Math.Expr.Data + Domain.Math.Expr.Parser + Domain.Math.Expr.Symbolic + Domain.Math.Expr.Symbols + Domain.Math.Expr.Views + Domain.Math.Expr + Domain.Math.Numeric.Exercises + Domain.Math.Numeric.Generators + Domain.Math.Numeric.Laws + Domain.Math.Numeric.Rules + Domain.Math.Numeric.Strategies + Domain.Math.Numeric.Tests + Domain.Math.Numeric.Views + Domain.Math.Polynomial.BuggyRules + Domain.Math.Polynomial.CleanUp + Domain.Math.Polynomial.Equivalence + Domain.Math.Polynomial.Exercises + Domain.Math.Polynomial.Generators + Domain.Math.Polynomial.IneqExercises + Domain.Math.Polynomial.Rules + Domain.Math.Polynomial.Strategies + Domain.Math.Polynomial.Tests + Domain.Math.Polynomial.Views + Domain.Math.Power.Exercises + Domain.Math.Power.Rules + Domain.Math.Power.Strategies + Domain.Math.Power.Views + Domain.Math.Simplification + Domain.Math.SquareRoot.Tests + Domain.Math.SquareRoot.Views + Domain.RegularExpr.Definitions + Domain.RegularExpr.Exercises + Domain.RegularExpr.Expr + Domain.RegularExpr.Parser + Domain.RegularExpr.Strategy + Domain.RelationAlgebra.Equivalence + Domain.RelationAlgebra.Exercises + Domain.RelationAlgebra.Formula + Domain.RelationAlgebra.Generator + Domain.RelationAlgebra.Parser + Domain.RelationAlgebra.Rules + Domain.RelationAlgebra.Strategies + Domain.RelationAlgebra + Main.ExerciseList + Main.LoggingDatabase + Main.Options + Main.Revision + Main + Service.Diagnose + Service.DomainReasoner + Service.ExercisePackage + Service.FeedbackText + Service.ModeJSON + Service.ModeXML + Service.ProblemDecomposition + Service.Request + Service.RulesInfo + Service.ServiceList + Service.StrategyInfo + Service.Submit + Service.TypedAbstractService + Service.TypedExample + Service.Types + Text.HTML + Text.JSON + Text.OpenMath.ContentDictionary + Text.OpenMath.Dictionary.Arith1 + Text.OpenMath.Dictionary.Calculus1 + Text.OpenMath.Dictionary.Fns1 + Text.OpenMath.Dictionary.Linalg2 + Text.OpenMath.Dictionary.List1 + Text.OpenMath.Dictionary.Logic1 + Text.OpenMath.Dictionary.Nums1 + Text.OpenMath.Dictionary.Quant1 + Text.OpenMath.Dictionary.Relation1 + Text.OpenMath.Dictionary.Transc1 + Text.OpenMath.FMP + Text.OpenMath.MakeSymbols + Text.OpenMath.Object + Text.OpenMath.Symbol + Text.Parsing + Text.Scanning + Text.UTF8 + Text.XML.Document + Text.XML.Interface + Text.XML.ParseLib + Text.XML.Parser + Text.XML.TestSuite + Text.XML.Unicode + Text.XML + build-depends: base >= 4.2 && < 5, + directory, time, mtl, cgi, containers, - QuickCheck, + QuickCheck >= 2.1.0.3, random, uulib, filepath, - parsec + parsec, + old-time -------------------------------------------------------------------------------- diff --git a/src/Common/Apply.hs b/src/Common/Apply.hs --- a/src/Common/Apply.hs +++ b/src/Common/Apply.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Common/Context.hs b/src/Common/Context.hs --- a/src/Common/Context.hs +++ b/src/Common/Context.hs @@ -1,5 +1,6 @@ +{-# OPTIONS -XDeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -8,191 +9,236 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- A context for a term that maintains a current focus and an environment of +-- A context for a term that maintains an environment of -- key-value pairs. A context is both showable and parsable. -- ----------------------------------------------------------------------------- module Common.Context ( -- * Abstract data type - Context, inContext, fromContext, showContext, parseContext - -- * Variable environment - , Var(..), intVar, integerVar, boolVar, get, set, change - -- * Location (current focus) - , Location, location, setLocation, changeLocation - , currentFocus, changeFocus, locationDown, locationUp - , makeLocation, fromLocation + Context, fromContext, newContext, getEnvironment + -- * Key-value pair environment (abstract) + , Environment, emptyEnv, nullEnv, keysEnv, lookupEnv, storeEnv + , diffEnv, deleteEnv + -- * Variables + , Var, newVar, makeVar -- * Lifting - , liftToContext, ignoreContext - ) where + , liftToContext, liftTransContext, contextView + -- * Context Monad + , ContextMonad, runCM, readVar, writeVar, modifyVar + , maybeCM, withCM, evalCM -- , listCM, runListCM, withListCM + ) where +import Common.Navigator + +import qualified Common.Navigator as Navigator import Common.Transformation -import Common.Uniplate -import Common.Utils +import Common.Utils (safeHead, commaList, readM) +import Common.View import Control.Monad -import Data.Char +import Data.Maybe import Data.Dynamic -import Data.List -import Test.QuickCheck import qualified Data.Map as M - ---------------------------------------------------------- -- Abstract data type --- | Abstract data type for a context: a context stores an envrionent (key-value pairs) and --- a current focus (list of integers) -data Context a = C Location Environment a +-- | Abstract data type for a context: a context stores an envrionent +-- (key-value pairs) and a value +data Context a = C + { getEnvironment :: Environment -- ^ Returns the environment + , getNavigator :: Navigator a -- ^ Retrieve a value from its context + } -instance Eq a => Eq (Context a) where - x == y = fromContext x == fromContext y +fromContext :: Monad m => Context a -> m a +fromContext = leave . getNavigator -instance Ord a => Ord (Context a) where - x `compare` y = fromContext x `compare` fromContext y +instance Eq a => Eq (Context a) where + x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y) instance Show a => Show (Context a) where - show c = showContext c ++ ";" ++ show (fromContext c) - -instance Functor Context where - fmap f (C loc env a) = C loc env (f a) + show (C env a) = + let rest | null (keysEnv env) = "" + | otherwise = " {" ++ show env ++ "}" + in show a ++ rest -instance Arbitrary a => Arbitrary (Context a) where - arbitrary = liftM inContext arbitrary - coarbitrary = coarbitrary . fromContext +instance IsNavigator Context where + up (C env a) = liftM (C env) (up a) + allDowns (C env a) = map (C env) (allDowns a) + current (C _ a) = current a + location (C _ a) = Navigator.location a + changeM f (C env a) = liftM (C env) (changeM f a) --- | Put a value into a (default) context -inContext :: a -> Context a -inContext = C (L []) M.empty +instance TypedNavigator Context where + changeT f (C env a) = liftM (C env) (changeT f a) + currentT (C _ a) = currentT a + leaveT (C _ a) = leaveT a + castT v (C env a) = liftM (C env) (castT v a) --- | Retrieve a value from its context -fromContext :: Context a -> a -fromContext (C _ _ a) = a +-- | Construct a context +newContext :: Environment -> Navigator a -> Context a +newContext = C ---------------------------------------------------------- --- A simple parser and pretty-printer for contexts +-- Key-value pair environment (abstract) --- | Shows the context (without the embedded value) -showContext :: Context a -> String -showContext (C loc env _) = show loc ++ ";" ++ showEnv env +newtype Environment = Env { envMap :: M.Map String (Maybe Dynamic, String) } --- local helper function -showEnv :: Environment -> String -showEnv = concat . intersperse "," . map f . M.toList - where f (k, (_, v)) = k ++ "=" ++ v +instance Show Environment where + show = + let f (k, (_, v)) = k ++ "=" ++ v + in commaList . map f . M.toList . envMap --- | Parses a context: on a successful parse, the unit value is returned --- in the parsed context -parseContext :: String -> Maybe (Context ()) -parseContext s - | all isSpace s = - return (C (L []) M.empty ()) - | otherwise = do - (locString, envString) <- splitAtElem ';' s - loc <- case reads locString of - [(l, xs)] | all isSpace xs -> return l - _ -> Nothing - env <- if all isSpace envString then return M.empty else do - pairs <- mapM (splitAtElem '=') (splitsWithElem ',' envString) - let f (k, v) = (k, (Nothing, v)) - return $ M.fromList $ map f pairs - return (C loc env ()) +emptyEnv :: Environment +emptyEnv = Env M.empty +nullEnv :: Environment -> Bool +nullEnv = null . keysEnv + +keysEnv :: Environment -> [String] +keysEnv = M.keys . envMap + +lookupEnv :: Typeable a => String -> Environment -> Maybe a +lookupEnv s (Env m) = result + where + result -- Special case for result type String + | typeOf result == typeOf (Just "") = do + (_, txt) <- M.lookup s m + cast txt + | otherwise = do + (md, _) <- M.lookup s m + d <- md + fromDynamic d + +storeEnv :: (Typeable a, Show a) => String -> a -> Environment -> Environment +storeEnv = storeEnvWith show + +-- Generalized helper-function +storeEnvWith :: Typeable a => (a -> String) -> String -> a -> Environment -> Environment +storeEnvWith f s a (Env m) = Env (M.insert s pair m) + where -- Special case for type String + pair = + case cast a of + Just txt -> (Nothing, txt) + Nothing -> (Just (toDyn a), f a) + +diffEnv :: Environment -> Environment -> Environment +diffEnv (Env m1) (Env m2) = Env (M.filterWithKey p m1) + where p k (_, s) = maybe True ((/=s) . snd) (M.lookup k m2) + +deleteEnv :: String -> Environment -> Environment +deleteEnv s (Env m) = Env (M.delete s m) + ---------------------------------------------------------- --- Manipulating the variable environment +-- Variables --- local type synonym: can probably be simplified -type Environment = M.Map String (Maybe Dynamic, String) +-- | A variable has a name and a default value (for initializing). Each +-- stored value must be readable and showable. +data Var a = V + { varName :: String + , varInitial :: a + , varShow :: a -> String + , varRead :: String -> Maybe a + } --- | A variable has a name (for showing) and a default value (for initializing) -data Var a = String := a -- ^ Constructs a new variable +-- | Simple constructor function for creating a variable. Uses the +-- Show and Read type classes +newVar :: (Show a, Read a) => String -> a -> Var a +newVar = makeVar show readM --- | Make a new variable of type Int (initialized with 0) -intVar :: String -> Var Int -intVar = (:= 0) +-- | Extended constructor function for creating a variable. The show +-- and read functions are supplied explicitly. +makeVar :: (a -> String) -> (String -> Maybe a) -> String -> a -> Var a +makeVar showF readF s a = V s a showF readF --- | Make a new variable of type Integer (initialized with 0) -integerVar :: String -> Var Integer -integerVar = (:= 0) +---------------------------------------------------------- +-- Lifting rewrite rules --- | Make a new variable of type Bool (initialized with True) -boolVar :: String -> Var Bool -boolVar = (:= True) +-- | Lift a rule to operate on a term in a context +liftToContext :: Rule a -> Rule (Context a) +liftToContext = liftRuleIn thisView --- | Returns the value of a variable stored in a context -get :: (Read a, Typeable a) => Var a -> Context b -> a -get (s := a) (C _ env _) = - case M.lookup s env of - Nothing -> a -- return default value - Just (Just d, _) -> fromDyn d a -- use the stored dynamic (default value as backup) - Just (Nothing, s) -> - case reads s of -- parse the pretty-printed value (default value as backup) - [(b, rest)] | all isSpace rest -> b - _ -> a +liftTransContext :: Transformation a -> Transformation (Context a) +liftTransContext = liftTransIn thisView --- | Replaces the value of a variable stored in a context -set :: (Show a, Typeable a) => Var a -> a -> Context b -> Context b -set (s := _) a (C loc env b) = C loc (M.insert s (Just (toDyn a), show a) env) b +thisView :: View (Context a) (a, Context a) +thisView = makeView f g + where + f ctx = current ctx >>= \a -> Just (a, ctx) + g = uncurry replace --- | Updates the value of a variable stored in a context -change :: (Show a, Read a, Typeable a) => Var a -> (a -> a) -> Context b -> Context b -change v f c = set v (f (get v c)) c - +contextView :: MonadPlus m => ViewM m a b -> ViewM m (Context a) (Context b) +contextView v = makeView f g + where + f ca = do + guard (isTop ca) + a <- leave ca + b <- match v a + return (newContext (getEnvironment ca) (noNavigator b)) + g cb = fromJust $ do + guard (isTop cb) + b <- leave cb + let a = build v b + return (newContext (getEnvironment cb) (noNavigator a)) + ---------------------------------------------------------- --- Location (current focus) +-- Context monad --- | Type synonym for the current location (focus) -newtype Location = L [Int] deriving (Eq, Ord) +newtype ContextMonad a = CM (Environment -> [(a, Environment)]) -instance Show Location where - show (L is) = show is - -instance Read Location where - readsPrec n s = [ (L is, rest) | (is, rest) <- readsPrec n s ] +withCM :: (a -> ContextMonad b) -> Context a -> Maybe (Context b) +withCM f c = fromContext c >>= \a -> runCM (f a) (getEnvironment c) --- | Returns the current location of a context -location :: Context a -> Location -location (C loc _ _) = loc +evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b +evalCM f c = withCM f c >>= fromContext --- | Replaces the current location of a context -setLocation :: Location -> Context a -> Context a -setLocation loc (C _ env a) = C loc env a +runCM :: ContextMonad a -> Environment -> Maybe (Context a) +runCM (CM f) env = do + (a, e) <- safeHead (f env) + return (newContext e (noNavigator a)) --- | Updates the current location of a context -changeLocation :: (Location -> Location) -> Context a -> Context a -changeLocation f c = setLocation (f (location c)) c +instance Functor ContextMonad where + fmap = liftM --- | Returns the term which has the current focus: Nothing indicates that the current --- focus is invalid -currentFocus :: Uniplate a => Context a -> Maybe a -currentFocus c = getTermAt (fromLocation $ location c) (fromContext c) +instance Monad ContextMonad where + fail = const mzero + return a = CM (\env -> return (a, env)) + CM m >>= f = CM (\env -> do (a, e) <- m env + let CM g = f a + g e) --- | Changes the term which has the current focus. In case the focus is invalid, then --- this function has no effect. -changeFocus :: Uniplate a => (a -> a) -> Context a -> Context a -changeFocus f c = fmap (applyAt (fromLocation $ location c) f) c +instance MonadPlus ContextMonad where + mzero = CM (const mzero) + mplus (CM f) (CM g) = CM (\env -> f env `mplus` g env) --- | Go down to a certain child -locationDown :: Int -> Location -> Location -locationDown i (L is) = L (is ++ [i]) +readVar :: Typeable a => Var a -> ContextMonad a +readVar var = CM $ \env -> return $ + let name = varName var + txt = fromMaybe "" $ lookupEnv name env + in case (lookupEnv name env, varRead var txt) of + (Just a, _) -> (a, env) + (_, Just a) -> (a, storeEnvWith (varShow var) name a env) + _ -> (varInitial var, env) --- | Go up: Nothing indicates that we were already at the top -locationUp :: Location -> Maybe Location -locationUp (L is) - | null is = Nothing - | otherwise = Just (L (init is)) +writeVar :: Typeable a => Var a -> a -> ContextMonad () +writeVar var a = + let f = storeEnvWith (varShow var) (varName var) a + in CM $ \env -> return ((), f env) -makeLocation :: [Int] -> Location -makeLocation = L +modifyVar :: Typeable a => Var a -> (a -> a) -> ContextMonad () +modifyVar var f = readVar var >>= (writeVar var . f) -fromLocation :: Location -> [Int] -fromLocation (L is) = is +maybeCM :: Maybe a -> ContextMonad a +maybeCM = maybe mzero return ----------------------------------------------------------- --- Lifting rewrite rules --- | Lift a rule to operate on a term in a context -liftToContext :: (Lift f, Uniplate a) => f a -> f (Context a) -liftToContext = lift $ makeLiftPair currentFocus (changeFocus . const) +{- +listCM :: [a] -> ContextMonad a +listCM = foldr (mplus . return) mzero --- | Lift a rule to operate on a term in a context by ignoring the context -ignoreContext :: Lift f => f a -> f (Context a) -ignoreContext = lift $ makeLiftPair (return . fromContext) (fmap . const) +withListCM :: (a -> ContextMonad b) -> Context a -> [Context b] +withListCM f c = runListCM (f (fromContext c)) (getEnvironment c) + +runListCM :: ContextMonad a -> Environment -> [Context a] +runListCM (CM f) env = do + (a, e) <- f env + return (C e a) -} diff --git a/src/Common/Derivation.hs b/src/Common/Derivation.hs --- a/src/Common/Derivation.hs +++ b/src/Common/Derivation.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -16,24 +16,24 @@ ( -- * Data types DerivationTree, Derivations, Derivation -- * Constructors - , singleNode, addBranch, addBranches + , singleNode, addBranch, addBranches, newDerivation -- * Query , root, endpoint, branches, annotations, subtrees , results, lengthMax -- * Adapters , restrictHeight, restrictWidth, commit - , mergeSteps, cutOnStep + , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps, changeLabel -- * Query a derivation - , isEmpty, derivationLength, terms, steps, filterDerivation + , isEmpty, derivationLength, terms, steps, triples, filterDerivation -- * Conversions - , derivation, derivations + , derivation, randomDerivation, derivations ) where import Common.Utils (safeHead) import Control.Arrow import Control.Monad -import Data.List import Data.Maybe +import System.Random ----------------------------------------------------------------------------- -- Data type definitions for derivation trees and derivation lists @@ -135,6 +135,19 @@ | p s = (False, [(s, st)]) | otherwise = (endpoint st, branches st) +-- Change the annotation +mapSteps :: (s -> t) -> DerivationTree s a -> DerivationTree t a +mapSteps f t = t {branches = map g (branches t)} + where g (s, st) = (f s, mapSteps f st) + +changeLabel :: (l -> m) -> DerivationTree l a -> DerivationTree m a +changeLabel f = rec + where + rec t = t {branches = map (\(l, st) -> (f l, rec st)) (branches t)} + +mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a +mergeMaybeSteps = mapSteps fromJust . mergeSteps isJust + cutOnStep :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a cutOnStep p = rec where @@ -146,6 +159,9 @@ ----------------------------------------------------------------------------- -- Inspecting a derivation +newDerivation :: a -> [(s, a)] -> Derivation s a +newDerivation = D + -- | Tests whether the derivation is empty isEmpty :: Derivation s a -> Bool isEmpty (D _ xs) = null xs @@ -162,6 +178,11 @@ steps :: Derivation s a -> [s] steps (D _ xs) = map fst xs +-- | The triples of a derivation, consisting of the before term, the +-- step, and the after term. +triples :: Derivation s a -> [(a, s, a)] +triples d = zip3 (terms d) (steps d) (tail (terms d)) + -- | Filter steps from a derivation filterDerivation :: (s -> a -> Bool) -> Derivation s a -> Derivation s a filterDerivation p (D a xs) = D a (filter (uncurry p) xs) @@ -178,3 +199,24 @@ -- | The first derivation (if any) derivation :: DerivationTree s a -> Maybe (Derivation s a) derivation = safeHead . derivations + +-- | Return a random derivation (if any exists at all) +randomDerivation :: RandomGen g => g -> DerivationTree s a -> Maybe (Derivation s a) +randomDerivation g t = msum xs + where + (xs, g0) = shuffle g list + list = map (fmap (D (root t))) $ + [ Just [] | endpoint t ] ++ map make (branches t) + make (r, st) = do + D a2 ys <- randomDerivation g0 st + return ((r,a2):ys) + +shuffle :: RandomGen g => g -> [a] -> ([a], g) +shuffle g0 xs = rec g0 [] (length xs) xs + where + rec g acc n xs = + case splitAt i xs of + (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs) + _ -> (acc, g) + where + (i, g1) = randomR (0, n-1) g diff --git a/src/Common/Exercise.hs b/src/Common/Exercise.hs --- a/src/Common/Exercise.hs +++ b/src/Common/Exercise.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,33 +13,41 @@ ----------------------------------------------------------------------------- module Common.Exercise ( -- * Exercises - Exercise, Status(..), testableExercise, makeExercise, emptyExercise + Exercise, testableExercise, makeExercise, emptyExercise , description, exerciseCode, status, parser, prettyPrinter - , equivalence, similarity, isReady, isSuitable, strategy, extraRules + , equivalence, similarity, isReady, isSuitable, eqWithContext + , strategy, navigation, canBeRestarted, extraRules , difference, ordering, testGenerator, randomExercise, examples, getRule , simpleGenerator, useGenerator , randomTerm, randomTermWith, ruleset + , makeContext, inContext + -- * Exercise status + , Status(..), isPublic, isPrivate -- * Exercise codes , ExerciseCode, noCode, makeCode, readCode, domain, identifier -- * Miscellaneous - , restrictGenerator + , equivalenceContext, restrictGenerator , showDerivation, printDerivation , checkExercise, checkParserPretty - , checksForList + , checkExamples, generate ) where import Common.Apply import Common.Context import Common.Strategy hiding (not, fail, replicate) +import qualified Common.Strategy as S import Common.Derivation +import Common.Navigator import Common.Transformation -import Common.Utils +import Common.Utils (putLabel) +import Common.View (makeView) import Control.Monad.Error import Data.Char import Data.List +import Data.Maybe import System.Random -import Test.QuickCheck hiding (label, arguments) -import Text.Parsing (SyntaxError(..)) +import Test.QuickCheck hiding (label) +import Test.QuickCheck.Gen data Exercise a = Exercise { -- identification and meta-information @@ -47,7 +55,7 @@ , exerciseCode :: ExerciseCode -- uniquely determines the exercise (in a given domain) , status :: Status -- parsing and pretty-printing - , parser :: String -> Either SyntaxError a + , parser :: String -> Either String a , prettyPrinter :: a -> String -- syntactic and semantic checks , equivalence :: a -> a -> Bool @@ -55,17 +63,18 @@ , ordering :: a -> a -> Ordering -- syntactic comparison , isReady :: a -> Bool , isSuitable :: a -> Bool + , difference :: Bool -> a -> a -> Maybe (a, a) + , eqWithContext :: Maybe (Context a -> Context a -> Bool) -- special equivalence with context info -- strategies and rules , strategy :: LabeledStrategy (Context a) + , navigation :: a -> Navigator a + , canBeRestarted :: Bool -- By default, assumed to be the case , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy - , difference :: Bool -> a -> a -> Maybe (a, a) -- testing and exercise generation , testGenerator :: Maybe (Gen a) , randomExercise :: Maybe (StdGen -> Int -> a) , examples :: [a] } - -data Status = Stable | Provisional | Experimental deriving (Show, Eq) instance Eq (Exercise a) where e1 == e2 = exerciseCode e1 == exerciseCode e2 @@ -74,7 +83,7 @@ e1 `compare` e2 = exerciseCode e1 `compare` exerciseCode e2 instance Apply Exercise where - applyAll e = map fromContext . applyAll (strategy e) . inContext + applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a testableExercise = makeExercise @@ -95,7 +104,7 @@ , exerciseCode = noCode , status = Experimental -- parsing and pretty-printing - , parser = const $ Left $ ErrorMessage "<>" + , parser = const (Left "<>") , prettyPrinter = const "<>" -- syntactic and semantic checks , equivalence = \_ _ -> True @@ -103,16 +112,26 @@ , ordering = \_ _ -> EQ , isReady = const True , isSuitable = const True + , difference = \_ _ _ -> Nothing + , eqWithContext = Nothing -- strategies and rules - , strategy = label "Succeed" succeed + , strategy = label "Fail" S.fail + , navigation = noNavigator + , canBeRestarted = True , extraRules = [] - , difference = \_ _ _ -> Nothing -- testing and exercise generation , testGenerator = Nothing , randomExercise = Nothing , examples = [] } + +makeContext :: Exercise a -> Environment -> a -> Context a +makeContext ex env = newContext env . navigation ex +-- | Put a value into an empty environment +inContext :: Exercise a -> a -> Context a +inContext = flip makeContext emptyEnv + --------------------------------------------------------------- -- Exercise generators @@ -134,7 +153,13 @@ | otherwise = f (snd (next rng)) level where a = generate 100 rng (g level) + where +generate :: Int -> StdGen -> Gen a -> a +generate n rnd (MkGen m) = m rnd' size + where + (size, rnd') = randomR (0, n) rnd + restrictGenerator :: (a -> Bool) -> Gen a -> Gen a restrictGenerator p g = do a <- g @@ -157,6 +182,24 @@ where xs = examples ex --------------------------------------------------------------- +-- Exercise status + +data Status + = Stable -- ^ A released exercise that has undergone some thorough testing + | Provisional -- ^ A released exercise, possibly with some deficiencies + | Alpha -- ^ An exercise that is under development + | Experimental -- ^ An exercise for experimentation purposes only + deriving (Show, Eq) + +-- | An exercise with the status @Stable@ or @Provisional@ +isPublic :: Exercise a -> Bool +isPublic ex = status ex `elem` [Stable, Provisional] + +-- | An exercise that is not public +isPrivate :: Exercise a -> Bool +isPrivate = not . isPublic + +--------------------------------------------------------------- -- Exercise codes (unique identification) data ExerciseCode = EC String String | NoCode @@ -198,6 +241,17 @@ --------------------------------------------------------------- -- Rest +equivalenceContext :: Exercise a -> Context a -> Context a -> Bool +equivalenceContext ex a b = + case eqWithContext ex of + Just f -> f a b + Nothing -> fromMaybe False $ + liftM2 (equivalence ex) (fromContext a) (fromContext b) + +prettyPrinterContext :: Exercise a -> Context a -> String +prettyPrinterContext ex = + maybe "<>" (prettyPrinter ex) . fromContext + getRule :: Monad m => Exercise a -> String -> m (Rule (Context a)) getRule ex s = case filter ((==s) . name) (ruleset ex) of @@ -206,10 +260,27 @@ _ -> fail $ "Ambiguous ruleid " ++ s showDerivation :: Exercise a -> a -> String -showDerivation ex = - let err = "<>" - f = show . fmap (Shown . prettyPrinter ex . fromContext) . filterDerivation (\r a -> isMajorRule r) - in maybe err f . derivation . fullDerivationTree (strategy ex) . inContext +showDerivation ex a = + case derivation tree of + Just d -> show (f d) ++ extra d + Nothing -> prettyPrinterContext ex (root tree) + ++ "\n =>\n<>" + where + tree = derivationTree (strategy ex) (inContext ex a) + extra d = + case fromContext (last (terms d)) of + Nothing -> "<>" + Just a | isReady ex a -> "" + | otherwise -> "<>" + -- A bit of hack to show the delta between two environments, not including + -- the location variable + f d = let t:ts = map (Shown . prettyPrinterContext ex) (terms d) + xs = zipWith3 present (steps d) (drop 1 (terms d)) (terms d) + present a x y = Shown (show a ++ extra) + where env = deleteEnv "location" (diffEnv (getEnvironment x) (getEnvironment y)) + extra | nullEnv env = "" + | otherwise = "\n " ++ show env + in newDerivation t (zip xs ts) -- local helper datatype data Shown = Shown String @@ -222,65 +293,187 @@ --------------------------------------------------------------- -- Checks for an exercise +{- +checkExercise :: Exercise a -> IO () +checkExercise ex = do + putStrLn ("** " ++ show (exerciseCode ex)) + -- Derivations for examples + checkExamples ex + -- Derivations for test generator + case testGenerator ex of + Nothing -> return () + Just gen -> do + putStrLn "Checking with test generator" + forM_ [0 .. 100] $ \i -> do + -- putChar '.' + g <- newStdGen + checksForTerm False ex (generate i g gen) + return () + -- Derivations for random exercise generator + case randomExercise ex of + Nothing -> return () + Just f -> do + putStrLn "Checking with random exercise generator" + forM_ [0 .. 109] $ \i -> do + -- putChar '.' + g <- newStdGen + checksForTerm False ex (f g (i `div` 10)) + return () + -- Soundness of rules + case testGenerator ex of + Nothing -> return () + Just gen -> do + putStrLn "Soundness of rules with test generator" + forM_ (filter (not . isBuggyRule) (ruleset ex)) $ \r -> do + putStr ("[" ++ show r ++ "] ") + xs <- generateIO 300 (smartGen r (liftM (inContext ex) gen)) + let list = [ (x, y) | x <- xs, y <- applyAll r x ] + p (x, y) = not (equivalenceContext ex x y) + case filter p list of + [] | null list -> putStrLn "Warning: no applications found" + | otherwise -> putStrLn "Ok" + (x, y):_ -> report $ + "counter example: " ++ prettyPrinterContext ex x + ++ " => " ++ prettyPrinterContext ex y -} -checkExercise :: Show a => Exercise a -> IO () -checkExercise ex = +checkExercise :: Exercise a -> IO () +checkExercise ex = do + putStrLn ("** " ++ show (exerciseCode ex)) + checkExamples ex case testGenerator ex of Nothing -> return () Just gen -> do - putStrLn ("** " ++ show (exerciseCode ex)) - let check txt p = putLabel txt >> quickCheck p - check "parser/pretty printer" $ forAll gen $ - checkParserPretty (equivalence ex) (parser ex) (prettyPrinter ex) - + let showAsGen = showAs (prettyPrinter ex) gen + check txt p = putLabel txt >> quickCheck p + check "parser/pretty printer" $ forAll showAsGen $ + checkParserPrettyEx ex . from + putStrLn "Soundness non-buggy rules" forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> do putLabel (" " ++ name r) - let eq f a b = fromContext a `f` fromContext b - checkRuleSmart (eq (equivalence ex)) r (liftM inContext gen) + let eq a b = equivalenceContext ex (from a) (from b) + myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) + myView = makeView (return . from) (S (prettyPrinterContext ex)) + testRuleSmart eq (liftRule myView r) myGen - check "non-trivial terms" $ - forAll gen $ \x -> - let trivial = isReady ex x - rejected = not trivial - suitable = not trivial in - classify trivial "trivial" $ - classify rejected "rejected" $ - classify suitable "suitable" $ property True check "soundness strategy/generator" $ - forAll gen $ - isReady ex . fromContext . applyD (strategy ex) . inContext + forAll showAsGen $ + maybe False (isReady ex) . fromContext + . applyD (strategy ex) . inContext ex . from +data ShowAs a = S {showS :: a -> String, from :: a} + +instance Show (ShowAs a) where + show a = showS a (from a) + +showAs :: (a -> String) -> Gen a -> Gen (ShowAs a) +showAs f = liftM (S f) + -- check combination of parser and pretty-printer checkParserPretty :: (a -> a -> Bool) -> (String -> Either b a) -> (a -> String) -> a -> Bool -checkParserPretty eq parser pretty p = - either (const False) (eq p) (parser (pretty p)) +checkParserPretty eq parser pretty a = + either (const False) (eq a) (parser (pretty a)) -checksForList :: Exercise a -> IO () -checksForList ex - | status ex /= Experimental || null xs = return () - | otherwise = do - let err s = putStrLn $ "Error: " ++ s - putStrLn ("** " ++ show (exerciseCode ex)) - mapM_ (either err return . checksForTerm ex) xs - where xs = examples ex +checkParserPrettyEx :: Exercise a -> a -> Bool +checkParserPrettyEx ex = + checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex) -checksForTerm :: Monad m => Exercise a -> a -> m () -checksForTerm ex a = - let txt = prettyPrinter ex a in - case derivation (derivationTree (strategy ex) (inContext a)) of - Nothing -> fail $ "no derivation for " ++ txt - Just theDerivation -> do - unless (isReady ex (last as)) $ - fail $ "not solved: " ++ txt - case [ (x, y) | x <- as, y <- as, not (equivalence ex x y) ] of - (x, y):_ -> fail $ "not equivalent: " ++ prettyPrinter ex x ++ " and " - ++ prettyPrinter ex y - _ -> return () - case filter (not . checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex)) as of - hd:_ -> let s = prettyPrinter ex hd in - fail $ "parse error for " ++ s ++ ": parsed as " ++ - either show (prettyPrinter ex) (parser ex s) - _ -> return () - where - as = map fromContext (terms theDerivation) +checkExamples :: Exercise a -> IO () +checkExamples ex = do + let xs = examples ex + unless (null xs) $ do + putStrLn $ "Checking " ++ show (length xs) ++ " examples" + bs <- forM xs $ \a -> checksForTerm True ex a + when (and bs) $ + putStrLn "Passed all tests" + +checksForTerm :: Bool -> Exercise a -> a -> IO Bool +checksForTerm leftMost ex a = do + let tree = derivationTree (strategy ex) (inContext ex a) + -- Left-most derivation + b1 <- if not leftMost then return True else + case derivation tree of + Just d -> checksForDerivation ex d + Nothing -> do + report $ "no derivation for " ++ prettyPrinter ex a + return False + -- Random derivation + g <- getStdGen + b2 <- case randomDerivation g tree of + Just d -> checksForDerivation ex d + Nothing -> return True + return $ and [b1, b2] + +checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> IO Bool +checksForDerivation ex d = do + -- Conditions on starting term + let start = head (terms d) + b1 <- do let b = maybe False (isSuitable ex) (fromContext start) + unless b $ report $ + "start term not suitable: " ++ prettyPrinterContext ex start + return b + {- + b2 <- do let b = False -- maybe True (isReady ex) (fromContext start) + when b $ report $ + "start term is ready: " ++ prettyPrinterContext ex start + return b-} + -- Conditions on final term + let final = last (terms d) + {- + b3 <- do let b = False -- maybe True (isSuitable ex) (fromContext final) + when b $ report $ + "final term is suitable: " ++ prettyPrinterContext ex start + ++ " => " ++ prettyPrinterContext ex final + return b -} + b4 <- do let b = maybe False (isReady ex) (fromContext final) + unless b $ report $ + "final term not ready: " ++ prettyPrinterContext ex start + ++ " => " ++ prettyPrinterContext ex final + return b + -- Parser/pretty printer on terms + let ts = terms d + p = maybe False (not . checkParserPrettyEx ex) . fromContext + b5 <- case filter p ts of + [] -> return True + hd:_ -> do + let s = prettyPrinterContext ex hd + report $ "parse error for " ++ s ++ ": parsed as " + ++ either show (prettyPrinter ex) (parser ex s) + return False + -- Equivalences between terms + let pairs = [ (x, y) | x <- ts, y <- ts ] + p (x, y) = not (equivalenceContext ex x y) + b6 <- case filter p pairs of + [] -> return True + (x, y):_ -> do + report $ "not equivalent: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + return False + -- Similarity of terms + {- + let p (x, _, y) = fromMaybe False $ + liftM2 (similarity ex) (fromContext x) (fromContext y) + b7 <- case filter p (triples d) of + [] -> return True + (x, r, y):_ -> do + report $ "similar subsequent terms: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + ++ " using " ++ show r + return False -} + let xs = [ x | cx <- terms d, x <- fromContext cx, not (similarity ex x x) ] + b8 <- case xs of + [] -> return True + hd:_ -> do + report $ "term not similar to itself: " ++ prettyPrinter ex hd + return False + -- Result + return $ and [b1, b4, b5, b6, b8] + +report :: String -> IO () +report txt = putStrLn ("Error: " ++ txt) + +{- +generateIO :: Int -> Gen a -> IO [a] +generateIO n gen = forM [0..n] $ \i -> do + std <- newStdGen + return (generate i std gen) -} diff --git a/src/Common/Grammar.hs b/src/Common/Grammar.hs deleted file mode 100644 --- a/src/Common/Grammar.hs +++ /dev/null @@ -1,366 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines a set of combinators for context-free grammars. These --- grammars are the basis of the strategies. The fix-point combinator 'fix' --- makes it context-free. The code is based on the RTS'08 paper --- "Recognizing Strategies" --- ------------------------------------------------------------------------------ -module Common.Grammar - ( -- * Abstract data type - Grammar - -- * Smart constructor functions - , (<*>), (<|>), (<||>), var, rec, fix, many, succeed, fail, symbol - -- * Elementary operations - , empty, firsts, nonempty - -- * Membership and generated language - , member, language, languageBF - -- * Additional functions - , collectSymbols, join, withIndex - -- * QuickCheck properties - , checks - ) where - -import Common.Uniplate -import Control.Monad (liftM, liftM2) -import Data.List -import Prelude hiding (fail) -import Test.QuickCheck -import qualified Data.Set as S - ----------------------------------------------------------------------- --- Abstract data type - -data Grammar a = Grammar a :*: Grammar a - | Grammar a :|: Grammar a - | Grammar a :||: Grammar a - | Rec Int (Grammar a) - | Symbol a | Var Int | Succeed | Fail deriving Show - -infixr 3 :|:, <|> -infixr 4 :||:, <||> -infixr 5 :*:, <*> - ----------------------------------------------------------------------- --- Smart constructor functions - --- simple constructors -succeed, fail :: Grammar a -var :: Int -> Grammar a -symbol :: a -> Grammar a - -succeed = Succeed -fail = Fail -symbol = Symbol -var = Var - --- | Smart constructor for sequences: removes fails and succeeds in the --- operands -(<*>) :: Grammar a -> Grammar a -> Grammar a -Succeed <*> t = t -s <*> Succeed = s -Fail <*> _ = fail -_ <*> Fail = fail -(s :*: t) <*> u = s :*: (t <*> u) -s <*> t = s :*: t - --- | Smart constructor for alternatives: removes fails in the operands, and --- merges succeeds if present in both arguments -(<|>) :: Grammar a -> Grammar a -> Grammar a -Fail <|> t = t -s <|> Fail = s -(s :|: t) <|> u = s :|: (t <|> u) -Succeed <|> Succeed = Succeed -s <|> t = s :|: t - --- | Smart constructor for parallel execution: removes fails and succeeds in the operands -(<||>) :: Grammar a -> Grammar a -> Grammar a -Succeed <||> t = t -s <||> Succeed = s -Fail <||> _ = fail -_ <||> Fail = fail -(s :||: t) <||> u = s :||: (t <||> u) -s <||> t = s :||: t - --- | For constructing a recursive grammar -rec :: Int -> Grammar a -> Grammar a -rec i s = if i `S.member` freeVars s then Rec i s else s - - --- | Fix-point combinator to model recursion. Be careful: this combinator is --- VERY powerfull, and it is your own responsibility that the result --- is a valid, non-left-recursive grammar -fix :: (Grammar a -> Grammar a) -> Grammar a -fix f = Rec i (f (Var i)) -- disadvantage: function f is applied twice - where - s = allVars (f Succeed) - i = if S.null s then 0 else S.findMax s + 1 - --- | Zero or more occurrences -many :: Grammar a -> Grammar a -many s = rec 0 (succeed <|> (nonempty s <*> var 0)) -{- TODO: deal with free variables? -many s = rec i (succeed <|> (nonempty s <*> var i)) - where - vs = freeVars s - i = if S.null vs then 0 else 1 + S.findMax vs -} - ----------------------------------------------------------------------- --- Elementary operations - --- | Tests whether the grammar accepts the empty string -empty :: Grammar a -> Bool -empty (s :*: t) = empty s && empty t -empty (s :|: t) = empty s || empty t -empty (s :||: t) = empty s && empty t -empty (Rec _ s) = empty s -empty Succeed = True -empty _ = False - --- | Returns the firsts set of the grammar, where each symbol is --- paired with the remaining grammar -firsts :: Grammar a -> [(a, Grammar a)] -firsts (s :*: t) = [ (a, s' <*> t) | (a, s') <- firsts s ] ++ - (if empty s then firsts t else []) -firsts (s :|: t) = firsts s ++ firsts t -firsts (s :||: t) = [ (a, s' <||> t ) | (a, s') <- firsts s ] ++ - [ (a, s <||> t' ) | (a, t') <- firsts t] -firsts (Rec i s) = firsts (replaceVar i (Rec i s) s) -firsts (Symbol a) = [(a, succeed)] -firsts _ = [] - --- | Returns the grammar without the empty string alternative -nonempty :: Grammar a -> Grammar a -nonempty s = foldr (<|>) fail [ symbol a <*> t | (a, t) <- firsts s ] - ----------------------------------------------------------------------- --- Membership and generated language - --- | Checks whether a string is member of the grammar's language -member :: Eq a => [a] -> Grammar a -> Bool -member [] g = empty g -member (a:as) g = not $ null [ () | (b, t) <- firsts g, a==b, member as t ] - --- | Generates the language of the grammar (list can be infinite). The sentences are --- returned sorted by length, thus in a breadth-first order. The integer that is passed --- is the cut-off depth (the maximal length of the sentences) needed to avoid non-termination -language :: Int -> Grammar a -> [[a]] -language n = concat . take n . languageBF - --- | Generates the language of a grammar in a breadth-first manner, which is made explicit --- by the outermost list. Sentences are grouped by their length -languageBF :: Grammar a -> [[[a]]] -languageBF s = [ [] | empty s ] : merge [ map (map (a:)) $ languageBF t | (a, t) <- firsts s ] - where merge = map concat . transpose - ----------------------------------------------------------------------- --- Additional functions - --- | Collect all the symbols of the grammar -collectSymbols :: Grammar a -> [a] -collectSymbols (Symbol a) = [a] -collectSymbols g = compos [] (++) collectSymbols g - --- | The (monadic) join -join :: Grammar (Grammar a) -> Grammar a -join = mapSymbol id - --- | Label all symbols with an index (from left to right) -withIndex :: Grammar a -> Grammar (Int, a) -withIndex = snd . rec 0 - where - rec :: Int -> Grammar a -> (Int, Grammar (Int, a)) - rec n grammar = - case grammar of - p :*: q -> let (n1, a) = rec n p - (n2, b) = rec n1 q - in (n2, a :*: b) - p :|: q -> let (n1, a) = rec n p - (n2, b) = rec n1 q - in (n2, a :|: b) - p :||: q -> let (n1, a) = rec n p - (n2, b) = rec n1 q - in (n2, a :||: b) - Rec i s -> let (n1, a) = rec n s - in (n1, Rec i a) - Var i -> (n, Var i) - Symbol a -> (n+1, Symbol (n, a)) - Succeed -> (n, Succeed) - Fail -> (n, Fail) - ----------------------------------------------------------------------- --- Local helper functions and instances - -instance Uniplate (Grammar a) where - uniplate (s :*: t) = ([s,t], \[a,b] -> a :*: b) - uniplate (s :|: t) = ([s,t], \[a,b] -> a :|: b) - uniplate (s :||: t) = ([s,t], \[a,b] -> a :||: b) - uniplate (Rec i s) = ([s] , \[a] -> Rec i a) - uniplate g = ([] , \[] -> g) - -instance Functor Grammar where - fmap f = mapSymbol (symbol . f) - -freeVars :: Grammar a -> S.Set Int -freeVars (Rec i s) = freeVars s S.\\ S.singleton i -freeVars (Var i) = S.singleton i -freeVars g = compos S.empty S.union freeVars g - -allVars :: Grammar a -> S.Set Int -allVars (Var i) = S.singleton i -allVars g = compos S.empty S.union allVars g - -replaceVar :: Int -> Grammar a -> Grammar a -> Grammar a -replaceVar i new = rec - where - rec g = - case g of - Var j | i==j -> new - Rec j _ | i==j -> g - _ -> f $ map rec cs - where (cs, f) = uniplate g - -mapSymbol :: (a -> Grammar b) -> Grammar a -> Grammar b -mapSymbol f (p :*: q) = mapSymbol f p <*> mapSymbol f q -mapSymbol f (p :|: q) = mapSymbol f p <|> mapSymbol f q -mapSymbol f (p :||: q) = mapSymbol f p <||> mapSymbol f q -mapSymbol f (Rec i p) = Rec i (mapSymbol f p) -mapSymbol _ (Var i) = Var i -mapSymbol f (Symbol a) = f a -mapSymbol _ Succeed = Succeed -mapSymbol _ Fail = Fail - --------------------------------------------------------- --- QuickCheck generator - -instance Arbitrary a => Arbitrary (Grammar a) where - arbitrary = sized (arbGrammar []) - coarbitrary grammar = - case grammar of - p :*: q -> variant 0 . coarbitrary p . coarbitrary q - p :|: q -> variant 1 . coarbitrary p . coarbitrary q - p :||: q -> variant 2 . coarbitrary p . coarbitrary q - Rec i p -> variant 3 . coarbitrary i . coarbitrary p - Var i -> variant 4 . coarbitrary i - Symbol a -> variant 5 . coarbitrary a - Succeed -> variant 6 - Fail -> variant 7 - --- Use smart constructors here -arbGrammar :: Arbitrary a => [Grammar a] -> Int -> Gen (Grammar a) -arbGrammar xs n - | n == 0 = oneof $ - liftM symbol arbitrary : - map return ([succeed, fail] ++ xs) - | otherwise = oneof - [ arbGrammar xs 0 - , liftM2 (<*>) rec rec - , liftM2 (<|>) rec rec - , liftM2 (<||>) rec rec - , liftM many rec --- , liftM fix (promote (\x -> arbGrammar (x:xs) (n `div` 2))) -{- , do i <- oneof $ map return [1::Int ..5] - x <- arbGrammar (Var i:xs) (n `div` 2) - return $ Rec i x -} - ] - where - rec = arbGrammar xs (n `div` 2) - --------------------------------------------------------- --- QuickCheck properties - -propSymbols :: (Int -> Int) -> Grammar Int -> Bool -propSymbols f p = map f (collectSymbols p) == collectSymbols (fmap f p) - -propIndexId :: Grammar Int -> Bool -propIndexId p = fmap snd (withIndex p) === p - -propIndexUnique :: Grammar Int -> Bool -propIndexUnique p = is == nub is - where is = map fst $ collectSymbols $ withIndex p - -propSound :: Grammar Int -> Property -propSound p = not (null xs) ==> all (`member` p) xs - where xs = take 20 $ language 10 p - -propEmpty :: Grammar Int -> Bool -propEmpty s = empty s == member [] s - -propNonEmpty :: Grammar Int -> Bool -propNonEmpty = not . member [] . nonempty - -propSplitSucceed :: Grammar Int -> Bool -propSplitSucceed p = p === if empty p then succeed <|> new else new - where new = nonempty p - -propFirsts :: Grammar Int -> Bool -propFirsts p = nonempty p === foldr op fail (firsts p) - where op (a, q) r = (symbol a <*> q) <|> r - -propJoin :: Grammar Int -> Bool -propJoin p = join (fmap symbol p) === p - -propMap :: (Int -> Int) -> (Int -> Int) -> Grammar Int -> Bool -propMap f g p = fmap (f . g) p === fmap (f . g) p - -propRec :: Grammar Int -> Property -propRec this@(Rec i p) = property (replaceVar i this p === this) -propRec _ = False ==> True - -propSucceed :: Grammar Int -> Bool -propSucceed p = empty p == member [] p - -infixl 1 === - -(===) :: Grammar Int -> Grammar Int -> Bool -p === q = all (`member` p) ys && all (`member` q) xs - where - xs = take 20 $ language 10 p - ys = take 20 $ language 10 q - -associative op p q r = p `op` (q `op` r) === (p `op` q) `op` r -commutative op p q = p `op` q === q `op` p -idempotent op p = p `op` p === p -leftUnit op e p = e `op` p === p -rightUnit op e p = p `op` e === p -unit op e p = leftUnit op e p && rightUnit op e p -absorbe op e p = (e `op` p === e) && (p `op` e === e) -propStar p = many p === succeed <|> (p <*> many p) -propStarStar p = many (many p) === many p - -checks :: IO () -checks = do - putStrLn "** Grammar combinators" - quickCheck propMap - quickCheck propJoin - quickCheck propSymbols - quickCheck propIndexId - quickCheck propIndexUnique - quickCheck propSound - quickCheck propEmpty - quickCheck propNonEmpty - quickCheck propSplitSucceed - quickCheck propFirsts - quickCheck propRec - quickCheck propStar - quickCheck propStarStar - quickCheck propSucceed - quickCheck $ associative (<|>) - quickCheck $ commutative (<|>) - quickCheck $ idempotent (<|>) - quickCheck $ unit (<|>) fail - quickCheck $ associative (<*>) - quickCheck $ unit (<*>) succeed - quickCheck $ absorbe (<*>) fail - quickCheck $ associative (<||>) - quickCheck $ commutative (<||>) - quickCheck $ unit (<||>) succeed - quickCheck $ absorbe (<||>) fail diff --git a/src/Common/Navigator.hs b/src/Common/Navigator.hs new file mode 100644 --- /dev/null +++ b/src/Common/Navigator.hs @@ -0,0 +1,261 @@ +{-# OPTIONS -XExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines a type class for navigating an expression. +-- +----------------------------------------------------------------------------- +module Common.Navigator + ( -- * Type classes for navigating expressions + IsNavigator(..), TypedNavigator(..) + -- * Types and constructors + , Navigator, Location + , navigator, noNavigator, viewNavigator + -- * Derived navigations + , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo + , top, leafs, downFirst, downLast, left, right + ) where + +import Common.Uniplate +import Common.View hiding (left, right) +import Control.Monad +import Data.Maybe +import Data.Typeable + +--------------------------------------------------------------- +-- Type class for navigating expressions + +type Location = [Int] + +-- | For a minimal complete definition, provide an implemention for downs or +-- allDowns. All other functions need an implementation as well, except for +-- change. Note that a constructor (a -> f a) is not included in the type class +-- to allow additional type class constraints on type a. +class IsNavigator f where + -- navigation + up :: Monad m => f a -> m (f a) + down :: Monad m => Int -> f a -> m (f a) + allDowns :: f a -> [f a] + -- inspection + current :: Monad m => f a -> m a + location :: f a -> Location + -- adaption + change :: (a -> a) -> f a -> f a + changeM :: Monad m => (a -> m a) -> f a -> m (f a) + -- default definitions + down n a = + case drop n (allDowns a) of + [] -> fail ("down " ++ show n) + hd:_ -> return hd + allDowns a = + [ fa | i <- [0 .. arity a-1], fa <- down i a ] + change f a = + case changeM (Just . f) a of + Just new -> new + Nothing -> a + +class IsNavigator f => TypedNavigator f where + changeT :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a) + currentT :: (Monad m, Typeable b) => f a -> m b + leaveT :: (Monad m, Typeable b) => f a -> m b + castT :: (Monad m, Typeable e) => View e b -> f a -> m (f b) + -- By default, fail + changeT _ _ = fail "changeT" + currentT _ = fail "currentT" + leaveT _ = fail "leaveT" + castT _ _ = fail "castT" + +--------------------------------------------------------------- +-- Derived navigations + +leave :: (IsNavigator f, Monad m) => f a -> m a +leave a = maybe (current a) leave (up a) + +replace :: IsNavigator f => a -> f a -> f a +replace = change . const + +arity :: IsNavigator f => f a -> Int +arity = length . allDowns + +isTop :: IsNavigator f => f a -> Bool +isTop = isNothing . up + +isLeaf :: IsNavigator f => f a -> Bool +isLeaf = null . allDowns + +ups :: (IsNavigator f, Monad m) => Int -> f a -> m (f a) +ups n a = foldM (const . up) a [1..n] + +downs :: (IsNavigator f, Monad m) => [Int] -> f a -> m (f a) +downs is a = foldM (flip down) a is + +navigateTo :: (IsNavigator f, Monad m) => Location -> f a -> m (f a) +navigateTo is a = ups (length js - n) a >>= downs (drop n is) + where + js = location a + n = length (takeWhile id (zipWith (==) is js)) + +top :: (IsNavigator f, Monad m) => f a -> m (f a) +top = navigateTo [] + +leafs :: IsNavigator f => f a -> [f a] +leafs a + | isLeaf a = [a] + | otherwise = concatMap leafs (allDowns a) + +downFirst :: (IsNavigator f, Monad m) => f a -> m (f a) +downFirst = down 0 + +downLast :: (IsNavigator f, Monad m) => f a -> m (f a) +downLast a = down (arity a - 1) a + +left :: (IsNavigator f, Monad m) => f a -> m (f a) +left a0 = rec a0 + where + rec a + | isTop a = downFirst a0 + | i == 0 = up a >>= rec + | otherwise = up a >>= down (i-1) + where + i = last (location a) + +right :: (IsNavigator f, Monad m) => f a -> m (f a) +right a0 = rec a0 + where + rec a + | isTop a = downLast a0 + | otherwise = do + p <- up a + let n = arity p + if i >= n-1 then rec p else down (i+1) p + where + i = last (location a) + +--------------------------------------------------------------- +-- Instance based on Uniplate + +-- The uniplate function is stored in the data type to get rid of the +-- Uniplate type class constraints in the member functions of the +-- Navigator type class. +data UniplateNav a = UN (UniplateType a) [(Int, a -> a)] a + +type UniplateType a = a -> ([a], [a] -> a) + +makeUN :: Uniplate a => a -> UniplateNav a +makeUN = UN uniplate [] + +instance Show a => Show (UniplateNav a) where + show = showNav + +instance IsNavigator UniplateNav where + up (UN _ [] _) = fail "up" + up (UN uni ((_, f):xs) a) = return (UN uni xs (f a)) + + allDowns (UN uni xs a) = zipWith make [0..] cs + where + (cs, build) = uni a + make i = UN uni ((i, build . flip (update i) cs):xs) + update _ _ [] = [] + update i x (y:ys) + | i == 0 = x:ys + | otherwise = y:update (i-1) x ys + + location (UN _ xs _) = reverse (map fst xs) + + changeM f (UN uni xs a) = liftM (UN uni xs) (f a) + current (UN _ _ a) = return a + +showNav :: (IsNavigator f, Show a) => f a -> String +showNav a = maybe "???" show (leave a) ++ " { " + ++ maybe "???" show (current a) + ++ " @ " ++ show (location a) ++ " }" + +--------------------------------------------------------------- +-- Instance based on a View + +data ViewNav a b = VN (View a b) (UniplateNav a) + +instance Show a => Show (ViewNav a b) where + show (VN _ a) = show a + +instance IsNavigator (ViewNav a) where + up (VN v a) = liftM (VN v) (up a) + allDowns (VN v a) = liftM (VN v) (allDowns a) + location (VN _ a) = location a + current (VN v a) = current a >>= matchM v + changeM f (VN v a) = + let g b = matchM v b >>= (liftM (build v) . f) + in liftM (VN v) (changeM g a) + +instance Typeable a => TypedNavigator (ViewNav a) where + changeT f (VN v a) = do + new <- current a >>= castM >>= f >>= castM + return (VN v (replace new a)) + currentT (VN _ a) = + current a >>= castM + leaveT (VN _ a) = + leave a >>= castM + castT v (VN v0 a) + | typeOf (getTp v) == typeOf (getTp v0) = + return (VN (makeView f g) a) + | otherwise = + fail "castT" + where + f e = castM e >>= matchM v + g = fromMaybe (error "castT") . cast . build v + + getTp :: View a b -> a + getTp = error "castT" + +castM :: (Monad m, Typeable a, Typeable b) => a -> m b +castM = maybe (fail "castM") return . cast + +--------------------------------------------------------------- +-- Uniform navigator type + +instance Show a => Show (Navigator a) where + show = showNav + +data Navigator a = forall f . TypedNavigator f => N (f a) +data Simple a = forall f . IsNavigator f => S (f a) + +instance IsNavigator Navigator where + up (N a) = liftM N (up a) + allDowns (N a) = map N (allDowns a) + current (N a) = current a + location (N a) = location a + changeM f (N a) = liftM N (changeM f a) + +instance TypedNavigator Navigator where + changeT f (N a) = liftM N (changeT f a) + currentT (N a) = currentT a + leaveT (N a) = leaveT a + castT v (N a) = liftM N (castT v a) + +instance IsNavigator Simple where + up (S a) = liftM S (up a) + allDowns (S a) = map S (allDowns a) + current (S a) = current a + location (S a) = location a + changeM f (S a) = liftM S (changeM f a) + +instance TypedNavigator Simple + +--------------------------------------------------------------- +-- Constructors + +navigator :: Uniplate a => a -> Navigator a +navigator = N . S . makeUN + +noNavigator :: a -> Navigator a +noNavigator = N . S . UN (\a -> ([], const a)) [] + +viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a +viewNavigator = N . VN identity . makeUN diff --git a/src/Common/Rewriting.hs b/src/Common/Rewriting.hs --- a/src/Common/Rewriting.hs +++ b/src/Common/Rewriting.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,19 +10,15 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting - ( module Common.Rewriting.AC - , module Common.Rewriting.Confluence - , module Common.Rewriting.MetaVar - , module Common.Rewriting.RewriteRule - , module Common.Rewriting.Substitution - , module Common.Rewriting.Difference - , module Common.Rewriting.Unification + ( RewriteRule, smartGenerator, rewriteRule, rewriteRules + , Builder, rewriteM, RuleSpec((:~>)), rulePair, BuilderList, showRewriteRule + , Rewrite(..), ShallowEq(..), Operator + , associativeOperator, ruleName, Operators, collectWithOperator + , equalWith, isOperator, constructor, difference, differenceMode + , acOperator, normalizeWith, IsTerm(..), Different(..) ) where import Common.Rewriting.AC -import Common.Rewriting.Confluence -import Common.Rewriting.MetaVar -import Common.Rewriting.RewriteRule -import Common.Rewriting.Substitution import Common.Rewriting.Difference -import Common.Rewriting.Unification +import Common.Rewriting.RewriteRule +import Common.Rewriting.Term diff --git a/src/Common/Rewriting/AC.hs b/src/Common/Rewriting/AC.hs --- a/src/Common/Rewriting/AC.hs +++ b/src/Common/Rewriting/AC.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -17,6 +17,7 @@ , isOperator, findOperator , normalizeWith, equalWith , pairings, pairingsMatch + , pairingsA2, onBoth ) where import Common.Uniplate @@ -118,7 +119,14 @@ -- associative pairings pairingsA :: Bool -> Operator a -> a -> a -> [[(a, a)]] -pairingsA matchMode op a b = rec (collectWithOperator op a) (collectWithOperator op b) +pairingsA matchMode op a b = map (map make) result + where + (as, bs) = onBoth (collectWithOperator op) (a, b) + result = pairingsA2 matchMode as bs + make = onBoth (buildWithOperator op) + +pairingsA2 :: Bool -> [a] -> [a] -> [[([a], [a])]] +pairingsA2 matchMode = rec where rec [] [] = [[]] rec as bs = @@ -128,8 +136,8 @@ , i==1 || j==1 , let (as1, as2) = splitAt i as , let (bs1, bs2) = splitAt j bs - , let a1 = buildWithOperator op as1 - , let b1 = buildWithOperator op bs1 + , let a1 = as1 + , let b1 = bs1 , ps <- rec as2 bs2 ] @@ -176,7 +184,10 @@ let toLeft (xs, ys) = (a:xs, ys) toRight (xs, ys) = ( xs, a:ys) in map toLeft ps ++ map toRight ps - + +onBoth :: (a -> b) -> (a, a) -> (b, b) +onBoth f (x, y) = (f x, f y) + {- permutations :: [a] -> [[a]] permutations = foldr (concatMap . insert) [[]] diff --git a/src/Common/Rewriting/Confluence.hs b/src/Common/Rewriting/Confluence.hs deleted file mode 100644 --- a/src/Common/Rewriting/Confluence.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.Confluence - ( isConfluent, confluence, confluenceWith, confluentFunction - , testConfluence, testConfluenceWith, testConfluentFunction - ) where - -import Common.Rewriting.AC -import Common.Rewriting.MetaVar -import Common.Rewriting.RewriteRule -import Common.Rewriting.Substitution -import Common.Rewriting.Unification -import Common.Uniplate (subtermsAt, applyAtM, somewhereM) -import Data.List -import Data.Maybe - - ----------------------------------------------------- - -superImpose :: Rewrite a => RewriteRule a -> RewriteRule a -> [([Int], a)] -superImpose r1 r2 = - [ (loc, s |-> lhs2) | (loc, a) <- subtermsAt lhs2, s <- make a ] - where - lhs1 = lhs (rulePair r1 0) - lhs2 = lhs (rulePair r2 (nrOfMetaVars r1)) - - make a - | isJust (isMetaVar a) = [] - | otherwise = unifyM lhs1 a - -criticalPairs :: (Rewrite a, Eq a) => [RewriteRule a] -> [(a, (RewriteRule a, a), (RewriteRule a, a))] -criticalPairs rs = - [ (a, (r1, b1), (r2, b2)) - | r1 <- rs - , r2 <- rs - , (loc, a) <- superImpose r1 r2 - , b1 <- rewriteM r1 a - , b2 <- applyAtM loc (rewriteM r2) a - , b1 /= b2 - ] - -noDiamondPairs :: (Rewrite a, Eq a) => (a -> a) -> [RewriteRule a] -> [(a, (RewriteRule a, a, a), (RewriteRule a, a, a))] -noDiamondPairs f rs = - [ (a, (r1, e1, nf1), (r2, e2, nf2)) - | (a, (r1, e1), (r2, e2)) <- criticalPairs rs - , let (nf1, nf2) = (f e1, f e2) - , nf1 /= nf2 - ] - -reportPairs :: (Show a, Eq a) => [(a, (RewriteRule a, a, a), (RewriteRule a, a, a))] -> IO () -reportPairs = putStrLn . unlines . zipWith f [1::Int ..] - where - f i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines - [ show i ++ ") " ++ show a - , " " ++ show r1 - , " " ++ show e1 ++ if e1==nf1 then "" else " --> " ++ show nf1 - , " " ++ show r2 - , " " ++ show e2 ++ if e2==nf2 then "" else " --> " ++ show nf2 - ] - ----------------------------------------------------- - -isConfluent :: (Eq a, Show a, Rewrite a) => (a -> a) -> [RewriteRule a] -> Bool -isConfluent f = null . noDiamondPairs f - -confluentFunction :: (Eq a, Show a, Rewrite a) => (a -> a) -> [RewriteRule a] -> IO () -confluentFunction f = reportPairs . noDiamondPairs f - -confluenceWith :: (Ord a, Show a, Rewrite a) => [Operator a] -> [RewriteRule a] -> IO () -confluenceWith ops rs = confluentFunction (normalizeWith ops . normalFormWith ops rs) rs - -confluence :: (Ord a, Show a, Rewrite a) => [RewriteRule a] -> IO () -confluence = confluenceWith operators - ----------------------------------------------------- - -testConfluentFunction :: (Eq a, Rewrite a) => (a -> a) -> [RewriteRule a] -> a -> Bool -testConfluentFunction f rs a = - case nub [ f b | r <- rs, b <- somewhereM (rewriteM r) a ] of - _:_:_ -> False - _ -> True - -testConfluenceWith :: (Ord a, Rewrite a) => [Operator a] -> [RewriteRule a] -> a -> Bool -testConfluenceWith ops rs = testConfluentFunction (normalFormWith ops rs) rs - -testConfluence :: (Ord a, Rewrite a) => [RewriteRule a] -> a -> Bool -testConfluence = testConfluenceWith operators diff --git a/src/Common/Rewriting/Difference.hs b/src/Common/Rewriting/Difference.hs --- a/src/Common/Rewriting/Difference.hs +++ b/src/Common/Rewriting/Difference.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -17,28 +17,32 @@ ) where import Common.Rewriting.AC -import Common.Rewriting.Unification +import Common.Rewriting.RewriteRule import Control.Monad import Common.Uniplate import Data.Maybe -differenceMode :: Rewrite a => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a) +differenceMode :: (Rewrite a, Uniplate a, ShallowEq a) + => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a) differenceMode eq b = if b then differenceEqual eq else difference -- | This function returns the difference, except that the -- returned terms should be logically equivalent. Nothing can signal that -- there is no difference, or that the terms to start with are not equivalent. -differenceEqual :: Rewrite a => (a -> a -> Bool) -> a -> a -> Maybe (a, a) +differenceEqual :: (Rewrite a, Uniplate a, ShallowEq a) + => (a -> a -> Bool) -> a -> a -> Maybe (a, a) differenceEqual eq p q = do guard (eq p q) diff eq p q -difference :: Rewrite a => a -> a -> Maybe (a, a) +difference :: (Rewrite a, Uniplate a, ShallowEq a) + => a -> a -> Maybe (a, a) difference = diff (\_ _ -> True) -- local implementation function -diff :: Rewrite a => (a -> a -> Bool) -> a -> a -> Maybe (a, a) +diff :: (Rewrite a, Uniplate a, ShallowEq a) + => (a -> a -> Bool) -> a -> a -> Maybe (a, a) diff eq p q | shallowEq p q = case findOperator operators p of @@ -49,7 +53,8 @@ _ -> diffList eq (children p) (children q) | otherwise = Just (p, q) -diffList :: Rewrite a => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a) +diffList :: (Rewrite a, Uniplate a, ShallowEq a) + => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a) diffList eq xs ys | length xs /= length ys = Nothing | otherwise = @@ -57,7 +62,8 @@ [p] -> Just p _ -> Nothing -diffA :: Rewrite a => (a -> a -> Bool) -> Operator a -> [a] -> [a] -> Maybe (a, a) +diffA :: (Rewrite a, Uniplate a, ShallowEq a) + => (a -> a -> Bool) -> Operator a -> [a] -> [a] -> Maybe (a, a) diffA eq op = curry (make . uncurry rev . f . uncurry rev . f) where f (p:ps, q:qs) | not (null ps || null qs) && diff --git a/src/Common/Rewriting/MetaVar.hs b/src/Common/Rewriting/MetaVar.hs --- a/src/Common/Rewriting/MetaVar.hs +++ b/src/Common/Rewriting/MetaVar.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,10 +14,7 @@ import Common.Uniplate import Common.Utils (readInt) -import Data.Char (ord, isDigit) -import Data.List import qualified Data.IntSet as IS - ----------------------------------------------------------- --- Meta variables diff --git a/src/Common/Rewriting/RewriteRule.hs b/src/Common/Rewriting/RewriteRule.hs --- a/src/Common/Rewriting/RewriteRule.hs +++ b/src/Common/Rewriting/RewriteRule.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, + FunctionalDependencies, FlexibleInstances, UndecidableInstances, + TypeSynonymInstances #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,154 +13,159 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting.RewriteRule - ( RuleSpec(..), lhs, rhs - , RewriteRule, Builder, rewriteRule, BuilderList, rewriteRules - , ruleName, nrOfMetaVars, rulePair - , inverse, bothWays, checkScope - , rewrite, rewriteM, rewriteWith - , normalForm, normalFormWith - , smartGenerator, showRewriteRule, showRuleSpec + ( -- * Supporting type classes + Rewrite(..), ShallowEq(..), Different(..) + -- * Rewrite rules and specs + , RewriteRule(ruleName, rulePair), RuleSpec(..) + -- * Compiling a rewrite rule + , rewriteRule, rewriteRules, Builder, BuilderList + -- * Using rewrite rules + , rewrite, rewriteM, showRewriteRule, smartGenerator ) where -import Common.Apply import Common.Rewriting.AC -import Common.Rewriting.MetaVar import Common.Rewriting.Substitution -import Common.Rewriting.Unification -import Common.Uniplate (transform) -import Common.Utils +import Common.Rewriting.Term import Control.Monad -import Data.List -import Data.Maybe import Test.QuickCheck +import Common.Apply +import Common.Rewriting.MetaVar (getMetaVars) +import Common.Rewriting.Unification import qualified Data.IntSet as IS +import qualified Data.Map as M ------------------------------------------------------------ --- Rewrite rules +------------------------------------------------------ +-- Supporting type classes -infixl 1 :~> +class Different a where + different :: (a, a) -data RuleSpec a = a :~> a - deriving Show +class ShallowEq a where + shallowEq :: a -> a -> Bool -lhs, rhs :: RuleSpec a -> a -lhs (x :~> _) = x -rhs (_ :~> y) = y +-- The arbitrary type class is a quick solution to have smart generators +-- (in combination with lifting rules). The function in the RewriteRule module +-- cannot have a type class for this reason +-- The show type class is added for pretty-printing rules +class (IsTerm a, Arbitrary a, Show a) => Rewrite a where + operators :: [Operator a] + associativeOps :: a -> [Symbol] + -- default definition: no associative/commutative operators + operators = [] + associativeOps = const [] -data RewriteRule a = Rewrite a => R { ruleName :: String, nrOfMetaVars :: Int, rulePair :: Int -> RuleSpec a } +------------------------------------------------------ +-- Rewrite rules and specs -instance Show (RewriteRule a) where - show r = "[" ++ ruleName r ++ "]" +infixl 1 :~> + +data RuleSpec a = a :~> a deriving Show -instance Eq (RewriteRule a) where - r1 == r2 = ruleName r1 == ruleName r2 +data RewriteRule a = Rewrite a => R + { ruleName :: String + , nrOfMetaVars :: Int + , rulePair :: Int -> RuleSpec Term + } -class Rewrite a => Builder t a | t -> a where - buildSpec :: t -> Int -> RuleSpec a +instance Functor RuleSpec where + fmap f (a :~> b) = f a :~> f b + +------------------------------------------------------ +-- Compiling a rewrite rule + +class Builder t a | t -> a where + buildSpec :: t -> Int -> RuleSpec Term countVars :: t -> Int -instance Rewrite a => Builder (RewriteRule a) a where +instance IsTerm a => Builder (RewriteRule a) a where buildSpec = rulePair countVars = nrOfMetaVars -instance Rewrite a => Builder (RuleSpec a) a where - buildSpec rp _ = rp +instance IsTerm a => Builder (RuleSpec a) a where + buildSpec (a :~> b) _ = toTerm a :~> toTerm b countVars _ = 0 -instance (Rewrite a, Builder b a) => Builder (a -> b) a where - buildSpec f i = buildSpec (f (metaVar i)) (i+1) +instance (Different a, Builder t b) => Builder (a -> t) b where + buildSpec f i = buildFunction i (\a -> buildSpec (f a) (i+1)) countVars f = countVars (f $ error "countVars") + 1 -class Rewrite a => BuilderList t a | t -> a where - getSpecNr :: t -> Int -> Int -> RuleSpec a +class BuilderList t a | t -> a where + getSpecNr :: t -> Int -> Int -> RuleSpec Term countSpecsL :: t -> Int countVarsL :: t -> Int - + instance Rewrite a => BuilderList (RewriteRule a) a where getSpecNr r n = if n==0 then rulePair r else error "getSpecNr" countSpecsL _ = 1 countVarsL = nrOfMetaVars - -instance Rewrite a => BuilderList [RuleSpec a] a where + +instance Builder t a => BuilderList [t] a where getSpecNr rs = buildSpec . (rs !!) countSpecsL = length countVarsL _ = 0 -instance BuilderList b a => BuilderList (a -> b) a where - getSpecNr f n i = getSpecNr (f (metaVar i)) n (i+1) +instance (Different a, BuilderList t b) => BuilderList (a -> t) b where + getSpecNr f n i = buildFunction i (\a -> getSpecNr (f a) n (i+1)) countSpecsL f = countSpecsL (f $ error "countSpecsL") countVarsL f = countVarsL (f $ error "countSpecsL") + 1 - -rewriteRule :: Builder f a => String -> f -> RewriteRule a + +buildFunction :: Different a => Int -> (a -> RuleSpec Term) -> RuleSpec Term +buildFunction n f = fill n a1 a2 :~> fill n b1 b2 + where + a1 :~> b1 = f (fst different) + a2 :~> b2 = f (snd different) + +fill :: Int -> Term -> Term -> Term +fill i (App a1 a2) (App b1 b2) = App (fill i a1 b1) (fill i a2 b2) +fill i a b + | a == b = a + | otherwise = Meta i + +build :: Rewrite a => RuleSpec Term -> a -> [a] +build (lhs :~> rhs) a = do + s <- match (getMatcher a) lhs (toTerm a) + fromTermM (s |-> rhs) + +rewriteRule :: (Builder f a, Rewrite a) => String -> f -> RewriteRule a rewriteRule s f = R s (countVars f) (buildSpec f) -rewriteRules :: BuilderList f a => String -> f -> [RewriteRule a] +rewriteRules :: (BuilderList f a, Rewrite a) => String -> f -> [RewriteRule a] rewriteRules s f = map (R s (countVarsL f) . getSpecNr f) [0 .. countSpecsL f-1] -inverse :: RewriteRule a -> Maybe (RewriteRule a) -inverse r@(R _ _ _) = if checkScope new then Just new else Nothing - where - swap (x :~> y) = y :~> x - new = R (ruleName r) (nrOfMetaVars r) (swap . rulePair r) +getMatcher :: Rewrite a => a -> Matcher +getMatcher = M.unions . map associativeMatcher . associativeOps -bothWays :: Rewrite a => [RewriteRule a] -> [RewriteRule a] -bothWays rs = rs ++ mapMaybe inverse rs -checkScope :: Rewrite a => RewriteRule a -> Bool -checkScope r = IS.null (getMetaVars rhs IS.\\ getMetaVars lhs) - where lhs :~> rhs = rulePair r 0 +------------------------------------------------------ +-- Using a rewrite rule ------------------------------------------------------------ --- Applying rewrite rules +instance Apply RewriteRule where + applyAll = rewrite -instance Apply RewriteRule where - applyAll = rewriteM - rewrite :: RewriteRule a -> a -> [a] -rewrite r@(R _ _ _) = rewriteWith operators r +rewrite r@(R _ _ _) a = do + ext <- extendContext (associativeOps a) r + build (rulePair ext 0) a rewriteM :: MonadPlus m => RewriteRule a -> a -> m a -rewriteM r@(R _ _ _) = msum . map return . rewriteWith operators r - -rewriteWith :: Operators a -> RewriteRule a -> a -> [a] -rewriteWith ops r0@(R _ _ _) e = do - r <- extendContext ops r0 - let lhs :~> rhs = rulePair r (nextMetaVar e) - s <- matchWith ops lhs e - return (s |-> rhs) - --- Bug fix 4/3/2009: for associative operators, we need to extend rewrite --- rules to take "contexts" into account. In addition to a left and a right --- context, we also should consider a context on both sides. If not, we --- might miss some locations, as pointed out by Josje's bug report. -extendContext :: Operators a -> RewriteRule a -> [RewriteRule a] -extendContext ops r = - case findOperator ops (lhs $ rulePair r 0) of - Just op | isAssociative op -> - [r, extend (leftContext op) r, extend (rightContext op) r - , extend (rightContext op) (extend (leftContext op) r) ] - _ -> [r] - where - leftContext op a (x :~> y) = - constructor op a x :~> constructor op a y - - rightContext op a (x :~> y) = - constructor op x a :~> constructor op y a +rewriteM r = msum . map return . rewrite r -extend :: (a -> RuleSpec a -> RuleSpec a) -> RewriteRule a -> RewriteRule a -extend f (R s n g) = R s (n+1) (\i -> f (metaVar (i+n)) (g i)) - ----------------------------------------------------------- --- Normal forms +-- Pretty-print a rewriteRule -normalFormWith :: (Rewrite a, Ord a) => [Operator a] -> [RewriteRule a] -> a -> a -normalFormWith ops rs = fixpoint $ transform $ \a -> - case [ b | r <- rs, b <- rewriteWith ops r a ] of - hd:_ -> normalizeWith ops hd - _ -> a - -normalForm :: (Rewrite a, Ord a) => [RewriteRule a] -> a -> a -normalForm = normalFormWith operators +showRewriteRule :: Bool -> RewriteRule a -> Maybe String +showRewriteRule sound r@(R _ _ _) = do + x <- fromTermTp r (sub |-> a) + y <- fromTermTp r (sub |-> b) + let op = if sound then "~>" else "/~>" + return (show x ++ " " ++ op ++ " " ++ show y) + where + a :~> b = rulePair r 0 + vs = IS.toList (getMetaVars a `IS.union` getMetaVars b) + sub = listToSubst $ zip vs [ Var [c] | c <- ['a' ..] ] + + fromTermTp :: IsTerm a => RewriteRule a -> Term -> Maybe a + fromTermTp _ = fromTerm ----------------------------------------------------------- -- Smart generator that creates instantiations of the left-hand side @@ -166,19 +173,39 @@ smartGenerator :: RewriteRule a -> Gen a smartGenerator r@(R _ _ _) = do let a :~> _ = rulePair r 0 - let vs = getMetaVars a - list <- vector (IS.size vs) - let sub = listToSubst $ zip (IS.toList vs) list - return (sub |-> a) - ------------------------------------------------------------ --- Showing a rewrite-rule + let vs = IS.toList (getMetaVars a) + list <- vector (length vs) + let sub = listToSubst (zip vs (map (tpToTerm r) list)) + case fromTerm (sub |-> a) of + Just a -> return a + Nothing -> arbitrary + where + tpToTerm :: IsTerm a => RewriteRule a -> a -> Term + tpToTerm _ = toTerm -showRewriteRule :: Bool -> RewriteRule a -> String -showRewriteRule sound r@(R _ _ _) = ruleName r ++ ": " ++ showRuleSpec sound r - -showRuleSpec :: Bool -> RewriteRule a -> String -showRuleSpec sound r@(R _ _ _) = show lhs ++ " " ++ leadsto ++ " " ++ show rhs +------------------------------------------------------ + +-- Bug fix 4/3/2009: for associative operators, we need to extend rewrite +-- rules to take "contexts" into account. In addition to a left and a right +-- context, we also should consider a context on both sides. If not, we +-- might miss some locations, as pointed out by Josje's bug report. +extendContext :: [Symbol] -> RewriteRule a -> [RewriteRule a] +extendContext ops r@(R _ _ _) = + case getSpine (lhs $ rulePair r 0) of + (Con s, [_, _]) | s `elem` ops -> r : + [ extend (leftContext s) r + , extend (rightContext s) r + , extend (rightContext s) (extend (leftContext s) r) + ] + _ -> [r] where - leadsto = if sound then ":~>" else ":/~>" - lhs :~> rhs = rulePair r 0 + lhs (a :~> _) = a + + leftContext s a (x :~> y) = + binary s a x :~> binary s a y + + rightContext s a (x :~> y) = + binary s x a :~> binary s y a + +extend :: (Term -> RuleSpec Term -> RuleSpec Term) -> RewriteRule a -> RewriteRule a +extend f (R s n g) = R s (n+1) (\i -> f (Meta (i+n)) (g i)) diff --git a/src/Common/Rewriting/Substitution.hs b/src/Common/Rewriting/Substitution.hs --- a/src/Common/Rewriting/Substitution.hs +++ b/src/Common/Rewriting/Substitution.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -8,6 +8,8 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- +-- Substitutions +-- ----------------------------------------------------------------------------- module Common.Rewriting.Substitution ( Substitution, emptySubst, singletonSubst, listToSubst, (@@), (@@@) @@ -18,24 +20,13 @@ import Common.Rewriting.MetaVar import qualified Data.IntMap as IM import qualified Data.IntSet as IS -import Data.List import Data.Maybe ----------------------------------------------------------- --- Substitution - -- | Abstract data type for substitutions newtype Substitution a = S { unS :: IM.IntMap a } - -invariant :: (Uniplate a, MetaVar a) => Substitution a -> Bool -invariant s = IS.null (dom s `IS.intersection` getMetaVarsList (ran s)) - -makeS :: (Uniplate a, MetaVar a) => IM.IntMap a -> Substitution a -makeS m | invariant new = new - | otherwise = error "Rewriting.Substitution: invariant was violated" - where - new = S m infixr 4 |-> infixr 5 @@, @@@ @@ -45,27 +36,25 @@ -- | Returns the empty substitution emptySubst :: (Uniplate a, MetaVar a) => Substitution a -emptySubst = makeS IM.empty +emptySubst = S IM.empty -- | Returns a singleton substitution singletonSubst :: (MetaVar a, Uniplate a) => Int -> a -> Substitution a -singletonSubst i a - | isMetaVar a == Just i = emptySubst - | otherwise = makeS (IM.singleton i a) +singletonSubst i a = S (IM.singleton i a) -- | Turns a list into a substitution listToSubst :: (Uniplate a, MetaVar a) => [(Int, a)] -> Substitution a -listToSubst = makeS . IM.fromListWith (error "Substitution: keys are not unique") +listToSubst = S . IM.fromListWith (error "Substitution: keys are not unique") -- | Combines two substitutions. The left-hand side substitution is first applied to -- the co-domain of the right-hand side substitution (@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a -S a @@ S b = makeS $ a `IM.union` IM.map (S a |->) b +S a @@ S b = S $ a `IM.union` IM.map (S a |->) b -- | Combines two substitutions with disjoint domains. If the domains are not disjoint, -- an error is reported (@@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a -S a @@@ S b = makeS (IM.unionWith err a b) +S a @@@ S b = S (IM.unionWith err a b) where err _ _ = error "Unification.(@@@): domains of substitutions are not disjoint" -- | Lookups a variable in a substitution. Nothing indicates that the variable is diff --git a/src/Common/Rewriting/Term.hs b/src/Common/Rewriting/Term.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Term.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A simple data type for term rewriting +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Term where + +import Common.Utils (ShowString(..)) +import Common.Uniplate +import Control.Monad +import Common.Rewriting.MetaVar +import Data.Typeable + +----------------------------------------------------------- +-- * Data type for terms + +data Symbol = S (Maybe String) String + deriving (Eq, Ord) + +data Term = Var String + | Con Symbol + | App Term Term + | Num Integer + | Float Double + | Meta Int + deriving (Show, Eq, Ord, Typeable) + +instance Show Symbol where + show (S ma b) = maybe b (\a -> a++ "." ++ b) ma + +instance MetaVar Term where + metaVar = Meta + isMetaVar (Meta n) = Just n + isMetaVar _ = Nothing + +instance Uniplate Term where + uniplate (App f a) = ([f,a], \[g,b] -> App g b) + uniplate term = ([], \_ -> term) + +----------------------------------------------------------- +-- * Type class for conversion to/from terms + +class IsTerm a where + toTerm :: a -> Term + fromTerm :: MonadPlus m => Term -> m a + +instance IsTerm Term where + toTerm = id + fromTerm = return + +instance IsTerm ShowString where + toTerm = Var . fromShowString + fromTerm (Var s) = return (ShowString s) + fromTerm _ = fail "fromTerm" + +instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where + toTerm = either toTerm toTerm + fromTerm expr = + liftM Left (fromTerm expr) `mplus` + liftM Right (fromTerm expr) + +fromTermM :: (Monad m, IsTerm a) => Term -> m a +fromTermM = maybe (fail "fromTermM") return . fromTerm + +fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a +fromTermWith f a = + case getSpine a of + (t, xs) -> isCon t >>= \s -> mapM fromTermM xs >>= f s + +----------------------------------------------------------- +-- * Utility functions + +getSpine :: Term -> (Term, [Term]) +getSpine = rec [] + where + rec xs (App f a) = rec (a:xs) f + rec xs a = (a, xs) + +getConSpine :: Monad m => Term -> m (Symbol, [Term]) +getConSpine a = liftM (\s -> (s, xs)) (isCon b) + where (b, xs) = getSpine a + +makeTerm :: Term -> [Term] -> Term +makeTerm = foldl App + +makeConTerm :: Symbol -> [Term] -> Term +makeConTerm = makeTerm . Con + +unary :: Symbol -> Term -> Term +unary = App . Con + +binary :: Symbol -> Term -> Term -> Term +binary s = App . App (Con s) + +isUnary :: Symbol -> Term -> Maybe Term +isUnary s term = + case getSpine term of + (t, [a]) | isCon t == Just s -> Just a + _ -> Nothing + +isBinary :: Symbol -> Term -> Maybe (Term, Term) +isBinary s term = + case getSpine term of + (t, [a, b]) | isCon t == Just s -> Just (a, b) + _ -> Nothing + +isVar :: Monad m => Term -> m String +isVar (Var s) = return s +isVar _ = fail "isVar" + +isCon :: Monad m => Term -> m Symbol +isCon (Con s) = return s +isCon _ = fail "isCon" diff --git a/src/Common/Rewriting/Unification.hs b/src/Common/Rewriting/Unification.hs --- a/src/Common/Rewriting/Unification.hs +++ b/src/Common/Rewriting/Unification.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,23 +9,19 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Common.Rewriting.Unification - ( ShallowEq(..), Rewrite(..) - , unify, unifyM, unifyWith - , match, matchM, matchWith - ) where +module Common.Rewriting.Unification (match, Matcher, associativeMatcher) where +import Common.Rewriting.Term import Common.Rewriting.AC import Common.Rewriting.MetaVar import Common.Rewriting.Substitution -import Common.Uniplate import Control.Monad -import Test.QuickCheck import qualified Data.IntSet as IS +import qualified Data.Map as M ----------------------------------------------------------- -- Unification (in both ways) - +{- class ShallowEq a where shallowEq :: a -> a -> Bool @@ -66,36 +62,55 @@ s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) return (s2 @@ s1) recList _ _ = [] - +-} ----------------------------------------------------------- -- Matching (or: one-way unification) -match :: Rewrite a => a -> a -> [Substitution a] -match = matchWith operators - -matchM :: (MonadPlus m, Rewrite a) => a -> a -> m (Substitution a) -matchM x y = msum $ map return $ match x y - -matchWith :: Rewrite a => [Operator a] -> a -> a -> [Substitution a] -matchWith ops x y = do +match :: Matcher -> Term -> Term -> [Substitution Term] +match m x y = do s <- rec x y guard (IS.null $ dom s `IS.intersection` getMetaVars y) return s where - rec x y = - case isMetaVar x of - Just i | not (hasMetaVar i y) -> return $ singletonSubst i y - _ -> do - guard (shallowEq x y) - case findOperator ops x of - Just op -> - concatMap (uncurry recList . unzip) (pairingsMatch op x y) - Nothing -> - recList (children x) (children y) + rec (Meta i) y = do + guard (not (hasMetaVar i y)) + return (singletonSubst i y) + rec x y = do + let (a, as) = getSpine x + (b, bs) = getSpine y + case isCon a >>= (`M.lookup` m) of + Just f -> + concatMap (uncurry recList . unzip) (f x y) + Nothing -> do + guard (a == b) + recList as bs + recList [] [] = return emptySubst recList (x:xs) (y:ys) = do s1 <- rec x y s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) return (s2 @@ s1) recList _ _ = [] + +type Matcher = M.Map Symbol (Term -> Term -> [[(Term, Term)]]) + +associativeMatcher :: Symbol -> Matcher +associativeMatcher s = M.singleton s f + where + f a b = map (map make) result + where + (as, bs) = onBoth collect (a, b) + result = pairingsA2 True as bs + make = onBoth construct + + collect = ($ []) . rec + where + rec term = + case isBinary s term of + Just (a, b) -> rec a . rec b + Nothing -> (term:) + + construct xs + | null xs = error "associativeMatcher: empty list" + | otherwise = foldr1 (binary s) xs diff --git a/src/Common/Strategy.hs b/src/Common/Strategy.hs --- a/src/Common/Strategy.hs +++ b/src/Common/Strategy.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -16,384 +16,36 @@ ----------------------------------------------------------------------------- module Common.Strategy ( -- * Data types and type classes - Strategy, LabeledStrategy, strategyName, unlabel + Strategy, LabeledStrategy, strategyName , IsStrategy(..) -- * Running strategies , fullDerivationTree, derivationTree -- * Strategy combinators -- ** Basic combinators - , (<*>), (<|>), (<||>), succeed, fail, label, sequence, alternatives + , (<*>), (<|>), succeed, fail, label, sequence, alternatives -- <||> -- ** EBNF combinators , many, many1, replicate, option -- ** Negation and greedy combinators , check, not, repeat, repeat1, try, (|>), exhaustive -- ** Traversal combinators , fix, once, somewhere, topDown, bottomUp + -- * Configuration combinators + , module Common.Strategy.Configuration -- * Strategy locations - , StrategyLocation, StrategyOrRule, strategyLocations, subStrategy - , mapRules, rulesInStrategy, cleanUpStrategy + , StrategyLocation, topLocation, nextLocation, downLocation + , locationDepth + , subTaskLocation, nextTaskLocation, parseStrategyLocation + , StrategyOrRule, subStrategy, strategyLocations + , mapRules, mapRulesS, rulesInStrategy, cleanUpStrategy -- * Prefixes , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..) , prefixToSteps, stepsToRules, lastStepInPrefix ) where -import Common.Apply -import Common.Context -import Common.Derivation -import Common.Rewriting hiding (inverse) -import Common.Transformation -import Common.Uniplate (Uniplate, children) -import Common.Utils -import Prelude hiding (fail, not, repeat, replicate, sequence) -import qualified Common.Grammar as RE -import qualified Prelude as Prelude - ------------------------------------------------------------ --- Data types and type classes - --- | Abstract data type for a strategy -newtype Strategy a = S { unS :: RE.Grammar (Either (Rule a) (LabeledStrategy a)) } - --- | A strategy which is labeled with a string -data LabeledStrategy a = LS - { strategyName :: String -- ^ Returns the label of the strategy - , unlabel :: Strategy a -- ^ Removes the label from a strategy - } - --- | Type class to turn values into strategies -class Apply f => IsStrategy f where - toStrategy :: f a -> Strategy a - --- instances for Show -instance Show a => Show (Strategy a) where - show = show . unS - -instance Show a => Show (LabeledStrategy a) where - show s = - strategyName s ++ ": " ++ show (unlabel s) - --- instances for Apply -instance Apply Strategy where - applyAll s = results . fullDerivationTree s - -instance Apply LabeledStrategy where - applyAll = applyAll . unlabel - --- instances for IsStrategy -instance IsStrategy RewriteRule where - toStrategy r = - toStrategy (makeRule (ruleName r) (RewriteRule r)) - -instance IsStrategy Rule where - toStrategy = S . RE.symbol . Left - -instance IsStrategy Strategy where - toStrategy = id - -instance IsStrategy (LabeledStrategy) where - toStrategy = S . RE.symbol . Right - --- instances for Lift -instance Lift Strategy where - lift lp (S re) = S (fmap (either (Left . lift lp) (Right . lift lp)) re) - -instance Lift (LabeledStrategy) where - lift lp (LS n s) = LS n (lift lp s) - ------------------------------------------------------------ ---- Running strategies - --- | Returns the derivation tree for a strategy and a term, including all --- minor rules -fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a -fullDerivationTree = rec . noLabels . toStrategy - where - rec s a = addBranches (list s a) (singleNode a (RE.empty s)) - list s a = [ (f, rec rest b) - | (f, rest) <- RE.firsts s - , b <- applyAll f a - ] - --- | Returns the derivation tree for a strategy and a term with only major rules -derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a -derivationTree s = mergeSteps isMajorRule . fullDerivationTree s - -noLabels :: Strategy a -> RE.Grammar (Rule a) -noLabels = RE.join . fmap (either RE.symbol (noLabels . unlabel)) . unS - ------------------------------------------------------------ ---- Strategy combinators - --- Basic combinators -------------------------------------- - -infixr 3 <|> -infixr 4 <||> -infixr 5 <*> - --- | Put two strategies in sequence (first do this, then do that) -(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -s <*> t = S (unS (toStrategy s) RE.<*> unS (toStrategy t)) - --- | Choose between the two strategies (either do this or do that) -(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -s <|> t = S (unS (toStrategy s) RE.<|> unS (toStrategy t)) - --- | Run two strategies in parallel (with interleaving) -(<||>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -s <||> t = S (unS (toStrategy s) RE.<||> unS (toStrategy t)) - --- | The strategy that always succeeds (without doing anything) -succeed :: Strategy a -succeed = S RE.succeed - --- | The strategy that always fails -fail :: Strategy a -fail = S RE.fail - --- | Labels a strategy with a string -label :: IsStrategy f => String -> f a -> LabeledStrategy a -label l = LS l . toStrategy - --- | Puts a list of strategies into a sequence -sequence :: IsStrategy f => [f a] -> Strategy a -sequence = foldr ((<*>) . toStrategy) succeed - --- | Combines a list of alternative strategies -alternatives :: IsStrategy f => [f a] -> Strategy a -alternatives = foldr ((<|>) . toStrategy) fail - --- EBNF combinators -------------------------------------- - --- | Repeat a strategy zero or more times (non-greedy) -many :: IsStrategy f => f a -> Strategy a -many = S . RE.many . unS . toStrategy - --- | Apply a certain strategy at least once (non-greedy) -many1 :: IsStrategy f => f a -> Strategy a -many1 s = s <*> many s - --- | Apply a strategy a certain number of times -replicate :: IsStrategy f => Int -> f a -> Strategy a -replicate n = sequence . Prelude.replicate n - --- | Apply a certain strategy or do nothing (non-greedy) -option :: IsStrategy f => f a -> Strategy a -option s = s <|> succeed - --- Negation and greedy combinators ---------------------- - -infixr 4 |> - --- | Checks whether a predicate holds for the current term. The --- check is considered to be a minor step. -check :: (a -> Bool) -> Strategy a -check p = toStrategy checkRule - where - checkRule = minorRule $ makeSimpleRule "check" $ \a -> - if p a then Just a else Nothing - --- | Check whether or not the argument strategy cannot be applied: the result --- strategy only succeeds if this is not the case (otherwise it fails). -not :: IsStrategy f => f a -> Strategy a -not s = check (Prelude.not . applicable (toStrategy s)) - -{- alternative definition, with an early commit. No performance gain was -measurable - -applicableOne :: Strategy a -> a -> Bool -applicableOne s a = - let tree = derivationTree s a - in endpoint tree || Prelude.not (null (branches tree)) -} - --- | Repeat a strategy zero or more times (greedy version of 'many') -repeat :: IsStrategy f => f a -> Strategy a -repeat s = many s <*> not s - --- | Apply a certain strategy at least once (greedy version of 'many1') -repeat1 :: IsStrategy f => f a -> Strategy a -repeat1 s = many1 s <*> not s - --- | Apply a certain strategy if this is possible (greedy version of 'option') -try :: IsStrategy f => f a -> Strategy a -try s = s <|> not s - --- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise, --- try the right-operand strategy -(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -s |> t = s <|> (not s <*> t) - --- | Apply the strategies from the list exhaustively (until this is no longer possible) -exhaustive :: IsStrategy f => [f a] -> Strategy a -exhaustive = repeat . alternatives - --- Traversal combinators -------------------------------------------- - --- | A fix-point combinator on strategies (to model recursion). Powerful --- (but dangerous) combinator -fix :: (Strategy a -> Strategy a) -> Strategy a -fix f = S $ RE.fix $ unS . f . S - --- | Apply a strategy on (exactly) one of the term's direct children -once :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) -once s = ruleMoveDown <*> s <*> ruleMoveUp - where - ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" moveDown - moveDown c = - let n = maybe 0 (pred . length . children) (currentFocus c) - in [ changeLocation (locationDown i) c | i <- [0 .. n] ] - - ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" moveUp - moveUp c = do - new <- locationUp (location c) - return $ setLocation new c - --- | Apply a strategy somewhere in the term -somewhere :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) -somewhere s = fix $ \this -> s <|> once this - --- | Search for a suitable location in the term to apply the strategy using a --- top-down approach -topDown :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) -topDown s = fix $ \this -> s |> once this - --- | Search for a suitable location in the term to apply the strategy using a --- bottom-up approach -bottomUp :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) -bottomUp s = fix $ \this -> once this <|> (not (once (bottomUp s)) <*> s) - -{- The ideal implementation does not yet work: there appears to be a strange - interplay between the fixpoint operator (with variables) and the not combinator - > bottomUp s = fix $ \this -> once this |> s -} - ------------------------------------------------------------ ---- Strategy locations - --- | A strategy location corresponds to a substrategy or a rule -type StrategyLocation = [Int] - -type StrategyOrRule a = Either (LabeledStrategy a) (Rule a) - --- | Returns a list of all strategy locations, paired with the labeled --- substrategy or rule at that location -strategyLocations :: LabeledStrategy a -> [(StrategyLocation, Either (LabeledStrategy a) (Rule a))] -strategyLocations = rec [] - where - rec loc ns = - let f is = either (\r -> [ (is, Right r) | isMajorRule r ]) (rec is) - xs = RE.collectSymbols $ combine (,) loc $ unS $ unlabel ns - in (loc, Left ns) : concatMap (uncurry f) xs - --- | Returns the substrategy or rule at a strategy location. Nothing indicates that the location is invalid -subStrategy :: StrategyLocation -> LabeledStrategy a -> Maybe (StrategyOrRule a) -subStrategy loc s = - case loc of - [] -> return (Left s) - n:ns -> - case lookup n . RE.collectSymbols . RE.withIndex . unS . unlabel $ s of - Just (Left r) | null ns -> return (Right r) - Just (Right t) -> subStrategy ns t - _ -> Nothing - --- | Apply a function to all the rules that make up a labeled strategy -mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b -mapRules fun = f - where - f (LS n s) = LS n (g s) - g (S expr) = S (fmap h expr) - h (Left r) = Left (fun r) - h (Right ls) = Right (f ls) - --- | Returns a list of all major rules that are part of a labeled strategy -rulesInStrategy :: LabeledStrategy a -> [Rule a] -rulesInStrategy s = [ r | (_, Right r) <- strategyLocations s ] - --- local helper-function -combine :: ([Int] -> a -> b) -> [Int] -> RE.Grammar a -> RE.Grammar b -combine g is = fmap (\(i, a) -> g (is++[i]) a) . RE.withIndex - --- | Use a function as do-after hook for all rules in a labeled strategy -cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a -cleanUpStrategy f s = mapRules g (label (strategyName s) (doAfter f idRule <*> unlabel s)) - where - g r | isMajorRule r = doAfter f r - | otherwise = r - ------------------------------------------------------------ ---- Prefixes - --- | Abstract data type for a (labeled) strategy with a prefix (a sequence of --- executed rules). A prefix is still "aware" of the labels that appear in the --- strategy. A prefix is encoded as a list of integers (and can be reconstructed --- from such a list: see @makePrefix@). The list is stored in reversed order. -data Prefix a = P [(Int, Step a)] (RE.Grammar (Step a)) - -instance Show (Prefix a) where - show (P xs _) = show (reverse (map fst xs)) - -instance Eq (Prefix a) where - P xs _ == P ys _ = map fst xs == map fst ys - --- | Construct the empty prefix for a labeled strategy -emptyPrefix :: LabeledStrategy a -> Prefix a -emptyPrefix = makePrefix [] - --- | Construct a prefix for a given list of integers and a labeled strategy. -makePrefix :: [Int] -> LabeledStrategy a -> Prefix a -makePrefix is ls = rec [] is start - where - start = withSteps ls - - rec acc [] g = P acc g - rec acc (n:ns) g = - case drop n (RE.firsts g) of - (z, h):_ -> rec ((n, z):acc) ns h - _ -> P [] start - --- | The @Step@ data type can be used to inspect the structure of the strategy -data Step a = Begin StrategyLocation - | Step StrategyLocation (Rule a) - | End StrategyLocation - deriving (Show, Eq) - -instance Apply Step where - applyAll (Step _ r) = applyAll r - applyAll (Begin _) = return - applyAll (End _) = return - -instance Apply Prefix where - applyAll p = results . prefixTree p - --- | Create a derivation tree with a "prefix" as annotation. -prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a -prefixTree (P xs g) a = - addBranches list (singleNode a (RE.empty g)) - where - add (i, (step, rest)) = P ((i, step):xs) rest - list = [ (newPrefix, prefixTree newPrefix b) - | triple@(_, (step, _)) <- zip [0..] (RE.firsts g) - , let newPrefix = add triple - , b <- applyAll step a - ] - --- | Returns the steps that belong to the prefix -prefixToSteps :: Prefix a -> [Step a] -prefixToSteps (P xs _) = map snd (reverse xs) - --- | Retrieves the rules from a list of steps -stepsToRules :: [Step a] -> [Rule a] -stepsToRules steps = [ r | Step _ r <- steps ] - --- | Returns the last rule of a prefix (if such a rule exists) -lastStepInPrefix :: Prefix a -> Maybe (Step a) -lastStepInPrefix (P xs _) = safeHead (map snd xs) +import Common.Strategy.Abstract +import Common.Strategy.Combinators +import Common.Strategy.Prefix +import Common.Strategy.Location +import Common.Strategy.Configuration --- local helper function -withSteps :: LabeledStrategy a -> RE.Grammar (Step a) -withSteps = rec [] - where - rec is = mark is . RE.join . combine f is . unS . unlabel - f is = either (RE.symbol . Step is) (rec is) - mark is g = - let begin = RE.symbol (Begin is) - end = RE.symbol (End is) - in begin RE.<*> g RE.<*> end +import qualified Prelude () diff --git a/src/Common/Strategy/Abstract.hs b/src/Common/Strategy/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Abstract.hs @@ -0,0 +1,218 @@ +{-# OPTIONS -XFlexibleInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Strategy.Abstract + ( Strategy, IsStrategy(..) + , LabeledStrategy, label, unlabel + , fullDerivationTree, derivationTree, rulesInStrategy + , mapRules, mapRulesS, cleanUpStrategy + -- Accessors to the underlying representation + , toCore, fromCore, liftCore, liftCore2, fixCore, makeLabeledStrategy + , toLabeledStrategy + , LabelInfo, strategyName, processLabelInfo, changeInfo, makeInfo + , removed, collapsed, hidden, labelName, IsLabeled(..) + ) where + +import Common.Utils (commaList) +import Common.Strategy.Core +import Common.Strategy.BiasedChoice +import Common.Apply +import Common.Rewriting (RewriteRule(..)) +import Common.Transformation +import Common.Derivation +import Common.Uniplate + +----------------------------------------------------------- +--- Strategy data-type + +-- | Abstract data type for strategies +newtype Strategy a = S { toCore :: Core LabelInfo a } + +instance Show (Strategy a) where + show = show . toCore + +instance Apply Strategy where + applyAll s = results . fullDerivationTree s + +----------------------------------------------------------- +--- The information used as label in a strategy + +data LabelInfo = Info + { labelName :: String + , removed :: Bool + , collapsed :: Bool + , hidden :: Bool + } + +instance Show LabelInfo where + show info = + let ps = ["removed" | removed info] ++ + ["collapsed" | collapsed info] ++ + ["hidden" | hidden info] + extra = " (" ++ commaList ps ++ ")" + in show (labelName info) ++ if null ps then "" else extra + +makeInfo :: String -> LabelInfo +makeInfo s = Info s False False False + +----------------------------------------------------------- +--- Type class + +-- | Type class to turn values into strategies +class Apply f => IsStrategy f where + toStrategy :: f a -> Strategy a + +instance IsStrategy (Core LabelInfo) where + toStrategy = S + +instance IsStrategy Strategy where + toStrategy = id + +instance IsStrategy (LabeledStrategy) where + toStrategy (LS info (S core)) = + case core of + Rule Nothing r | name r == labelName info -> + S (Rule (Just info) r) + _ -> S (Label info core) + +instance IsStrategy Rule where -- Major rules receive a label + toStrategy r + | isMajorRule r = toStrategy (toLabeled r) + | otherwise = S (Rule Nothing r) + +instance IsStrategy RewriteRule where + toStrategy r = + toStrategy (makeRule (ruleName r) (RewriteRule r)) + +----------------------------------------------------------- +--- Labeled Strategy data-type + +-- | A strategy which is labeled with a string +data LabeledStrategy a = LS + { labelInfo :: LabelInfo -- ^ Returns information associated with this label + , unlabel :: Strategy a -- ^ Removes the label from a strategy + } + +makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a +makeLabeledStrategy info = LS info . toStrategy + +toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a) +toLabeledStrategy s = + case toCore s of + Label l c -> return (makeLabeledStrategy l (fromCore c)) + _ -> fail "Strategy without label" + +strategyName :: LabeledStrategy a -> String +strategyName = getLabel + +instance Show (LabeledStrategy a) where + show s = show (labelInfo s) ++ ": " ++ show (unlabel s) + +instance Apply LabeledStrategy where + applyAll = applyAll . toStrategy + +class IsLabeled f where + toLabeled :: f a -> LabeledStrategy a + +instance IsLabeled LabeledStrategy where + toLabeled = id + +instance IsLabeled Rule where + toLabeled r = LS (makeInfo (name r)) (S (Rule Nothing r)) + +instance IsLabeled RewriteRule where + toLabeled r = toLabeled (makeRule (ruleName r) (RewriteRule r)) + +-- | Labels a strategy with a string +label :: IsStrategy f => String -> f a -> LabeledStrategy a +label l = LS (makeInfo l) . toStrategy + +getLabel :: IsLabeled f => f a -> String +getLabel = labelName . labelInfo . toLabeled + +changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a +changeInfo f a = LS (f info) s + where LS info s = toLabeled a + +----------------------------------------------------------- +--- Process Label Information + +processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a +processLabelInfo getInfo = mapCore forLabel forRule + where + forLabel l c + | removed info = Fail + | collapsed info = Rule (Just l) asRule + | otherwise = new + where + new | hidden info = mapRule minorRule (Label l c) + | otherwise = Label l c + info = getInfo l + asRule = makeSimpleRuleList (labelName info ++ " (collapsed)") (applyAll new) + forRule (Just l) r + | removed info = Fail + | hidden info = Rule (Just l) (minorRule r) + | otherwise = Rule (Just l) r + where + info = getInfo l + forRule _ r = Rule Nothing r + +----------------------------------------------------------- +--- Remaining functions + +-- | Returns the derivation tree for a strategy and a term, including all +-- minor rules +fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a +fullDerivationTree = makeBiasedTree p . processLabelInfo id . toCore . toStrategy + where + p t = endpoint t || any isMajorRule (annotations t) || any p (subtrees t) + +-- | Returns the derivation tree for a strategy and a term with only major rules +derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a +derivationTree s = mergeSteps isMajorRule . fullDerivationTree s + +-- | Returns a list of all major rules that are part of a labeled strategy +rulesInStrategy :: IsStrategy f => f a -> [Rule a] +rulesInStrategy f = [ r | Rule _ r <- universe (toCore (toStrategy f)), isMajorRule r ] + +-- | Apply a function to all the rules that make up a labeled strategy +mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b +mapRules f (LS n s) = LS n (mapRulesS f s) + +mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b +mapRulesS f = S . mapRule f . toCore + +-- | Use a function as do-after hook for all rules in a labeled strategy +cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a +cleanUpStrategy f (LS n s) = mapRules g (LS n (S core)) + where + core = Rule Nothing (doAfter f idRule) :*: toCore s + g r | isMajorRule r = doAfter f r + | otherwise = r + +----------------------------------------------------------- +--- Functions to lift the core combinators + +fromCore :: Core LabelInfo a -> Strategy a +fromCore = toStrategy + +liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a +liftCore f = fromCore . f . toCore . toStrategy + +liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a +liftCore2 f = liftCore . f . toCore . toStrategy + +fixCore :: (Core l a -> Core l a) -> Core l a +fixCore f = Rec i (f (Var i)) -- disadvantage: function f is applied twice + where + s = coreVars (f (Rule Nothing idRule)) + i = if null s then 0 else maximum s + 1 diff --git a/src/Common/Strategy/BiasedChoice.hs b/src/Common/Strategy/BiasedChoice.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/BiasedChoice.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Strategy.BiasedChoice + ( Bias(..), placeBiasLabels, biasTreeG, makeBiasedTree + ) where + +import Common.Apply +-- import Common.View +import Common.Derivation +import Common.Transformation +import Common.Strategy.Core +-- import Common.Uniplate + +data Bias f a = TryFirst BiasId | OrElse BiasId | Normal (f a) deriving Show +type BiasId = Int + +instance Apply f => Apply (Bias f) where + applyAll (Normal r) = applyAll r + applyAll _ = return + +-- Disabled! +placeBiasLabels :: Core l a -> Core (Either (Bias f a) l) a +placeBiasLabels = {-fst . rec 0 . -}mapLabel Right + where {- + -- Left-biased choice + rec n (a :|>: b) = + let (ra, n1) = rec n a + (rb, n2) = rec n1 b + left = Label (Left (TryFirst n)) ra + right = Label (Left (OrElse n)) rb + in (left :|: right, n2) + -- All other cases + rec n core = + let (cs, f) = uniplate core + in first f (recList n cs) + + recList n [] = ([], n) + recList n (x:xs) = + let (a, n1) = rec n x + (as, n2) = recList n1 xs + in (a:as, n2) -} + +biasTranslation :: (Rule a -> f a) -> Translation (Either (Bias f a) l) a (Bias f a) +biasTranslation f = (either Before (const Skip), Normal . f) + +biasTreeG :: (DerivationTree (f a, info) a -> Bool) -> DerivationTree (Bias f a, info) a -> DerivationTree (f a, info) a +biasTreeG success t = t {branches = f [] (branches t)} + where + f _ [] = [] + f env (((bias, info), st):xs) = + case bias of + TryFirst n + | success new -> branches new ++ f (n:env) xs + | otherwise -> f env xs + where new = biasTreeG success st + OrElse n + | n `elem` env -> f env xs + | otherwise -> branches (biasTreeG success st) ++ f env xs + Normal r -> ((r, info), biasTreeG success st):f env xs + +-- success :: DerivationTree s a -> Bool +-- success = isJust . derivation + +biasTree :: (DerivationTree (f a) a -> Bool) -> DerivationTree (Bias f a) a -> DerivationTree (f a) a +biasTree success t = t {branches = f [] (branches t)} + where + f _ [] = [] + f env ((bias, st):xs) = + case bias of + TryFirst n + | success new -> branches new ++ f (n:env) xs + | otherwise -> f env xs + where new = biasTree success st + OrElse n + | n `elem` env -> f env xs + | otherwise -> branches (biasTree success st) ++ f env xs + Normal r -> (r, biasTree success st):f env xs +{- + success :: DerivationTree s a -> Bool + success = isJust . derivation -} + +makeBiasedTree :: (DerivationTree (Rule a) a -> Bool) -> Core l a -> a -> DerivationTree (Rule a) a +makeBiasedTree p core = + biasTree p . changeLabel fst . runTree (strategyTree (biasTranslation id) (placeBiasLabels core)) + +------------------------- +{- +test = makeBiasedTree (maybe False (const True) . derivation) myCore 5 + +myCore = (r1 :|>: r2) :|: (r3 :|>: r4) + where + r1 = make "r1" $ \n -> trace "**1**" [n*n] + r2 = make "r2" $ \n -> trace "**2**" [n+1] + r3 = make "r3" $ \n -> trace "**3**" [n*2] + r4 = make "r4" $ \n -> trace "**4**" [n `div` 2] + trace _ = id + make n = Rule Nothing . minorRule . makeSimpleRuleList n -} diff --git a/src/Common/Strategy/Combinators.hs b/src/Common/Strategy/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Combinators.hs @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A collection of strategy combinators: all lifted to work on different +-- data types +-- +----------------------------------------------------------------------------- +module Common.Strategy.Combinators where + +import Prelude hiding (not, repeat, fail, sequence) +import Common.Context +import Common.Navigator +import Common.Transformation +import Common.Strategy.Core +import Common.Strategy.Abstract + +----------------------------------------------------------- +--- Strategy combinators + +-- Basic combinators -------------------------------------- + +infixr 3 <|> +infixr 4 |> +infixr 5 <*> + +-- | Put two strategies in sequence (first do this, then do that) +(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(<*>) = liftCore2 (:*:) + +-- | Choose between the two strategies (either do this or do that) +(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(<|>) = liftCore2 (:|:) + +-- | The strategy that always succeeds (without doing anything) +succeed :: Strategy a +succeed = fromCore Succeed + +-- | The strategy that always fails +fail :: Strategy a +fail = fromCore Fail + +-- | Puts a list of strategies into a sequence +sequence :: IsStrategy f => [f a] -> Strategy a +sequence = foldr ((<*>) . toStrategy) succeed + +-- | Combines a list of alternative strategies +alternatives :: IsStrategy f => [f a] -> Strategy a +alternatives = foldr ((<|>) . toStrategy) fail + +-- EBNF combinators -------------------------------------- + +-- | Repeat a strategy zero or more times (non-greedy) +many :: IsStrategy f => f a -> Strategy a +many = liftCore Many + +-- | Apply a certain strategy at least once (non-greedy) +many1 :: IsStrategy f => f a -> Strategy a +many1 s = s <*> many s + +-- | Apply a strategy a certain number of times +replicate :: IsStrategy f => Int -> f a -> Strategy a +replicate n = sequence . Prelude.replicate n + +-- | Apply a certain strategy or do nothing (non-greedy) +option :: IsStrategy f => f a -> Strategy a +option s = s <|> succeed + +-- Negation and greedy combinators ---------------------- + +-- | Checks whether a predicate holds for the current term. The +-- check is considered to be a minor step. +check :: (a -> Bool) -> Strategy a +check p = toStrategy (checkRule p) + +-- | Check whether or not the argument strategy cannot be applied: the result +-- strategy only succeeds if this is not the case (otherwise it fails). +not :: IsStrategy f => f a -> Strategy a +not = liftCore (Not . noLabels) + +-- | Repeat a strategy zero or more times (greedy version of 'many') +repeat :: IsStrategy f => f a -> Strategy a +repeat = liftCore Repeat + +-- | Apply a certain strategy at least once (greedy version of 'many1') +repeat1 :: IsStrategy f => f a -> Strategy a +repeat1 s = s <*> repeat s + +-- | Apply a certain strategy if this is possible (greedy version of 'option') +try :: IsStrategy f => f a -> Strategy a +try s = s |> succeed + +-- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise, +-- try the right-operand strategy +(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(|>) = liftCore2 (:|>:) + +-- | Apply the strategies from the list exhaustively (until this is no longer possible) +exhaustive :: IsStrategy f => [f a] -> Strategy a +exhaustive = repeat . alternatives + +-- Traversal combinators -------------------------------------------- + +-- | A fix-point combinator on strategies (to model recursion). Powerful +-- (but dangerous) combinator +fix :: (Strategy a -> Strategy a) -> Strategy a +fix f = fromCore (fixCore (toCore . f . fromCore)) + +-- | Apply a strategy on (exactly) one of the term's direct children +once :: IsStrategy f => f (Context a) -> Strategy (Context a) +once s = ruleMoveDown <*> s <*> ruleMoveUp + where + ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" allDowns + ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" up + +-- | Apply a strategy somewhere in the term +somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a) +somewhere s = fix $ \this -> s <|> once this + +-- | Search for a suitable location in the term to apply the strategy using a +-- top-down approach +topDown :: IsStrategy f => f (Context a) -> Strategy (Context a) +topDown s = fix $ \this -> s |> once this + +-- | Search for a suitable location in the term to apply the strategy using a +-- bottom-up approach +bottomUp :: IsStrategy f => f (Context a) -> Strategy (Context a) +bottomUp s = fix $ \this -> once this <|> (not (once (bottomUp s)) <*> s) + +{- The ideal implementation does not yet work: there appears to be a strange + interplay between the fixpoint operator (with variables) and the not combinator + > bottomUp s = fix $ \this -> once this |> s -} diff --git a/src/Common/Strategy/Configuration.hs b/src/Common/Strategy/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Configuration.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Strategy.Configuration + ( -- Types and constructors + StrategyConfiguration, ConfigItem + , ConfigLocation(..), ConfigAction(..), configActions + -- Configure + , configure + -- Combinators + , remove, reinsert, collapse, expand, hide, reveal + ) where + +import Common.Strategy.Abstract +import Common.Strategy.Core +import Common.Strategy.Location +import Common.Transformation + +--------------------------------------------------------------------- +-- Types and constructors + +type StrategyConfiguration = [ConfigItem] +type ConfigItem = (ConfigLocation, ConfigAction) + +data ConfigLocation + = ByName String + | ByGroup String + | ByLocation StrategyLocation + deriving Show + +data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal + deriving (Show, Enum) + +configActions :: [ConfigAction] +configActions = [Remove .. ] + +--------------------------------------------------------------------- +-- Configure + +configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a +configure cfg ls = + label (strategyName ls) (configureCore cfg (toCore (unlabel ls))) + +configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a +configureCore cfg = mapCore f g . addLocation + where + f pair a = Label (change pair []) a + g (Just pair) r = Rule (Just (change pair (ruleGroups r))) r + g Nothing r = Rule Nothing r + + change pair@(_, info) groups = + let actions = getActions pair groups cfg + in foldr doAction info actions + +getActions :: (StrategyLocation, LabelInfo) -> [String] + -> StrategyConfiguration -> [ConfigAction] +getActions (loc, info) groups = map snd . filter (select . fst) + where + select (ByName s) = labelName info == s + select (ByGroup s) = s `elem` groups + select (ByLocation l) = loc == l + +doAction :: ConfigAction -> LabelInfo -> LabelInfo +doAction action = + case action of + Remove -> setRemoved True + Reinsert -> setRemoved False + Collapse -> setCollapsed True + Expand -> setCollapsed False + Hide -> setHidden True + Reveal -> setHidden False + +--------------------------------------------------------------------- +-- Configuration combinators + +remove, reinsert :: IsLabeled f => f a -> LabeledStrategy a +remove = changeInfo (doAction Remove) +reinsert = changeInfo (doAction Reinsert) + +collapse, expand :: IsLabeled f => f a -> LabeledStrategy a +collapse = changeInfo (doAction Collapse) +expand = changeInfo (doAction Expand) + +hide, reveal :: IsLabeled f => f a -> LabeledStrategy a +hide = changeInfo (doAction Hide) +reveal = changeInfo (doAction Reveal) + +-- helpers +setRemoved, setCollapsed, setHidden :: Bool -> LabelInfo -> LabelInfo +setRemoved b info = info {removed = b} +setCollapsed b info = info {collapsed = b} +setHidden b info = info {hidden = b} diff --git a/src/Common/Strategy/Core.hs b/src/Common/Strategy/Core.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Core.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- The core strategy combinators. This module defines the interal data +-- structure of a strategy, and some utility functions that operate +-- directly on it. +-- +----------------------------------------------------------------------------- +module Common.Strategy.Core + ( Core(..) + , strategyTree, runTree --, makeTree + , mapRule, coreVars, noLabels, mapCore, mapCoreM --, catMaybeLabel --, , + , mapLabel, Translation, ForLabel(..) --, simpleTranslation + ) where + +import qualified Common.Strategy.Grammar as Grammar +import Common.Strategy.Grammar (Grammar, (<*>), (<|>), symbol) +import Common.Apply +import Common.Derivation +import Common.Transformation +import Common.Uniplate +import Control.Monad.Identity + +----------------------------------------------------------------- +-- Strategy (internal) data structure, containing a selection +-- of combinators + +infixr 3 :|:, :|>: +infixr 5 :*: + +-- Some rules receive label (but not all) +data Core l a + = Core l a :*: Core l a + | Core l a :|: Core l a + | Core l a :|>: Core l a + | Many (Core l a) + | Repeat (Core l a) + | Not (Core () a) -- proves that there are no labels inside + | Label l (Core l a) + | Succeed + | Fail + | Rule (Maybe l) (Rule a) + | Var Int + | Rec Int (Core l a) + deriving Show + +----------------------------------------------------------------- +-- Useful instances + +instance Apply (Core l) where + applyAll core = results . makeTree core + +instance Uniplate (Core l a) where + uniplate core = + case core of + a :*: b -> ([a,b], \[x,y] -> x :*: y) + a :|: b -> ([a,b], \[x,y] -> x :|: y) + a :|>: b -> ([a,b], \[x,y] -> x :|>: y) + Many a -> ([a], \[x] -> Many x) + Repeat a -> ([a], \[x] -> Repeat x) + Label l a -> ([a], \[x] -> Label l x) + Rec n a -> ([a], \[x] -> Rec n x) + Not a -> ([noLabels a], \[x] -> Not (noLabels x)) + _ -> ([], \_ -> core) + +----------------------------------------------------------------- +-- The strategy tree (static, no term) + +strategyTree :: Translation l a b -> Core l a -> DerivationTree b () +strategyTree t = grammarTree . toGrammar t + +grammarTree :: Grammar a -> DerivationTree a () +grammarTree gr = addBranches list node + where + node = singleNode () (Grammar.empty gr) + list = [ (f, grammarTree rest) | (f, rest) <- Grammar.firsts gr ] + +----------------------------------------------------------------- +-- Running a strategy + +makeTree :: Core l a -> a -> DerivationTree (Rule a) a +makeTree c = changeLabel fst . runTree (strategyTree simpleTranslation c) + +runTree :: Apply f => DerivationTree (f a) info -> a -> DerivationTree (f a, info) a +runTree t a = addBranches list (singleNode a (endpoint t)) + where + list = concatMap make (branches t) + make (f, st) = [ ((f, root st), runTree st b) | b <- applyAll f a ] + +----------------------------------------------------------------- +-- Translation to Grammar data type + +type Translation l a b = (l -> ForLabel b, Rule a -> b) + +data ForLabel a = Skip | Before a | After a | Around a a + +simpleTranslation :: Translation l a (Rule a) +simpleTranslation = (const Skip, id) + +toGrammar :: Translation l a b -> Core l a -> Grammar b +toGrammar (f, g) = rec + where + rec core = + case core of + a :*: b -> rec a <*> rec b + a :|: b -> rec a <|> rec b + a :|>: b -> rec (a :|: (Not (noLabels a) :*: b)) + Many a -> Grammar.many (rec a) + Repeat a -> rec (Many a :*: Not (noLabels a)) + Succeed -> Grammar.succeed + Fail -> Grammar.fail + Label l a -> forLabel l (rec a) + Rule ml r -> (maybe id forLabel ml) (symbol (g r)) + Var n -> Grammar.var n + Rec n a -> Grammar.rec n (rec a) + Not a -> symbol (g (notRule a)) + + forLabel l g = + case f l of + Skip -> g + Before s -> symbol s <*> g + After t -> g <*> symbol t + Around s t -> symbol s <*> g <*> symbol t + +notRule :: Apply f => f a -> Rule a +notRule f = checkRule (not . applicable f) + +----------------------------------------------------------------- +-- Utility functions + +mapLabel :: (l -> m) -> Core l a -> Core m a +mapLabel f = mapCore (Label . f) (Rule . fmap f) + +mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b +mapRule f = mapCore Label (\ml -> Rule ml . f) + +noLabels :: Core l a -> Core m a +noLabels = mapCore (const id) (const (Rule Nothing)) + +-- catMaybeLabel :: Core (Maybe l) a -> Core l a +-- catMaybeLabel = mapCore (maybe id Label) (Rule . join) + +mapCore :: (l -> Core m b -> Core m b) -> (Maybe l -> Rule a -> Core m b) + -> Core l a -> Core m b +mapCore f g = + let fm l = return . f l . runIdentity + gm l = return . g l + in runIdentity . mapCoreM fm gm + +-- The most primitive function that applies functions to the label and +-- rule alternatives. Monadic version. +mapCoreM :: Monad m => (k -> m (Core l b) -> m (Core l b)) + -> (Maybe k -> Rule a -> m (Core l b)) + -> Core k a -> m (Core l b) +mapCoreM f g = rec + where + rec core = + case core of + a :*: b -> liftM2 (:*:) (rec a) (rec b) + a :|: b -> liftM2 (:|:) (rec a) (rec b) + a :|>: b -> liftM2 (:|>:) (rec a) (rec b) + Many a -> liftM Many (rec a) + Repeat a -> liftM Repeat (rec a) + Succeed -> return Succeed + Fail -> return Fail + Label l a -> f l (rec a) + Rule ml r -> g ml r + Var n -> return (Var n) + Rec n a -> liftM (Rec n) (rec a) + Not a -> do + let recNot h = mapCoreM (const id) (const h) + b <- recNot (g Nothing) a + c <- recNot (return . Rule Nothing) b + return (Not c) + +coreVars :: Core l a -> [Int] +coreVars s = [ n | Rec n _ <- universe s ] ++ [ n | Var n <- universe s ] diff --git a/src/Common/Strategy/Grammar.hs b/src/Common/Strategy/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Grammar.hs @@ -0,0 +1,367 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines a set of combinators for context-free grammars. These +-- grammars are the basis of the strategies. The fix-point combinator 'fix' +-- makes it context-free. The code is based on the RTS'08 paper +-- "Recognizing Strategies" +-- +----------------------------------------------------------------------------- +module Common.Strategy.Grammar + ( -- * Abstract data type + Grammar + -- * Smart constructor functions + , (<*>), (<|>), (<||>), var, rec, fix, many, succeed, fail, symbol + -- * Elementary operations + , empty, firsts, nonempty + -- * Membership and generated language + , member, language, languageBF + -- * Additional functions + , collectSymbols, join, withIndex + -- * QuickCheck properties + , checks + ) where + +import Common.Uniplate +import Control.Monad (liftM, liftM2) +import Data.List +import Prelude hiding (fail) +import Test.QuickCheck +import qualified Data.Set as S + +---------------------------------------------------------------------- +-- Abstract data type + +data Grammar a = Grammar a :*: Grammar a + | Grammar a :|: Grammar a + | Grammar a :||: Grammar a + | Rec Int (Grammar a) + | Symbol a | Var Int | Succeed | Fail deriving Show + +infixr 3 :|:, <|> +infixr 4 :||:, <||> +infixr 5 :*:, <*> + +---------------------------------------------------------------------- +-- Smart constructor functions + +-- simple constructors +succeed, fail :: Grammar a +var :: Int -> Grammar a +symbol :: a -> Grammar a + +succeed = Succeed +fail = Fail +symbol = Symbol +var = Var + +-- | Smart constructor for sequences: removes fails and succeeds in the +-- operands +(<*>) :: Grammar a -> Grammar a -> Grammar a +Succeed <*> t = t +s <*> Succeed = s +Fail <*> _ = fail +_ <*> Fail = fail +(s :*: t) <*> u = s :*: (t <*> u) +s <*> t = s :*: t + +-- | Smart constructor for alternatives: removes fails in the operands, and +-- merges succeeds if present in both arguments +(<|>) :: Grammar a -> Grammar a -> Grammar a +Fail <|> t = t +s <|> Fail = s +(s :|: t) <|> u = s :|: (t <|> u) +Succeed <|> Succeed = Succeed +s <|> t = s :|: t + +-- | Smart constructor for parallel execution: removes fails and succeeds in the operands +(<||>) :: Grammar a -> Grammar a -> Grammar a +Succeed <||> t = t +s <||> Succeed = s +Fail <||> _ = fail +_ <||> Fail = fail +(s :||: t) <||> u = s :||: (t <||> u) +s <||> t = s :||: t + +-- | For constructing a recursive grammar +rec :: Int -> Grammar a -> Grammar a +rec i s = if i `S.member` freeVars s then Rec i s else s + + +-- | Fix-point combinator to model recursion. Be careful: this combinator is +-- VERY powerfull, and it is your own responsibility that the result +-- is a valid, non-left-recursive grammar +fix :: (Grammar a -> Grammar a) -> Grammar a +fix f = Rec i (f (Var i)) -- disadvantage: function f is applied twice + where + s = allVars (f Succeed) + i = if S.null s then 0 else S.findMax s + 1 + +-- | Zero or more occurrences +many :: Grammar a -> Grammar a +many s = rec 0 (succeed <|> (nonempty s <*> var 0)) +{- TODO: deal with free variables? +many s = rec i (succeed <|> (nonempty s <*> var i)) + where + vs = freeVars s + i = if S.null vs then 0 else 1 + S.findMax vs -} + +---------------------------------------------------------------------- +-- Elementary operations + +-- | Tests whether the grammar accepts the empty string +empty :: Grammar a -> Bool +empty (s :*: t) = empty s && empty t +empty (s :|: t) = empty s || empty t +empty (s :||: t) = empty s && empty t +empty (Rec _ s) = empty s +empty Succeed = True +empty _ = False + +-- | Returns the firsts set of the grammar, where each symbol is +-- paired with the remaining grammar +firsts :: Grammar a -> [(a, Grammar a)] +firsts (s :*: t) = [ (a, s' <*> t) | (a, s') <- firsts s ] ++ + (if empty s then firsts t else []) +firsts (s :|: t) = firsts s ++ firsts t +firsts (s :||: t) = [ (a, s' <||> t ) | (a, s') <- firsts s ] ++ + [ (a, s <||> t' ) | (a, t') <- firsts t] +firsts (Rec i s) = firsts (replaceVar i (Rec i s) s) +firsts (Symbol a) = [(a, succeed)] +firsts _ = [] + +-- | Returns the grammar without the empty string alternative +nonempty :: Grammar a -> Grammar a +nonempty s = foldr (<|>) fail [ symbol a <*> t | (a, t) <- firsts s ] + +---------------------------------------------------------------------- +-- Membership and generated language + +-- | Checks whether a string is member of the grammar's language +member :: Eq a => [a] -> Grammar a -> Bool +member [] g = empty g +member (a:as) g = not $ null [ () | (b, t) <- firsts g, a==b, member as t ] + +-- | Generates the language of the grammar (list can be infinite). The sentences are +-- returned sorted by length, thus in a breadth-first order. The integer that is passed +-- is the cut-off depth (the maximal length of the sentences) needed to avoid non-termination +language :: Int -> Grammar a -> [[a]] +language n = concat . take n . languageBF + +-- | Generates the language of a grammar in a breadth-first manner, which is made explicit +-- by the outermost list. Sentences are grouped by their length +languageBF :: Grammar a -> [[[a]]] +languageBF s = [ [] | empty s ] : merge [ map (map (a:)) $ languageBF t | (a, t) <- firsts s ] + where merge = map concat . transpose + +---------------------------------------------------------------------- +-- Additional functions + +-- | Collect all the symbols of the grammar +collectSymbols :: Grammar a -> [a] +collectSymbols (Symbol a) = [a] +collectSymbols g = compos [] (++) collectSymbols g + +-- | The (monadic) join +join :: Grammar (Grammar a) -> Grammar a +join = mapSymbol id + +-- | Label all symbols with an index (from left to right) +withIndex :: Grammar a -> Grammar (Int, a) +withIndex = snd . rec 0 + where + rec :: Int -> Grammar a -> (Int, Grammar (Int, a)) + rec n grammar = + case grammar of + p :*: q -> let (n1, a) = rec n p + (n2, b) = rec n1 q + in (n2, a :*: b) + p :|: q -> let (n1, a) = rec n p + (n2, b) = rec n1 q + in (n2, a :|: b) + p :||: q -> let (n1, a) = rec n p + (n2, b) = rec n1 q + in (n2, a :||: b) + Rec i s -> let (n1, a) = rec n s + in (n1, Rec i a) + Var i -> (n, Var i) + Symbol a -> (n+1, Symbol (n, a)) + Succeed -> (n, Succeed) + Fail -> (n, Fail) + +---------------------------------------------------------------------- +-- Local helper functions and instances + +instance Uniplate (Grammar a) where + uniplate (s :*: t) = ([s,t], \[a,b] -> a :*: b) + uniplate (s :|: t) = ([s,t], \[a,b] -> a :|: b) + uniplate (s :||: t) = ([s,t], \[a,b] -> a :||: b) + uniplate (Rec i s) = ([s] , \[a] -> Rec i a) + uniplate g = ([] , \[] -> g) + +instance Functor Grammar where + fmap f = mapSymbol (symbol . f) + +freeVars :: Grammar a -> S.Set Int +freeVars (Rec i s) = freeVars s S.\\ S.singleton i +freeVars (Var i) = S.singleton i +freeVars g = compos S.empty S.union freeVars g + +allVars :: Grammar a -> S.Set Int +allVars (Var i) = S.singleton i +allVars g = compos S.empty S.union allVars g + +replaceVar :: Int -> Grammar a -> Grammar a -> Grammar a +replaceVar i new = rec + where + rec g = + case g of + Var j | i==j -> new + Rec j _ | i==j -> g + _ -> f $ map rec cs + where (cs, f) = uniplate g + +mapSymbol :: (a -> Grammar b) -> Grammar a -> Grammar b +mapSymbol f (p :*: q) = mapSymbol f p <*> mapSymbol f q +mapSymbol f (p :|: q) = mapSymbol f p <|> mapSymbol f q +mapSymbol f (p :||: q) = mapSymbol f p <||> mapSymbol f q +mapSymbol f (Rec i p) = Rec i (mapSymbol f p) +mapSymbol _ (Var i) = Var i +mapSymbol f (Symbol a) = f a +mapSymbol _ Succeed = Succeed +mapSymbol _ Fail = Fail + +-------------------------------------------------------- +-- QuickCheck generator + +instance Arbitrary a => Arbitrary (Grammar a) where + arbitrary = sized (arbGrammar []) +instance CoArbitrary a => CoArbitrary (Grammar a) where + coarbitrary grammar = + case grammar of + p :*: q -> variant 0 . coarbitrary p . coarbitrary q + p :|: q -> variant 1 . coarbitrary p . coarbitrary q + p :||: q -> variant 2 . coarbitrary p . coarbitrary q + Rec i p -> variant 3 . coarbitrary i . coarbitrary p + Var i -> variant 4 . coarbitrary i + Symbol a -> variant 5 . coarbitrary a + Succeed -> variant 6 + Fail -> variant 7 + +-- Use smart constructors here +arbGrammar :: Arbitrary a => [Grammar a] -> Int -> Gen (Grammar a) +arbGrammar xs n + | n == 0 = oneof $ + liftM symbol arbitrary : + map return ([succeed, fail] ++ xs) + | otherwise = oneof + [ arbGrammar xs 0 + , liftM2 (<*>) rec rec + , liftM2 (<|>) rec rec + , liftM2 (<||>) rec rec + , liftM many rec +-- , liftM fix (promote (\x -> arbGrammar (x:xs) (n `div` 2))) +{- , do i <- oneof $ map return [1::Int ..5] + x <- arbGrammar (Var i:xs) (n `div` 2) + return $ Rec i x -} + ] + where + rec = arbGrammar xs (n `div` 2) + +-------------------------------------------------------- +-- QuickCheck properties + +propSymbols :: (Int -> Int) -> Grammar Int -> Bool +propSymbols f p = map f (collectSymbols p) == collectSymbols (fmap f p) + +propIndexId :: Grammar Int -> Bool +propIndexId p = fmap snd (withIndex p) === p + +propIndexUnique :: Grammar Int -> Bool +propIndexUnique p = is == nub is + where is = map fst $ collectSymbols $ withIndex p + +propSound :: Grammar Int -> Property +propSound p = not (null xs) ==> all (`member` p) xs + where xs = take 20 $ language 10 p + +propEmpty :: Grammar Int -> Bool +propEmpty s = empty s == member [] s + +propNonEmpty :: Grammar Int -> Bool +propNonEmpty = not . member [] . nonempty + +propSplitSucceed :: Grammar Int -> Bool +propSplitSucceed p = p === if empty p then succeed <|> new else new + where new = nonempty p + +propFirsts :: Grammar Int -> Bool +propFirsts p = nonempty p === foldr op fail (firsts p) + where op (a, q) r = (symbol a <*> q) <|> r + +propJoin :: Grammar Int -> Bool +propJoin p = join (fmap symbol p) === p + +propMap :: (Int -> Int) -> (Int -> Int) -> Grammar Int -> Bool +propMap f g p = fmap (f . g) p === fmap (f . g) p + +propRec :: Grammar Int -> Property +propRec this@(Rec i p) = property (replaceVar i this p === this) +propRec _ = False ==> True + +propSucceed :: Grammar Int -> Bool +propSucceed p = empty p == member [] p + +infixl 1 === + +(===) :: Grammar Int -> Grammar Int -> Bool +p === q = all (`member` p) ys && all (`member` q) xs + where + xs = take 20 $ language 10 p + ys = take 20 $ language 10 q + +associative op p q r = p `op` (q `op` r) === (p `op` q) `op` r +commutative op p q = p `op` q === q `op` p +idempotent op p = p `op` p === p +leftUnit op e p = e `op` p === p +rightUnit op e p = p `op` e === p +unit op e p = leftUnit op e p && rightUnit op e p +absorbe op e p = (e `op` p === e) && (p `op` e === e) +propStar p = many p === succeed <|> (p <*> many p) +propStarStar p = many (many p) === many p + +checks :: IO () +checks = do + putStrLn "** Grammar combinators" + quickCheck propMap + quickCheck propJoin + quickCheck propSymbols + quickCheck propIndexId + quickCheck propIndexUnique + quickCheck propSound + quickCheck propEmpty + quickCheck propNonEmpty + quickCheck propSplitSucceed + quickCheck propFirsts + quickCheck propRec + quickCheck propStar + quickCheck propStarStar + quickCheck propSucceed + quickCheck $ associative (<|>) + quickCheck $ commutative (<|>) + quickCheck $ idempotent (<|>) + quickCheck $ unit (<|>) fail + quickCheck $ associative (<*>) + quickCheck $ unit (<*>) succeed + quickCheck $ absorbe (<*>) fail + quickCheck $ associative (<||>) + quickCheck $ commutative (<||>) + quickCheck $ unit (<||>) succeed + quickCheck $ absorbe (<||>) fail diff --git a/src/Common/Strategy/Location.hs b/src/Common/Strategy/Location.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Location.hs @@ -0,0 +1,120 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Locations in a strategy +-- +----------------------------------------------------------------------------- +module Common.Strategy.Location + ( StrategyLocation, topLocation, nextLocation, downLocation + , locationDepth + , subTaskLocation, nextTaskLocation, parseStrategyLocation + , StrategyOrRule, strategyLocations, subStrategy, addLocation + ) where + +import Common.Strategy.Abstract +import Common.Strategy.Core +import Common.Transformation +import Common.Uniplate +import Common.Utils (readM) +import Data.Foldable (toList) +import Data.Sequence hiding (take) +import Control.Monad.State + +----------------------------------------------------------- +--- Strategy locations + +-- | A strategy location corresponds to a substrategy or a rule +newtype StrategyLocation = SL (Seq Int) + deriving Eq + +instance Show StrategyLocation where + show (SL xs) = show (toList xs) + +type StrategyOrRule a = Either (LabeledStrategy a) (Rule a) + +topLocation :: StrategyLocation +topLocation = SL empty + +nextLocation :: StrategyLocation -> StrategyLocation +nextLocation (SL xs) = + case viewr xs of + EmptyR -> topLocation -- invalid + ys :> a -> SL (ys |> (a+1)) + +downLocation :: StrategyLocation -> StrategyLocation +downLocation (SL xs) = SL (xs |> 0) + +locationDepth :: StrategyLocation -> Int +locationDepth (SL xs) = Data.Sequence.length xs + +-- old (current) and actual (next major rule) location +subTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation +subTaskLocation (SL xs) (SL ys) = SL (rec xs ys) + where + rec xs ys = + case (viewl xs, viewl ys) of + (i :< is, j :< js) + | i == j -> i <| rec is js + | otherwise -> empty + (_, j :< _) -> singleton j + _ -> empty + +-- old (current) and actual (next major rule) location +nextTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation +nextTaskLocation (SL xs) (SL ys) = SL (rec xs ys) + where + rec xs ys = + case (viewl xs, viewl ys) of + (i :< is, j :< js) + | i == j -> i <| rec is js + | otherwise -> singleton j + _ -> empty + +parseStrategyLocation :: String -> Maybe StrategyLocation +parseStrategyLocation = fmap (SL . fromList) . readM + +-- | Returns a list of all strategy locations, paired with the labeled +-- substrategy or rule at that location + +strategyLocations :: LabeledStrategy a -> [(StrategyLocation, StrategyOrRule a)] +strategyLocations = collect . addLocation . toCore . toStrategy + where + collect core = + case core of + Label (loc, info) s -> + let this = makeLabeledStrategy info (mapLabel snd s) + in (loc, Left this) : collect s + Rule (Just (loc, _)) r -> + [(loc, Right r)] + _ -> + concatMap collect (children core) + +-- | Returns the substrategy or rule at a strategy location. Nothing +-- indicates that the location is invalid +subStrategy :: StrategyLocation -> LabeledStrategy a -> Maybe (StrategyOrRule a) +subStrategy loc = lookup loc . strategyLocations + +-- local helper functions that decorates interesting places with a +-- strategy lcations (major rules, and labels) +addLocation :: Core l a -> Core (StrategyLocation, l) a +addLocation = flip evalState topLocation . mapCoreM forLabel forRule + where + forLabel l ma = do + loc <- get + put (downLocation loc) + rest <- ma + put (nextLocation loc) + return (Label (loc, l) rest) + forRule (Just l) r = do + loc <- get + put (nextLocation loc) + return (Rule (Just (loc, l)) r) + forRule Nothing r = + return (Rule Nothing r) diff --git a/src/Common/Strategy/Prefix.hs b/src/Common/Strategy/Prefix.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Prefix.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A prefix encodes a sequence of steps already performed (a so-called trace), +-- and allows to continue the derivation at that particular point. +-- +----------------------------------------------------------------------------- +module Common.Strategy.Prefix + ( Prefix, emptyPrefix, makePrefix + , Step(..), prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix + ) where + +import Common.Apply +import Common.Utils +import Common.Strategy.Abstract +import Common.Strategy.Core +import Common.Transformation +import Common.Derivation +import Common.Strategy.Location +import Common.Strategy.BiasedChoice +import Data.Maybe + +----------------------------------------------------------- +--- Prefixes + +-- | Abstract data type for a (labeled) strategy with a prefix (a sequence of +-- executed rules). A prefix is still "aware" of the labels that appear in the +-- strategy. A prefix is encoded as a list of integers (and can be reconstructed +-- from such a list: see @makePrefix@). The list is stored in reversed order. +data Prefix a = P [(Int, Bias Step a)] (DerivationTree (Bias Step a) ()) + +instance Show (Prefix a) where + show (P xs _) = show (reverse (map fst xs)) + +instance Eq (Prefix a) where + P xs _ == P ys _ = map fst xs == map fst ys + +-- | Construct the empty prefix for a labeled strategy +emptyPrefix :: LabeledStrategy a -> Prefix a +emptyPrefix = fromMaybe (error "emptyPrefix") . makePrefix [] + +-- | Construct a prefix for a given list of integers and a labeled strategy. +makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a) +makePrefix is ls = rec [] is start + where + mkCore = placeBiasLabels . processLabelInfo snd + . addLocation . toCore . toStrategy + start = strategyTree biasT (mkCore ls) + + rec acc [] t = return (P acc t) + rec acc (n:ns) t = + case drop n (branches t) of + (step, st):_ -> rec ((n, step):acc) ns st + _ -> fail ("invalid prefix: " ++ show is) + + biasT :: Translation (Either (Bias Step a) (StrategyLocation, LabelInfo)) a (Bias Step a) + biasT = (forLabel, Normal . Step) + + forLabel (Left bias) = Before bias + forLabel (Right (loc, i)) = Around (Normal (Begin loc i)) (Normal (End loc i)) + +-- | The @Step@ data type can be used to inspect the structure of the strategy +data Step a = Begin StrategyLocation LabelInfo + | Step (Rule a) + | End StrategyLocation LabelInfo + deriving Show + +instance Apply Step where + applyAll (Step r) = applyAll r + applyAll (Begin _ _) = return + applyAll (End _ _) = return + +instance Apply Prefix where + applyAll p = results . prefixTree p + +-- | Create a derivation tree with a "prefix" as annotation. +prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a +prefixTree (P xs t) = changeLabel snd . biasTreeG suc . runTree (decorate xs t) + where + suc t = endpoint t || any p (annotations t) || any suc (subtrees t) + p (Step r, _) = isMajorRule r + p _ = False + +decorate :: [(Int, Bias Step a)] -> DerivationTree (Bias Step a) () -> DerivationTree (Bias Step a) (Prefix a) +decorate xs t = + let list = zipWith make [0..] (branches t) + make i (s, st) = (s, decorate ((i,s):xs) st) + in addBranches list (singleNode (P xs t) (endpoint t)) + +-- | Returns the steps that belong to the prefix +prefixToSteps :: Prefix a -> [Step a] +prefixToSteps (P xs _) = [ step | (_, Normal step) <- reverse xs ] + +-- | Retrieves the rules from a list of steps +stepsToRules :: [Step a] -> [Rule a] +stepsToRules steps = [ r | Step r <- steps ] + +-- | Returns the last rule of a prefix (if such a rule exists) +lastStepInPrefix :: Prefix a -> Maybe (Step a) +lastStepInPrefix (P xs _) = safeHead [ step | (_, Normal step) <- xs ] diff --git a/src/Common/Transformation.hs b/src/Common/Transformation.hs --- a/src/Common/Transformation.hs +++ b/src/Common/Transformation.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -18,23 +18,22 @@ module Common.Transformation ( -- * Transformations Transformation(RewriteRule), makeTrans, makeTransList - , inverseTrans, getPatternPair -- * Arguments , ArgDescr(..), defaultArgDescr, Argument(..) , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1 , hasArguments, expectedArguments, getDescriptors, useArguments -- * Rules , Rule, name, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule - , ruleGroups, addRuleToGroup + , ruleGroups, ruleDescription, ruleSiblings, addRuleToGroup, describe , rule, ruleList, ruleListF , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList - , idRule, emptyRule, minorRule, buggyRule, doBefore, doAfter - , transformations, getRewriteRules + , idRule, checkRule, emptyRule, minorRule, buggyRule, doBefore, doAfter + , transformations, getRewriteRules, doBeforeTrans -- * Lifting - , LiftPair, liftPairGet, liftPairSet, liftPairChange, makeLiftPair, Lift(..) , ruleOnce, ruleOnce2, ruleMulti, ruleMulti2, ruleSomewhere + , liftRule, liftTrans, liftRuleIn, liftTransIn -- * QuickCheck - , checkRule, checkRuleSmart + , testRule, testRuleSmart ) where import Common.Apply @@ -42,56 +41,39 @@ import Common.Traversable import Common.Uniplate (Uniplate, somewhereM) import Common.Utils +import Common.View import Control.Monad import Data.Char -import Data.List import Data.Maybe import Data.Ratio -import Test.QuickCheck hiding (arguments) - +import Test.QuickCheck ----------------------------------------------------------- --- Transformations -- | Abstract data type for representing transformations data Transformation a - = Function String (a -> [a]) + = Function (a -> [a]) | RewriteRule (RewriteRule a) + | Transformation a :*: Transformation a -- sequence | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a) - | forall b . Lift (LiftPair b a) (Transformation b) + | forall b c . LiftView (ViewList a (b, c)) (Transformation b) instance Apply Transformation where - applyAll (Function _ f) = f + applyAll (Function f) = f applyAll (RewriteRule r) = rewriteM r applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a) - applyAll (Lift lp t ) = \b -> maybe [] (map (\new -> liftPairSet lp new b) . applyAll t) (liftPairGet lp b) + applyAll (LiftView v t) = \a -> [ build v (b, c) | (b0, c) <- match v a, b <- applyAll t b0 ] + applyAll (s :*: t) = \a -> applyAll s a >>= applyAll t -- | Turn a function (which returns its result in the Maybe monad) into a transformation -makeTrans :: String -> (a -> Maybe a) -> Transformation a -makeTrans s f = makeTransList s (maybe [] return . f) +makeTrans :: (a -> Maybe a) -> Transformation a +makeTrans f = makeTransList (maybe [] return . f) -- | Turn a function (which returns a list of results) into a transformation -makeTransList :: String -> (a -> [a]) -> Transformation a +makeTransList :: (a -> [a]) -> Transformation a makeTransList = Function --- | Return the inverse of a transformation. Only transformation that are constructed with (|-) --- can be inversed -inverseTrans :: Transformation a -> Maybe (Transformation a) -inverseTrans trans = - case trans of - RewriteRule r -> fmap RewriteRule (inverse r) - Lift lp t -> fmap (Lift lp) (inverseTrans t) - _ -> Nothing - -getPatternPair :: a -> Transformation a -> Maybe (a, a) -getPatternPair _ (RewriteRule r) = let a :~> b = rulePair r 0 in Just (a, b) -getPatternPair a (Lift lp t) = do - let f t = liftPairSet lp t a - b <- liftPairGet lp a - (x, y) <- getPatternPair b t - return (f x, f y) -getPatternPair _ _ = Nothing - ----------------------------------------------------------- --- Arguments @@ -106,11 +88,7 @@ -- | Constructor function for an argument descriptor that uses the Show and Read type classes defaultArgDescr :: (Show a, Read a, Arbitrary a) => String -> ArgDescr a -defaultArgDescr descr = ArgDescr descr Nothing parse show arbitrary - where - parse s = case reads s of - [(a, xs)] | all isSpace xs -> return a - _ -> Nothing +defaultArgDescr descr = ArgDescr descr Nothing readM show arbitrary -- | A type class for types which have an argument descriptor class Arbitrary a => Argument a where @@ -182,28 +160,35 @@ getDescriptors :: Rule a -> [Some ArgDescr] getDescriptors rule = case transformations rule of - [Abstraction args _ _] -> someArguments args - [Lift _ t] -> getDescriptors $ rule - { transformations = [t] - , doBeforeHook = id - , doAfterHook = id - } - _ -> [] + [t] -> rec t + _ -> [] + where + rec :: Transformation a -> [Some ArgDescr] + rec trans = + case trans of + Abstraction args _ _ -> someArguments args + LiftView _ t -> rec t + s :*: t -> rec s ++ rec t + _ -> [] -- | Returns a list of pretty-printed expected arguments. Nothing indicates that there are no such arguments expectedArguments :: Rule a -> a -> Maybe [String] expectedArguments rule a = case transformations rule of - [Abstraction args f _] -> - fmap (showArguments args) (f a) - [Lift lp t] -> do - b <- liftPairGet lp a - expectedArguments rule - { transformations = [t] - , doBeforeHook = id - , doAfterHook = id - } b - _ -> Nothing + [t] -> rec t a + _ -> Nothing + where + rec :: Transformation a -> a -> Maybe [String] + rec trans a = + case trans of + Abstraction args f _ -> + fmap (showArguments args) (f a) + LiftView v t -> do + (b, _) <- safeHead (match v a) + rec t b + s :*: t -> + rec s a `mplus` rec t a + _ -> Nothing -- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are -- invalid (not parsable), or that the wrong number of arguments was supplied @@ -218,7 +203,9 @@ make trans = case trans of Abstraction args _ g -> fmap g (parseArguments args list) - Lift lp t -> fmap (Lift lp) (make t) + LiftView v t -> fmap (LiftView v) (make t) + s :*: t -> fmap (:*: t) (make s) `mplus` + fmap (s :*:) (make t) _ -> Nothing ----------------------------------------------------------- @@ -278,12 +265,12 @@ -- | Abstract data type for representing rules data Rule a = Rule { name :: String -- ^ Returns the name of the rule (should be unique) + , ruleDescription :: String -- ^ A short description what the rule is doing , transformations :: [Transformation a] , isBuggyRule :: Bool -- ^ Inspect whether or not the rule is buggy (unsound) , isMinorRule :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system) , ruleGroups :: [String] - , doBeforeHook :: a -> a -- ^ Hook to perform an action before the rule is fired - , doAfterHook :: a -> a -- ^ Hook to perform an action after the rule has been fired + , ruleSiblings :: [String] } instance Show (Rule a) where @@ -294,33 +281,29 @@ instance Apply Rule where applyAll r a = do - let b = doBeforeHook r a t <- transformations r - c <- applyAll t b - return (doAfterHook r c) + applyAll t a -- | Returns whether or not the rule is major (i.e., not minor) isMajorRule :: Rule a -> Bool isMajorRule = not . isMinorRule isRewriteRule :: Rule a -> Bool -isRewriteRule = all p . transformations - where - p :: Transformation a -> Bool - p (RewriteRule _) = True - p (Lift _ t) = p t - p _ = False +isRewriteRule = not . null . getRewriteRules +describe :: String -> Rule a -> Rule a +describe txt r = r { ruleDescription = txt ++ "\n" ++ ruleDescription r} + addRuleToGroup :: String -> Rule a -> Rule a addRuleToGroup group r = r { ruleGroups = group : ruleGroups r } -ruleList :: Builder f a => String -> [f] -> Rule a +ruleList :: (Builder f a, Rewrite a) => String -> [f] -> Rule a ruleList s = makeRuleList s . map (RewriteRule . rewriteRule s) -ruleListF :: BuilderList f a => String -> f -> Rule a +ruleListF :: (BuilderList f a, Rewrite a) => String -> f -> Rule a ruleListF s = makeRuleList s . map RewriteRule . rewriteRules s -rule :: Builder f a => String -> f -> Rule a +rule :: (Builder f a, Rewrite a) => String -> f -> Rule a rule s = makeRule s . RewriteRule . rewriteRule s -- | Turn a transformation into a rule: the first argument is the rule's name @@ -329,20 +312,26 @@ -- | Turn a list of transformations into a single rule: the first argument is the rule's name makeRuleList :: String -> [Transformation a] -> Rule a -makeRuleList n ts = Rule n ts False False [] id id +makeRuleList n ts = Rule n [] ts False False [] [] -- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name makeSimpleRule :: String -> (a -> Maybe a) -> Rule a -makeSimpleRule n = makeRule n . makeTrans n +makeSimpleRule n = makeRule n . makeTrans -- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name makeSimpleRuleList :: String -> (a -> [a]) -> Rule a -makeSimpleRuleList n = makeRule n . makeTransList n +makeSimpleRuleList n = makeRule n . makeTransList -- | A special (minor) rule that always returns the identity idRule :: Rule a idRule = minorRule $ makeSimpleRule "Identity" return +-- | A special (minor) rule that checks a predicate (and returns the identity +-- if the predicate holds) +checkRule :: (a -> Bool) -> Rule a +checkRule p = minorRule $ makeSimpleRule "Check" $ \a -> + if p a then Just a else Nothing + -- | A special (minor) rule that is never applicable (i.e., this rule always fails) emptyRule :: Rule a emptyRule = minorRule $ makeSimpleRule "Empty" (const Nothing) @@ -357,11 +346,16 @@ -- | Perform the function before the rule has been fired doBefore :: (a -> a) -> Rule a -> Rule a -doBefore f r = r { doBeforeHook = f } +doBefore f = doBeforeTrans (makeTrans (return . f)) +-- | Perform the function before the rule has been fired +doBeforeTrans :: Transformation a -> Rule a -> Rule a +doBeforeTrans t r = r {transformations = map (t :*:) (transformations r)} + -- | Perform the function after the rule has been fired doAfter :: (a -> a) -> Rule a -> Rule a -doAfter f r = r { doAfterHook = f } +doAfter f r = r {transformations = map make (transformations r)} + where make t = t :*: makeTransList (return . f) getRewriteRules :: Rule a -> [(Some RewriteRule, Bool)] getRewriteRules r = concatMap f (transformations r) @@ -370,49 +364,13 @@ f trans = case trans of RewriteRule rr -> [(Some rr, not $ isBuggyRule r)] - Lift _ t -> f t + LiftView _ t -> f t + s :*: t -> f s ++ f t _ -> [] ----------------------------------------------------------- --- Lifting --- | A lift pair consists of two functions: the first to access a value in a context (this can fail, --- hence the Maybe), the second to update the value in its context -data LiftPair a b = LiftPair - { liftPairGet :: b -> Maybe a -- ^ Returns the accessor function of a lift pair - , liftPairSet :: a -> b -> b -- ^ Returns the update function of a lift pair - } --- | Update a value in a context -liftPairChange :: LiftPair a b -> (a -> Maybe a) -> b -> Maybe b -liftPairChange lp f b = do - a <- liftPairGet lp b - new <- f a - return (liftPairSet lp new b) - --- | Constructor for a lift pair -makeLiftPair :: (b -> Maybe a) -> (a -> b -> b) -> LiftPair a b -makeLiftPair = LiftPair - --- | A type class for functors that can be lifted with a lift pair -class Lift f where - lift :: LiftPair a b -> f a -> f b - -instance Lift Transformation where - lift = Lift - -instance Lift Rule where - lift lp r = r - { transformations = map (lift lp) (transformations r) - , doBeforeHook = liftFunction lp (doBeforeHook r) - , doAfterHook = liftFunction lp (doAfterHook r) - } - -liftFunction :: LiftPair a b -> (a -> a) -> b -> b -liftFunction lp f a = - case liftPairGet lp a of - Just b -> liftPairSet lp (f b) a - Nothing -> a - -- | Lift a rule using the Once type class ruleOnce :: Once f => Rule a -> Rule (f a) ruleOnce r = makeSimpleRuleList (name r) $ onceM $ applyAll r @@ -441,20 +399,35 @@ ruleSomewhere :: Uniplate a => Rule a -> Rule a ruleSomewhere r = makeSimpleRuleList (name r) $ somewhereM $ applyAll r +liftTrans :: View a b -> Transformation b -> Transformation a +liftTrans v = liftTransIn (v &&& identity) + +liftTransIn :: Crush m => ViewM m a (b, c) -> Transformation b -> Transformation a +liftTransIn = LiftView . viewList + +liftRule :: View a b -> Rule b -> Rule a +liftRule v = liftRuleIn (v &&& identity) + +liftRuleIn :: Crush m => ViewM m a (b, c) -> Rule b -> Rule a +liftRuleIn v r = r + { transformations = map (liftTransIn v) (transformations r) + } + ----------------------------------------------------------- --- QuickCheck -- | Check the soundness of a rule: the equality function is passed explicitly -checkRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO () -checkRule eq rule = +testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO () +testRule eq rule = quickCheck (propRule eq rule arbitrary) -- | Check the soundness of a rule and use a "smart generator" for this. The smart generator -- behaves differently on transformations constructed with a (|-), and for these transformations, -- the left-hand side patterns are used (meta variables are instantiated with random terms) -checkRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> IO () -checkRuleSmart eq rule gen = - quickCheck (propRule eq rule (smartGen rule gen)) +testRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> IO () +testRuleSmart eq rule gen = + let cfg = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100} + in quickCheckWith cfg (propRule eq rule (smartGen rule gen)) propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property propRule eq rule gen = @@ -466,17 +439,19 @@ smartGen r gen = frequency [(2, gen), (1, smart)] where smart = gen >>= \a -> - oneof (gen : mapMaybe (smartGenTrans a) (transformations r)) + oneof (gen : concatMap (smartGenTrans a) (transformations r)) -smartGenTrans :: a -> Transformation a -> Maybe (Gen a) +smartGenTrans :: a -> Transformation a -> [Gen a] smartGenTrans a trans = case trans of RewriteRule r -> return (smartGenerator r) - Lift lp t -> do - b <- liftPairGet lp a - gen <- smartGenTrans b t - return $ liftM (\c -> liftPairSet lp c a) gen - _ -> Nothing + LiftView v t -> do + (b, c) <- match v a + gen <- smartGenTrans b t + return $ liftM (\n -> build v (n, c)) gen + s :*: t -> + smartGenTrans a s ++ smartGenTrans a t + _ -> [] smartApplyRule :: Rule a -> a -> Gen (Maybe a) smartApplyRule r a = do diff --git a/src/Common/Traversable.hs b/src/Common/Traversable.hs --- a/src/Common/Traversable.hs +++ b/src/Common/Traversable.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Common/Uniplate.hs b/src/Common/Uniplate.hs --- a/src/Common/Uniplate.hs +++ b/src/Common/Uniplate.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Common/Utils.hs b/src/Common/Utils.hs --- a/src/Common/Utils.hs +++ b/src/Common/Utils.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -24,20 +24,26 @@ data Some f = forall a . Some (f a) -thoroughCheck :: Testable a => a -> IO () -thoroughCheck = check $ defaultConfig {configMaxTest = 1000, configMaxFail = 5000} +data ShowString = ShowString { fromShowString :: String } + deriving (Eq, Ord) -generateStd :: Gen a -> IO a -generateStd gen = do - stdgen <- newStdGen - return (generate 100 stdgen gen) +instance Show ShowString where + show = fromShowString +thoroughCheck :: Testable a => a -> IO () +thoroughCheck = quickCheckWith $ stdArgs {maxSize = 500, maxSuccess = 500} + readInt :: String -> Maybe Int readInt xs | null xs = Nothing | any (not . isDigit) xs = Nothing | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' +readM :: (Monad m, Read a) => String -> m a +readM s = case reads s of + [(a, xs)] | all isSpace xs -> return a + _ -> fail ("no read: " ++ s) + stringToHex :: String -> Maybe Int stringToHex = foldl op (Just 0) where @@ -57,13 +63,6 @@ isSubsetOf :: Eq a => [a] -> [a] -> Bool isSubsetOf xs ys = all (`elem` ys) xs -eqListBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool -eqListBy f = rec - where - rec (x:xs) (y:ys) = f x y && rec xs ys - rec [] [] = True - rec _ _ = False - cartesian :: [a] -> [b] -> [(a, b)] cartesian as bs = [ (a, b) | a <- as, b <- bs ] @@ -78,6 +77,7 @@ fixpoint :: Eq a => (a -> a) -> a -> a fixpoint f = stop . iterate f where + stop [] = error "Common.Utils: empty list" stop (x:xs) | x == head xs = x | otherwise = stop xs @@ -99,70 +99,57 @@ Just (xs, ys) -> xs : splitsWithElem c ys Nothing -> [s] -{- safeIndex :: Int -> [a] -> Maybe a -safeIndex 0 (x:_) = return x -safeIndex n (_:xs) = safeIndex (n-1) xs -safeIndex _ _ = Nothing -} - -- | Use a fixed standard "random" number generator. This generator is -- accessible by calling System.Random.getStdGen useFixedStdGen :: IO () useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} -trim :: String -> String -trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse - -isNatural :: String -> Bool -isNatural x = all isDigit x && not (null x) - fst3 (x, _, _) = x snd3 (_, x, _) = x thd3 (_, _, x) = x -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c - -mapLeft :: (a -> b) -> Either a c -> Either b c -mapLeft f = either (Left . f) Right - -mapRight :: (b -> c) -> Either a b -> Either a c -mapRight f = either Left (Right . f) - commaList :: [String] -> String commaList = concat . intersperse ", " -indent :: Int -> String -> String -indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines - primes :: [Int] primes = rec [2..] where + rec [] = error "Common.Utils: empty list" rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) - + putLabel :: String -> IO () -putLabel = putStr . take 40 . (++ repeat ' ') +putLabel s = + let n = (40 - length s) `max` 3 + in putStr (s ++ replicate n ' ') reportTest :: String -> Bool -> IO () reportTest s b = putLabel s >> putStrLn (if b then "OK" else "FAILED") instance Show (a -> b) where show _ = "" - + +{- instance Arbitrary Char where arbitrary = let chars = ['a' .. 'z'] ++ ['A' .. 'Z'] in oneof (map return chars) +instance CoArbitrary Char where coarbitrary = coarbitrary . ord - +-} + instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (M.Map k a) where arbitrary = liftM M.fromList arbitrary +instance (Ord k, CoArbitrary k, CoArbitrary a) => CoArbitrary (M.Map k a) where coarbitrary = coarbitrary . M.toList - + +{- -- Generating arbitrary random rational numbers instance Integral a => Arbitrary (Ratio a) where arbitrary = sized (\n -> ratioGen n (n `div` 4)) +instance Integral a => CoArbitrary (Ratio a) where coarbitrary r = f (numerator r) . f (denominator r) - where f = variant . fromIntegral - + where f = variant . fromIntegral +-} + -- | Prevents a bias towards small numbers ratioGen :: Integral a => Int -> Int -> Gen (Ratio a) ratioGen n m = do diff --git a/src/Common/View.hs b/src/Common/View.hs --- a/src/Common/View.hs +++ b/src/Common/View.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,21 +12,30 @@ -- ----------------------------------------------------------------------------- module Common.View - ( Match, View, makeView, Simplification, makeSimplification - , match, matchM, build, canonical, canonicalM, canonicalWith - , simplify, simplifyWith, isCanonical, isCanonicalWith - , belongsTo, viewEquivalent, viewEquivalentWith - , (>>>), Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..), identity - , listView, conversion, ( #> ) + ( -- * Generalized monadic views + ViewM, match, build, makeView, biArr, identity, (>>>) + , canonical, canonicalWith + , Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..) + -- * Simple views + , View, ViewList, Match, belongsTo + , simplify, simplifyWith, viewEquivalent, viewEquivalentWith + , isCanonical, isCanonicalWith, matchM, canonicalM, viewList + -- * Some combinators + , listView, switchView, ( #> ), associativeView + -- * Properties on views , propIdempotence, propSoundness, propNormalForm ) where +import Common.Traversable import Control.Arrow hiding ((>>>)) import Control.Monad import Data.Maybe import Test.QuickCheck import qualified Control.Category as C +---------------------------------------------------------------------------------- +-- Generalized monadic view + -- For all v::View the following should hold: -- 1) simplify v a "is equivalent to" a -- 2) match (build b) equals Just b @@ -34,76 +43,38 @@ -- -- Derived property: simplification is idempotent -type Match a b = a -> Maybe b - -data View a b = View - { match :: Match a b +data ViewM m a b = ViewM + { match :: a -> m b , build :: b -> a } -type Simplification a = View a a - -matchM :: Monad m => View a b -> a -> m b -matchM v = maybe (Prelude.fail "no match") return . match v - -makeView :: (a -> Maybe b) -> (b -> a) -> View a b -makeView = View +makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b +makeView = ViewM -makeSimplification :: (a -> a) -> Simplification a -makeSimplification f = makeView (return . f) id +biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b +biArr f g = makeView (return . f) g -canonical :: View a b -> a -> Maybe a +canonical :: Monad m => ViewM m a b -> a -> m a canonical = canonicalWith id -canonicalM :: Monad m => View a b -> a -> m a -canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v - -canonicalWith :: (b -> b) -> View a b -> a -> Maybe a +canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a canonicalWith f view = liftM (build view . f) . match view -simplify :: View a b -> a -> a -simplify = simplifyWith id - -simplifyWith :: (b -> b) -> View a b -> a -> a -simplifyWith f view a = fromMaybe a (canonicalWith f view a) - --------------------------------------------------------------- - -belongsTo :: a -> View a b -> Bool -belongsTo a view = isJust (match view a) - -viewEquivalent :: Eq b => View a b -> a -> a -> Bool -viewEquivalent = viewEquivalentWith (==) - -viewEquivalentWith :: (b -> b -> Bool) -> View a b -> a -> a -> Bool -viewEquivalentWith eq view x y = - case (match view x, match view y) of - (Just a, Just b) -> a `eq` b - _ -> False - -isCanonical :: Eq a => View a b -> a -> Bool -isCanonical = isCanonicalWith (==) - -isCanonicalWith :: (a -> a -> Bool) -> View a b -> a -> Bool -isCanonicalWith eq v a = maybe False (eq a) (canonical v a) - ---------------------------------------------------------------- -- Arrow combinators -identity :: View a a -identity = makeView Just id +identity :: Monad m => ViewM m a a +identity = makeView return id -(>>>) :: View a b -> View b c -> View a c +(>>>) :: Monad m => ViewM m a b -> ViewM m b c -> ViewM m a c v >>> w = makeView (\a -> match v a >>= match w) (build v . build w) -instance C.Category View where +instance Monad m => C.Category (ViewM m) where id = identity v . w = w >>> v - -instance Arrow View where - arr f = makeView - (return . f) - (error "Control.View.arr: function is not invertible") + +instance Monad m => Arrow (ViewM m) where + arr f = biArr f (error "Control.View.arr: function is not invertible") first v = makeView (\(a, c) -> match v a >>= \b -> return (b, c)) @@ -122,7 +93,7 @@ (\a -> liftM2 (,) (match v a) (match w a)) (\(b, _) -> build v b) -instance ArrowChoice View where +instance Monad m => ArrowChoice (ViewM m) where left v = makeView (either (liftM Left . match v) (return . Right)) (either (Left . build v) Right) @@ -139,20 +110,70 @@ v ||| w = makeView (either (match v) (match w)) (Left . build v) + +--------------------------------------------------------------- +-- Simple views (based on a particular monad) + +type View = ViewM Maybe +type ViewList = ViewM [] +type Match a b = a -> Maybe b + +simplify :: View a b -> a -> a +simplify = simplifyWith id + +simplifyWith :: (b -> b) -> View a b -> a -> a +simplifyWith f view a = fromMaybe a (canonicalWith f view a) + +belongsTo :: a -> View a b -> Bool +belongsTo a view = isJust (match view a) + +viewEquivalent :: Eq b => View a b -> a -> a -> Bool +viewEquivalent = viewEquivalentWith (==) + +viewEquivalentWith :: (b -> b -> Bool) -> View a b -> a -> a -> Bool +viewEquivalentWith eq view x y = + case (match view x, match view y) of + (Just a, Just b) -> a `eq` b + _ -> False +isCanonical :: Eq a => View a b -> a -> Bool +isCanonical = isCanonicalWith (==) + +isCanonicalWith :: (a -> a -> Bool) -> View a b -> a -> Bool +isCanonicalWith eq v a = maybe False (eq a) (canonical v a) + +-- generalized match on a ViewM Maybe +matchM :: Monad m => View a b -> a -> m b +matchM v = maybe (Prelude.fail "no match") return . match v + +-- generalized canonical element on a ViewM Maybe +canonicalM :: Monad m => View a b -> a -> m a +canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v + +viewList :: Crush m => ViewM m a b -> ViewList a b +viewList v = makeView (crush . match v) (build v) + --------------------------------------------------------------- --- More combinators +-- Some combinators -listView :: View a b -> View [a] [b] +listView :: Monad m => ViewM m a b -> ViewM m [a] [b] listView v = makeView (mapM (match v)) (map (build v)) -conversion :: (a -> b) -> (b -> a) -> View a b -conversion f g = makeView (Just . f) g +switchView :: (Monad m, Switch f) => ViewM m a b -> ViewM m (f a) (f b) +switchView v = makeView (switch . fmap (match v)) (fmap (build v)) -( #> ) :: (a -> Bool) -> View a b -> View a b +( #> ) :: MonadPlus m => (a -> Bool) -> ViewM m a b -> ViewM m a b p #> v = makeView f (build v) where f a = guard (p a) >> match v a +associativeView :: View a (a,a) -> ViewList a (a,a) +associativeView v = makeView (reverse . f) (build v) + where f a = + case matchM v a of + Just (x, y) -> [(x, y)] ++ [(x1, build v (x2, y)) | (x1, x2) <- f x] + ++ [(build v (x, y1), y2) | (y1, y2) <- f y] + Nothing -> [] + --------------------------------------------------------------- -- Properties on views diff --git a/src/Documentation/DefaultPage.hs b/src/Documentation/DefaultPage.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/DefaultPage.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.DefaultPage where + +import Common.Context +import Common.Exercise +import Common.Transformation +import Control.Monad +import Service.DomainReasoner +import Service.ServiceList +import System.Directory +import System.FilePath +import Text.HTML +import qualified Text.XML as XML +import Data.Char + +generatePage :: String -> String -> HTMLBuilder -> DomainReasoner () +generatePage = generatePageAt 0 + +generatePageAt :: Int -> String -> String -> HTMLBuilder -> DomainReasoner () +generatePageAt n dir txt body = do + version <- getFullVersion + let filename = dir ++ "/" ++ txt + dirpart = takeDirectory filename + doc = defaultPage version (findTitle body) n body + liftIO $ do + putStrLn $ "Generating " ++ filename + unless (null dirpart) (createDirectoryIfMissing True dirpart) + writeFile filename (showHTML doc) + +defaultPage :: String -> String -> Int -> HTMLBuilder -> HTML +defaultPage version title level builder = + htmlPage title (Just (up level ++ "ideas.css")) $ do + header level + builder + footer version + +header :: Int -> HTMLBuilder +header level = center $ do + let f m = text "[" >> space >> m >> space >> text "]" + f $ link (up level ++ exerciseOverviewPageFile) $ text "Exercises" + replicateM_ 5 space + f $ link (up level ++ "services.html") $ text "Services" + replicateM_ 5 space + f $ link (up level ++ "tests.html") $ text "Tests" + replicateM_ 5 space + f $ link (up level ++ "coverage/hpc_index.html") $ text "Coverage" + replicateM_ 5 space + f $ link (up level ++ "api/index.html") $ text "API" + hr + +footer :: String -> HTMLBuilder +footer version = do + hr + italic $ text $ "Automatically generated from sources: " ++ version + +up :: Int -> String +up = concat . flip replicate "../" + +findTitle :: HTMLBuilder -> String +findTitle = maybe "" XML.getData . XML.findChild "h1" . XML.makeXML "page" + +------------------------------------------------------------ +-- Paths and files + +ruleImagePath :: Exercise a -> String +ruleImagePath ex = "exercises/" ++ f (domain (exerciseCode ex)) ++ "/" ++ f (description ex) ++ "/" + where f = filter isAlphaNum . map toLower + +exercisePagePath :: ExerciseCode -> String +exercisePagePath code = "exercises/" ++ domain code ++ "/" + +servicePagePath :: String +servicePagePath = "services/" + +ruleImageFile :: Exercise a -> Rule (Context a) -> String +ruleImageFile ex r = ruleImagePath ex ++ "rule" ++ name r ++ ".png" + +ruleImageFileHere :: Exercise a -> Rule (Context a) -> String +ruleImageFileHere ex r = + filter (not . isSpace) (identifier (exerciseCode ex)) + ++ "/rule" ++ filter isAlphaNum (name r) ++ ".png" + +exerciseOverviewPageFile :: String +exerciseOverviewPageFile = "exercises.html" + +exerciseOverviewAllPageFile :: String +exerciseOverviewAllPageFile = "exercises-all.html" + +serviceOverviewPageFile :: String +serviceOverviewPageFile = "services.html" + +exercisePageFile :: ExerciseCode -> String +exercisePageFile code = + exercisePagePath code + ++ filter (not . isSpace) (identifier code) + ++ ".html" + +exerciseStrategyFile :: ExerciseCode -> String +exerciseStrategyFile code = + exercisePagePath code + ++ filter (not . isSpace) (identifier code) + ++ "-strategy.html" + +exerciseRulesFile :: ExerciseCode -> String +exerciseRulesFile code = + exercisePagePath code + ++ filter (not . isSpace) (identifier code) + ++ "-rules.html" + +exerciseDerivationsFile :: ExerciseCode -> String +exerciseDerivationsFile code = + exercisePagePath code + ++ filter (not . isSpace) (identifier code) + ++ "-derivations.html" + +servicePageFile :: Service -> String +servicePageFile srv = servicePagePath ++ serviceName srv ++ ".html" + +------------------------------------------------------------ +-- Utility functions + +showBool :: Bool -> String +showBool b = if b then "yes" else "no" diff --git a/src/Documentation/ExercisePage.hs b/src/Documentation/ExercisePage.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/ExercisePage.hs @@ -0,0 +1,180 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.ExercisePage (makeExercisePage) where + +import Common.Exercise +import Common.Strategy hiding (not, replicate) +import Common.Transformation +import Service.ExercisePackage +import Service.StrategyInfo +import Service.DomainReasoner +import Service.TypedAbstractService hiding (exercise) +import Control.Monad +import Data.List +import Common.Utils (commaList, Some(..)) +import Data.Maybe +import System.Random +import qualified Data.Map as M +import Service.RulesInfo (rewriteRuleToFMP, collectExamples) +import Text.HTML +import Text.OpenMath.Object +import Text.OpenMath.FMP +import qualified Text.XML as XML +import Documentation.DefaultPage + +makeExercisePage :: String -> ExercisePackage a -> DomainReasoner () +makeExercisePage dir pkg = do + let ex = exercise pkg + make = generatePageAt 2 dir . ($ (exerciseCode ex)) + make exercisePageFile (exercisePage pkg) + make exerciseStrategyFile (strategyPage ex) + make exerciseRulesFile (rulesPage ex) + unless (null (examples (exercise pkg))) $ + make exerciseDerivationsFile (derivationsPage ex) + +exercisePage :: ExercisePackage a -> HTMLBuilder +exercisePage pkg = do + h1 (description ex) + + h2 "1. General information" + table + [ [bold $ text "Code", ttText (show $ exerciseCode ex)] + , [bold $ text "Status", text (show $ status ex)] + , [ bold $ text "OpenMath support" + , text $ showBool $ withOpenMath pkg + ] + , [ bold $ text "Textual feedback" + , text $ showBool $ isJust $ getExerciseText pkg + ] + , [ bold $ text "Restartable strategy" + , text $ showBool $ canBeRestarted ex + ] + , [ bold $ text "Exercise generator" + , text $ showBool $ isJust $ randomExercise ex + ] + , [ bold $ text "Examples" + , text $ show $ length $ examples ex + ] + ] + + para $ link (up 2 ++ exerciseStrategyFile code) $ + text "See strategy details" + + h2 "2. Rules" + let rs = rulesInStrategy (strategy ex) + f r = [ text (name r) + , text $ showBool $ isBuggyRule r + , text $ showBool $ hasArguments r + , text $ showBool $ r `elem` rs + , text $ concat $ intersperse "," (ruleGroups r) + , when (isRewriteRule r) $ + image (ruleImageFileHere ex r) + ] + table ( [bold $ text "Rule name", bold $ text "Buggy" + , bold $ text "Args" + , bold $ text "Used", bold $ text "Groups" + , bold $ text "Rewrite rule" + ] + : map f (ruleset ex) + ) + para $ link (up 2 ++ exerciseRulesFile code) $ + text "See rule details" + + + h2 "3. Example" + let state = generateWith (mkStdGen 0) ex 5 + preText (showDerivation ex (term state)) + unless (null (examples ex)) $ + link (up 2 ++ exerciseDerivationsFile code) (text "More examples") + where + ex = exercise pkg + code = exerciseCode ex + +strategyPage :: Exercise a -> HTMLBuilder +strategyPage ex = do + h1 title + h2 "1. Representation in XML" + preText (XML.showXML (strategyToXML (strategy ex))) + h2 "2. Locations" + let f (loc, e) = [text (show loc), indent (locationDepth loc) >> g e] + g (Left a) = text (strategyName a) + g (Right a) = text (name a ++ " (rule)") + indent n = text (replicate (3*n) '.') + table ( [bold $ text "Location", bold $ text "Label"] + : map f (strategyLocations (strategy ex)) + ) + where + code = exerciseCode ex + title = "Strategy for " ++ show code + +rulesPage :: Exercise a -> HTMLBuilder +rulesPage ex = do + h1 title + -- Groups + let groups = sort (nub (concatMap ruleGroups (ruleset ex))) + unless (null groups) $ do + ul $ flip map groups $ \g -> do + bold $ text $ g ++ ":" + space + let elems = filter ((g `elem`) . ruleGroups) (ruleset ex) + text $ commaList $ map name elems + + -- General info + forM_ (zip [1..] (ruleset ex)) $ \(i, r) -> do + h2 (show i ++ ". " ++ show r) + para $ text (ruleDescription r) + para $ table + [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)] + , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)] + , [bold $ text "Groups", text $ commaList $ ruleGroups r] + , [bold $ text "Siblings", text $ commaList $ ruleSiblings r] + ] + when (isRewriteRule r) $ para $ + image (ruleImageFileHere ex r) + -- Examples + let ys = M.findWithDefault [] (name r) exampleMap + unless (null ys) $ do + h3 "Examples" + forM_ (take 3 ys) $ \(a, b) -> para $ tt $ + preText $ prettyPrinter ex a ++ "\n =>\n" ++ prettyPrinter ex b + + -- FMPS + let xs = getRewriteRules r + unless (null xs) $ do + h3 "Formal Mathematical Properties" + forM_ xs $ \(Some rr, b) -> para $ do + let fmp = rewriteRuleToFMP b rr + ttText $ show $ XML.makeXML "FMP" $ + XML.builder (omobj2xml (toObject fmp)) + where + code = exerciseCode ex + title = "Strategy for " ++ show code + exampleMap = collectExamples ex + +derivationsPage :: Exercise a -> HTMLBuilder +derivationsPage ex = do + unless (errs==0) $ + errorLine $ preText $ "Warning: " ++ show errs ++ " example(s) with an incorrect derivation" + h1 "Examples" + forM_ (zip [1 ..] ds) $ \(i, d) -> do + h2 (show i ++ ".") + preText d + where + ds = map (showDerivation ex) (examples ex) + errs = let p s = "<>" `isSuffixOf` s + || "<>" `isSuffixOf` s + in length $ filter p ds + +errorLine :: HTMLBuilder -> HTMLBuilder +errorLine b = XML.element "font" $ do + "color" XML..=. "red" + bold b diff --git a/src/Documentation/LatexRules.hs b/src/Documentation/LatexRules.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/LatexRules.hs @@ -0,0 +1,140 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.LatexRules (makeLatexRules) where + +import Common.Exercise +import Common.Rewriting +import Common.Transformation +import Common.Utils +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import System.Directory +import System.Time + +makeLatexRules :: String -> Exercise a -> IO () +makeLatexRules dir ex = do + let code = exerciseCode ex + path = dir ++ "/" ++ domain code ++ "/" ++ filter (/= ' ') (identifier code) + -- Exercise document + let rules = concatMap getRewriteRules (ruleset ex) + unless (null rules) $ do + createDirectoryIfMissing True path + doc <- makeDocument ex + let filename = path ++ "/overview.lhs" + putStrLn $ "Creating " ++ filename + writeFile filename doc + -- individual rules + forM_ (ruleset ex) $ \r -> + case makeSingleRule (domain code ++ "/" ++ domain code ++ ".fmt") r of + Nothing -> return () + Just txt -> do + let filename = path ++ "/rule" ++ filter isAlphaNum (name r) ++ ".lhs" + putStrLn $ "Creating " ++ filename + writeFile filename txt + +{- +exerciseRulesToTeX :: Exercise a -> String +exerciseRulesToTeX ex = unlines . map ruleToTeX . concatMap getRewriteRules . ruleset $ ex +-} + +ruleToTeX :: (Some RewriteRule, Bool) -> Maybe String +ruleToTeX (Some r, sound) = do + txt <- showRewriteRule sound r + return $ "RewriteRule " ++ withoutDigits (ruleName r) + ++ " (" ++ txt ++ ")" + + +------------------------------------------------------ + +makeSingleRule :: String -> Rule a -> Maybe String +makeSingleRule dom r + | null (getRewriteRules r) = Nothing + | otherwise = Just $ texHeader (Just dom) ++ texBody Nothing content + where + content = unlines $ + [ "\\pagestyle{empty}" + , formatRuleName (name r) + , "\\begin{code}" + ] ++ + map (filter (/= '"') . fromMaybe "" . ruleToTeX) (getRewriteRules r) ++ + [ "\\end{code}" + ] + + +makeDocument :: Exercise a -> IO String +makeDocument ex = do + let code = exerciseCode ex + time <- getClockTime + return $ + texHeader (Just $ domain code ++ "/" ++ domain code ++ ".fmt") ++ + texBody (Just $ show time) (texSectionRules ex) + +------------------------------------------------------ + +texHeader :: Maybe String -> String +texHeader fmt = unlines + [ "\\documentclass{article}" + , "" + , "%include lhs2TeX.fmt" + , "%format RewriteRule (a) (b) = \"\\rewriterule{\"a\"}{\"b\"}\"" + , "%format ~> = \"\\:\\leadsto\\:\"" + , "%format /~> = \"\\:\\not\\leadsto\\:\"" + , maybe "" ("%include "++) fmt + , "" + , "\\newcommand{\\rewriterule}[2]{#1:\\quad #2}" + , "\\newcommand{\\rulename}[1]{\\mbox{\\sc #1}}" + ] + +texBody :: Maybe String -> String -> String +texBody date content = unlines + [ "\\begin{document}" + , content + , maybe "" (\s -> "\\par\\vspace*{5mm}\\noindent\\footnotesize{@(generated on " ++ s ++ ")@}") date + , "\\end{document}" + ] + +texSectionRules :: Exercise a -> String +texSectionRules ex = unlines + [ "\\section{Rewrite rules}" + , formats + , makeGroup Nothing + , unlines $ map (makeGroup . Just) groups + ] + where + rules = concatMap getRewriteRules (ruleset ex) + groups = nub (concatMap ruleGroups (ruleset ex)) + names = let f (Some r, _) = ruleName r + in nub (map f rules) + formats = unlines (map formatRuleName names) + + makeGroup :: Maybe String -> String + makeGroup mgroup = unlines + [ maybe "" (\s -> "\\subsection{" ++ s ++ "}") mgroup + , "\\begin{code}" + , unlines $ map (filter (/= '"')) xs + , "\\end{code}" + ] + where + p x = maybe (null $ ruleGroups x) (`elem` ruleGroups x) mgroup + xs = mapMaybe ruleToTeX $ concatMap getRewriteRules $ filter p $ ruleset ex + +formatRuleName :: String -> String +formatRuleName s = "%format " ++ withoutDigits s ++ " = \"\\rulename{" ++ s ++ "}\"" + +withoutDigits :: String -> String +withoutDigits = concatMap f + where + f c | isAlpha c = [c] + | isDigit c = "QX" ++ [chr (ord c + 49)] + | otherwise = [] diff --git a/src/Documentation/Make.hs b/src/Documentation/Make.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/Make.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.Make (DocItem(..), makeDocumentation) where + +import Common.Utils (Some(..)) +import Service.DomainReasoner +import Documentation.SelfCheck +import Documentation.LatexRules +import Documentation.ExercisePage +import Documentation.ServicePage +import Documentation.OverviewPages + +data DocItem = Pages String | LatexRules String | SelfCheck String + deriving Eq + +makeDocumentation :: DocItem -> DomainReasoner () +makeDocumentation doc = + case doc of + Pages dir -> do + makeOverviewExercises dir + makeOverviewServices dir + getPackages >>= mapM_ (\(Some pkg) -> makeExercisePage dir pkg) + getServices >>= mapM_ (\s -> makeServicePage dir s) + SelfCheck dir -> + performSelfCheck dir + LatexRules dir -> + let f (Some ex) = makeLatexRules dir ex + in getExercises >>= liftIO . mapM_ f diff --git a/src/Documentation/OverviewPages.hs b/src/Documentation/OverviewPages.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/OverviewPages.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.OverviewPages + ( makeOverviewExercises, makeOverviewServices + ) where + +import Documentation.DefaultPage +import Data.Char +import Data.List +import Control.Monad +import Common.Utils (Some(..)) +import Common.Exercise +import Service.ServiceList +import Service.DomainReasoner +import Text.HTML + +makeOverviewExercises :: String -> DomainReasoner () +makeOverviewExercises dir = do + list <- getExercises + generatePage dir exerciseOverviewPageFile $ + exerciseOverviewPage False list + generatePage dir exerciseOverviewAllPageFile $ + exerciseOverviewPage True list + +makeOverviewServices :: String -> DomainReasoner () +makeOverviewServices dir = do + list <- getServices + generatePage dir serviceOverviewPageFile (serviceOverviewPage list) + +exerciseOverviewPage :: Bool -> [Some Exercise] -> HTMLBuilder +exerciseOverviewPage showAll list = do + h1 title + + unless showAll $ para $ do + text "Show" + space + link exerciseOverviewAllPageFile $ + text "all exercises" + text ", including the ones under development" + + forM_ (zip [1..] groupedList) $ \(i, (dom, xs)) -> do + h2 (show i ++ ". " ++ dom) + noBorderTable (map makeRow xs) + where + title | showAll = "All exercises" + | otherwise = "Exercises" + + makeRow (Some ex) = + [ do tt bullet >> space + link (exercisePageFile code) $ ttText (show code) + , do spaces 10 + f (status ex) + spaces 10 + , text $ description ex + ] + where + code = exerciseCode ex + f st = italic $ text ("(" ++ map toLower (show st) ++ ")") + + groupedList = process list + where + process = map g . groupBy eq . sortBy cmp . filter p + + cmp (Some a) (Some b) = exerciseCode a `compare` exerciseCode b + eq a b = f a == f b + f (Some ex) = domain (exerciseCode ex) + g xs = (f (head xs), xs) + p (Some ex) = showAll || isPublic ex + +serviceOverviewPage :: [Service] -> HTMLBuilder +serviceOverviewPage list = do + h1 "Services" + let sorted = sortBy (\x y -> serviceName x `compare` serviceName y) list + ul $ flip map sorted $ \s -> do + link (servicePageFile s) (ttText (serviceName s)) + when (serviceDeprecated s) $ + space >> text "(deprecated)" diff --git a/src/Documentation/SelfCheck.hs b/src/Documentation/SelfCheck.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/SelfCheck.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.SelfCheck (performSelfCheck) where + +import Control.Monad.Trans +import System.Directory +import Common.Utils (reportTest, useFixedStdGen, Some(..), snd3) +import Common.Exercise +import Service.ExercisePackage +import qualified Common.Strategy.Grammar as Grammar +import Control.Monad +import Service.Request +import Service.DomainReasoner + +import qualified Domain.LinearAlgebra.Checks as LA +import Service.ModeJSON +import Service.ModeXML + +import qualified Domain.Math.Numeric.Tests as MathNum +import qualified Domain.Math.Polynomial.Tests as MathPoly +import qualified Domain.Math.SquareRoot.Tests as MathSqrt +import qualified Domain.Math.Data.Interval as MathInterval + +import qualified Text.UTF8 as UTF8 +import qualified Text.JSON as JSON +import Data.List +import System.Time + +performSelfCheck :: String -> DomainReasoner () +performSelfCheck dir = totalDiff $ do + timeDiff $ liftIO $ do + putStrLn "* 1. Domain checks" + Grammar.checks + MathNum.main + MathPoly.tests + MathSqrt.tests + MathInterval.testMe + LA.checks + UTF8.testEncoding + JSON.testMe + + liftIO $ putStrLn "* 2. Exercise checks" + pkgs <- getPackages + forM_ pkgs $ \(Some pkg) -> + timeDiff $ liftIO $ checkExercise (exercise pkg) + + timeDiff $ do + liftIO $ putStrLn "* 3. Unit tests" + n <- unitTests dir + liftIO $ putStrLn $ "** Number of unit tests: " ++ show n + +-- Returns the number of tests performed +unitTests :: String -> DomainReasoner Int +unitTests = visit 0 + where + visit i path = do + valid <- liftIO $ doesDirectoryExist path + if not valid then return 0 else do + -- analyse content + xs <- liftIO $ getDirectoryContents path + let xml = filter (".xml" `isSuffixOf`) xs + json = filter (".json" `isSuffixOf`) xs + liftIO $ putStrLn $ replicate (i+1) '*' ++ " " ++ simplerDirectory path + -- perform tests + forM json $ \x -> + performUnitTest JSON (path ++ "/" ++ x) + forM xml $ \x -> + performUnitTest XML (path ++ "/" ++ x) + -- recursively visit subdirectories + is <- forM (filter ((/= ".") . take 1) xs) $ \x -> + visit (i+1) (path ++ "/" ++ x) + return (length (xml ++ json) + sum is) + +performUnitTest :: DataFormat -> FilePath -> DomainReasoner () +performUnitTest format path = do + liftIO useFixedStdGen -- fix the random number generator + txt <- liftIO $ readFile path + exp <- liftIO $ readFile expPath + out <- case format of + JSON -> liftM snd3 (processJSON txt) + XML -> liftM snd3 (processXML txt) + `catchError` \_ -> return "Error" + liftIO $ reportTest (stripDirectoryPart path) (out ~= exp) + where + expPath = baseOf path ++ ".exp" + baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse + x ~= y = filterVersion x == filterVersion y + + filterVersion = + let p s = not (null s || "version" `isInfixOf` s) + in unlines . filter p . lines + +simplerDirectory :: String -> String +simplerDirectory s + | "../" `isPrefixOf` s = simplerDirectory (drop 3 s) + | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s) + | otherwise = s + +stripDirectoryPart :: String -> String +stripDirectoryPart = reverse . takeWhile (/= '/') . reverse + +{- +logicConfluence :: IO () +logicConfluence = reportTest "logic rules" (isConfluent f rs) + where + f = normalizeWith ops . normalFormWith ops rs + ops = map makeCommutative Logic.logicOperators + rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd] + rs = [ r | RewriteRule r <- concatMap transformations rwrs ] + -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] +-} + +-- Helper functions +showDiffWith :: MonadIO m => (TimeDiff -> IO ()) -> m a -> m a +showDiffWith f action = do + t0 <- liftIO getClockTime + a <- action + t1 <- liftIO getClockTime + liftIO (f (diffClockTimes t1 t0)) + return a + +totalDiff :: MonadIO m => m a -> m a +totalDiff = showDiffWith (putStrLn . ("*** Total time: "++) . formatDiff) + +timeDiff :: MonadIO m => m a -> m a +timeDiff = showDiffWith (putStrLn . ("+++ Time: "++) . formatDiff) + +formatDiff :: TimeDiff -> String +formatDiff d@(TimeDiff z1 z2 z3 h m s p) + | any (/=0) [z1,z2,z3] = timeDiffToString d + | s >= 60 = formatDiff (timeDiff ((h*60+m)*60+s) p) + | h==0 && m==0 = show inSec ++ " secs" + | otherwise = show (60*h+m) ++ ":" ++ digSec ++ " mins" + where + milSec = 1000*toInteger s + p `div` 1000000000 + inSec = fromIntegral milSec / 1000 + digSec = (if s < 10 then ('0' :) else id) (show s) + timeDiff n p = + let (rest, s) = n `divMod` 60 + (h, m) = rest `divMod` 60 + in TimeDiff 0 0 0 h m s p diff --git a/src/Documentation/ServicePage.hs b/src/Documentation/ServicePage.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/ServicePage.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.ServicePage (makeServicePage) where + +import Documentation.DefaultPage +import Service.ExercisePackage +import Service.ServiceList +import Service.TypedExample +import Service.Types +import Service.DomainReasoner +import Service.TypedAbstractService (emptyState) +import Text.HTML +import qualified Text.XML as XML +import Text.XML (XML, showXML) +import Domain.Logic +import Domain.Math.Polynomial.Exercises +import Domain.Math.Data.Relation +import Domain.Math.Expr.Symbolic +import Control.Monad +import Common.Utils (ShowString(..)) + +makeServicePage :: String -> Service -> DomainReasoner () +makeServicePage dir s = do + xs <- examplesFor (serviceName s) + generatePageAt 1 dir (servicePageFile s) (servicePage xs s) + +servicePage :: [Example] -> Service -> HTMLBuilder +servicePage examples s = do + h1 (serviceName s) + + para $ do + bold $ text "Signature:" + space + case serviceFunction s of + _ ::: t -> ttText (show t) + para $ do + bold $ text "Description: " + br + text $ serviceDescription s + + when (serviceDeprecated s) $ + para $ bold $ text "Warning: this service is deprecated!" + + unless (null examples) $ do + h2 $ "XML examples (" ++ show (length examples) ++ ")" + forM_ (zip [1..] examples) $ + \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do + h2 $ show i ++ ". " ++ msg + bold $ text "Request:" + preText $ showXML xmlRequest + bold $ text "Reply:" + preText $ showXML xmlReply + unless xmlTest $ + XML.element "font" $ do + "color" XML..=. "red" + bold $ text "Error: invalid request/reply pair" + +----------------------------------------------------------------------- +-- Examples + +type Example = (String, (XML, XML, Bool)) + +examplesFor :: String -> DomainReasoner [Example] +examplesFor s = sequence [ m | (t, m) <- list, s == t ] + where + list = + [ logic "derivation" [Nothing ::: Maybe StrategyCfg, stLogic1] + , lineq "derivation" [Nothing ::: Maybe StrategyCfg, stLineq1] + , logic "allfirsts" [stLogic2] + , lineq "allfirsts" [stLineq2] + , logic "onefirst" [stLogic2] + , lineq "onefirst" [stLineq2] +-- , logic "applicable" [[] ::: Location, stLogic1] + , lineq "rulesinfo" [] + , lineq "rulelist" [linearExercise ::: Exercise] + , lineq "strategyinfo" [linearExercise ::: Exercise] + ] + strVar = Var . ShowString + stLogic1 = emptyState dnfExercise (Not (strVar "p" :&&: Not (strVar "q"))) ::: State + stLogic2 = emptyState dnfExercise (Not (Not (strVar "p")) :&&: Not T) ::: State + stLineq1 = emptyState linearExercise (5*(variable "x"+1) :==: 11) ::: State + stLineq2 = emptyState linearExercise (5*(variable "x"+1) :==: (variable "x"-1)/2) ::: State + + logic = make "Logic" (package dnfExercise) + lineq = make "Linear equation" (termPackage linearExercise) + + make msg pkg fs args = (fs, do + srv <- findService fs + tr <- typedExample pkg srv args + return (msg, tr)) diff --git a/src/Documentation/TestsPage.hs b/src/Documentation/TestsPage.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/TestsPage.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.TestsPage (main) where + +import Control.Monad +import Data.Char +import Data.List +import Documentation.DefaultPage +import Service.DomainReasoner +import System.Environment +import Main.Revision +import Text.HTML +import qualified Text.XML as XML + +main :: IO () +main = do + args <- getArgs + case args of + [fileIn, fileOut] -> do + input <- readFile fileIn + runDomainReasoner $ do + setFullVersion fullVersion + generatePage "docs" (up 1 ++ fileOut) (testsPage input) + _ -> fail "Invalid invocation" + +fullVersion :: String +fullVersion = "version " ++ version ++ " (revision " ++ show revision ++ ", " ++ lastChanged ++ ")" + +testsPage :: String -> HTMLBuilder +testsPage input = do + h1 "Tests" + let (hs, bs) = unzip (map format (lines input)) + bold (text "Failures: ") + text $ show $ length $ filter not bs + brs hs + where + format :: String -> (HTMLBuilder, Bool) + format s + | any (`elem` ws) ["failed", "error", "error:", "falsifiable"] = + (errorLine (ttText s), False) + | "* " `isPrefixOf` s = + (h2 (drop 2 s), True) + | "** " `isPrefixOf` s = + (br >> bold (text (drop 3 s)), True) + | "*** " `isPrefixOf` s = + (br >> bold (text (drop 4 s)), True) + | otherwise = + (fromString s, True) + where + ws = map (map toLower . filter isAlpha) (words s) + + +brs :: [HTMLBuilder] -> HTMLBuilder +brs = mapM_ (>> br) + +fromString :: String -> HTMLBuilder +fromString = f [] + where + f acc [] = ttText (reverse acc) + f acc list@(x:xs) + | "+++" `isPrefixOf` list = do + f acc [] + unless (null acc) (spaces 3) + okLine (ttText (drop 3 list)) + | "*** Gave up!" `isPrefixOf` list = do + f acc [] + unless (null acc) (spaces 3) + ttText (drop 3 list) + | otherwise = f (x:acc) xs + +errorLine :: HTMLBuilder -> HTMLBuilder +errorLine b = XML.element "font" $ do + "color" XML..=. "red" + bold b + +okLine :: HTMLBuilder -> HTMLBuilder +okLine b = XML.element "font" $ do + "color" XML..=. "gray" + b diff --git a/src/Domain/LinearAlgebra.hs b/src/Domain/LinearAlgebra.hs --- a/src/Domain/LinearAlgebra.hs +++ b/src/Domain/LinearAlgebra.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -17,14 +17,12 @@ , module Domain.LinearAlgebra.Strategies , module Domain.LinearAlgebra.LinearSystem , module Domain.LinearAlgebra.Exercises - , module Domain.LinearAlgebra.Symbols ) where import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.Parser import Domain.LinearAlgebra.MatrixRules -import Domain.LinearAlgebra.EquationsRules hiding (changeCover) +import Domain.LinearAlgebra.EquationsRules hiding (changeCover, findIndexM) import Domain.LinearAlgebra.Strategies import Domain.LinearAlgebra.LinearSystem -import Domain.LinearAlgebra.Exercises -import Domain.LinearAlgebra.Symbols +import Domain.LinearAlgebra.Exercises diff --git a/src/Domain/LinearAlgebra/Checks.hs b/src/Domain/LinearAlgebra/Checks.hs --- a/src/Domain/LinearAlgebra/Checks.hs +++ b/src/Domain/LinearAlgebra/Checks.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,14 +11,14 @@ ----------------------------------------------------------------------------- module Domain.LinearAlgebra.Checks (checks) where -import Domain.Math.Simplification (simplify) -import Domain.LinearAlgebra hiding (getSolution) -import Test.QuickCheck -import Control.Monad -import Common.Utils -import Data.List import Common.Apply import Common.Context +import Common.Exercise +import Common.Utils +import Domain.LinearAlgebra hiding (getSolution) +import Domain.Math.Expr +import Domain.Math.Simplification (simplify) +import Test.QuickCheck ----------------------------------------------------------- --- QuickCheck properties @@ -33,28 +33,34 @@ propEchelon :: Matrix Rational -> Bool propEchelon = - inRowEchelonForm . matrix . applyD forwardPass . inContext . fmap fromRational + withoutContext inRowEchelonForm . applyD forwardPass . gaussContext propReducedEchelon :: Matrix Rational -> Bool propReducedEchelon = - inRowReducedEchelonForm . matrix . applyD gaussianElimStrategy . inContext . fmap fromRational + withoutContext inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext propSound :: Matrix Rational -> Bool propSound m = - (matrix . applyD gaussianElimStrategy . inContext . fmap fromRational) m - == fmap fromRational (reduce m) + (fromContext . applyD gaussianElimStrategy . gaussContext) m + == Just (fmap fromRational (reduce m)) propSolution :: Matrix Rational -> Property propSolution m1 = forAll (arbSolution m1) $ \(solution, m2) -> - let m3 = (matrix . applyD gaussianElimStrategy . inContext . fmap fromRational) m2 + let m3 = (fromContext . applyD gaussianElimStrategy . gaussContext) m2 p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0 g = (*) . fromRational - in all p (rows m3) + in maybe False (all p . rows) m3 arbSolution :: (Arbitrary a, Num a) => Matrix a -> Gen ([a], Matrix a) arbSolution m = do solution <- vector (snd $ dimensions m) let finalCol = map (return . sum . zipWith (*) solution) (rows m) newMatrix = makeMatrix $ zipWith (++) (rows m) finalCol - return (solution, newMatrix) + return (solution, newMatrix) + +withoutContext :: (a -> Bool) -> Context a -> Bool +withoutContext f = maybe False f . fromContext + +gaussContext :: Matrix Rational -> Context (Matrix Expr) +gaussContext = inContext gaussianElimExercise . fmap fromRational diff --git a/src/Domain/LinearAlgebra/EquationsRules.hs b/src/Domain/LinearAlgebra/EquationsRules.hs --- a/src/Domain/LinearAlgebra/EquationsRules.hs +++ b/src/Domain/LinearAlgebra/EquationsRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,12 +15,13 @@ import Common.Context import Common.Transformation import Common.Utils +import Common.Navigator import Common.View hiding (simplify) import Control.Monad import Data.List hiding (repeat) import Data.Maybe import Domain.Math.Expr -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Simplification (simplify) import Domain.LinearAlgebra.LinearView import Domain.LinearAlgebra.LinearSystem @@ -37,70 +38,79 @@ ruleExchangeEquations :: Rule (Context (LinearSystem Expr)) ruleExchangeEquations = simplifySystem $ makeRule "Exchange" $ - supplyLabeled2 descr args (\x y -> liftSystemTrans $ exchange x y) + supplyLabeled2 descr args (\x y -> liftTransContext $ exchange x y) where - descr = ("equation 1", "equation 2") - args c = do mv <- minvar c - i <- findIndex (elem mv . getVarsSystem . return) (remaining c) - return (get covered c, get covered c + i) + descr = ("equation 1", "equation 2") + args = evalCM $ \ls -> do + mv <- minvar ls + eqs <- remaining ls + i <- findIndexM (elem mv . getVarsSystem . return) eqs + cov <- readVar covered + return (cov, cov + i) ruleEliminateVar :: Rule (Context (LinearSystem Expr)) ruleEliminateVar = simplifySystem $ makeRule "Eliminate variable" $ - supplyLabeled3 descr args (\x y z -> liftSystemTrans $ addEquations x y z) + supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z) where - descr = ("equation 1", "equation 2", "scale factor") - args c = do - mv <- minvar c - let hd:rest = remaining c - getCoef = coefficientOf mv . getLHS - (i, coef) <- safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ] + descr = ("equation 1", "equation 2", "scale factor") + args = evalCM $ \ls -> do + mv <- minvar ls + hd:rest <- remaining ls + let getCoef = coefficientOf mv . leftHandSide + (i, coef) <- maybeCM $ safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ] guard (getCoef hd /= 0) let v = negate coef / getCoef hd - return ( i + get covered c + 1, get covered c, v) + cov <- readVar covered + return (i + cov + 1, cov, v) ruleDropEquation :: Rule (Context (LinearSystem Expr)) -ruleDropEquation = simplifySystem $ makeSimpleRule "Drop (0=0) equation" $ - \c -> do i <- findIndex (fromMaybe False . testConstants (==)) (equations c) - return $ change covered (\n -> if i < n then n-1 else n) - $ fmap (deleteIndex i) c +ruleDropEquation = simplifySystem $ makeSimpleRule "Drop (0=0) equation" $ withCM $ \ls -> do + i <- findIndexM (fromMaybe False . testConstants (==)) ls + modifyVar covered (\n -> if i < n then n-1 else n) + return (deleteIndex i ls) ruleInconsistentSystem :: Rule (Context (LinearSystem Expr)) -ruleInconsistentSystem = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ - \c -> do let stop = [0 :==: 1] - guard $ invalidSystem (equations c) && equations c /= stop - return $ set covered 1 (fmap (const stop) c) +ruleInconsistentSystem = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ withCM $ \ls -> do + let stop = [0 :==: 1] + guard (invalidSystem ls && ls /= stop) + writeVar covered 1 + return stop ruleScaleEquation :: Rule (Context (LinearSystem Expr)) ruleScaleEquation = simplifySystem $ makeRule "Scale equation to one" $ - supplyLabeled2 descr args (\x y -> liftSystemTrans $ scaleEquation x y) + supplyLabeled2 descr args (\x y -> liftTransContext $ scaleEquation x y) where - descr = ("equation", "scale factor") - args c = do eq <- safeHead $ drop (get covered c) (equations c) - let expr = getLHS eq - mv <- minvar c - guard (coefficientOf mv expr /= 0) - let coef = 1 / coefficientOf mv expr - return (get covered c, coef) + descr = ("equation", "scale factor") + args = evalCM $ \ls -> do + cov <- readVar covered + eq <- maybeCM $ safeHead $ drop cov ls + let expr = leftHandSide eq + mv <- minvar ls + guard (coefficientOf mv expr /= 0) + let coef = 1 / coefficientOf mv expr + return (cov, coef) ruleBackSubstitution :: Rule (Context (LinearSystem Expr)) ruleBackSubstitution = simplifySystem $ makeRule "Back substitution" $ - supplyLabeled3 descr args (\x y z -> liftSystemTrans $ addEquations x y z) + supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z) where - descr = ("equation 1", "equation 2", "scale factor") - args c = do eq <- safeHead $ drop (get covered c) (equations c) - let expr = getLHS eq - mv <- safeHead (getVars expr) - i <- findIndex ((/= 0) . coefficientOf mv . getLHS) (take (get covered c) (equations c)) - let coef = negate $ coefficientOf mv (getLHS (equations c !! i)) - return (i, get covered c, coef) + descr = ("equation 1", "equation 2", "scale factor") + args = evalCM $ \ls -> do + cov <- readVar covered + eq <- maybeCM $ safeHead $ drop cov ls + let expr = leftHandSide eq + mv <- maybeCM $ safeHead (getVars expr) + i <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls) + let coef = negate $ coefficientOf mv (leftHandSide (ls !! i)) + return (i, cov, coef) ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a)) -ruleIdentifyFreeVariables = minorRule $ makeSimpleRule "Identify free variables" $ - \c -> let vars = [ head ys | ys <- map (getVars . getLHS) (equations c), not (null ys) ] - change eq = - let (e1, e2) = splitLinearExpr (`notElem` vars) (getLHS eq) -- constant ends up in e1 - in e2 :==: getRHS eq - e1 - in return (fmap (map change) c) +ruleIdentifyFreeVariables = minorRule $ makeSimpleRule "Identify free variables" $ withCM $ \ls -> + let vars = [ head ys | ys <- map (getVars . leftHandSide) ls, not (null ys) ] + change eq = + let (e1, e2) = splitLinearExpr (`notElem` vars) (leftHandSide eq) -- constant ends up in e1 + in e2 :==: rightHandSide eq - e1 + in return (map change ls) ruleCoverUpEquation :: Rule (Context (LinearSystem a)) ruleCoverUpEquation = minorRule $ makeRule "Cover up first equation" $ changeCover (+1) @@ -109,8 +119,9 @@ ruleUncoverEquation = minorRule $ makeRule "Uncover one equation" $ changeCover (\x -> x-1) ruleCoverAllEquations :: Rule (Context (LinearSystem a)) -ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ - \c -> return (set covered (length $ equations c) c) +ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ withCM $ \ls -> do + writeVar covered (length ls) + return ls -- local helper functions deleteIndex :: Int -> [a] -> [a] @@ -124,7 +135,7 @@ -- simplify a linear system simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr)) -simplifySystem = doAfter $ fmap (map (fmap f)) +simplifySystem = doAfter $ change (map (fmap f)) where f = simplifyWith (fmap simplify) linearView --------------------------------------------------------------------------------- @@ -133,54 +144,54 @@ exchange :: Int -> Int -> Transformation [a] exchange i j | i > j = exchange j i - | otherwise = makeTrans "exchange" $ \xs -> do + | otherwise = makeTrans $ \xs -> do guard (i/=j && validEquation i xs && validEquation j xs) let (begin, x:rest) = splitAt i xs (middle, y:end) = splitAt (j-i-1) rest return $ begin++[y]++middle++[x]++end scaleEquation :: IsLinear a => Int -> a -> Transformation (LinearSystem a) -scaleEquation i a = makeTrans "scaleEquation" $ \xs -> do +scaleEquation i a = makeTrans $ \xs -> do guard (a `notElem` [0,1] && validEquation i xs) let (begin, this:end) = splitAt i xs return (begin ++ [fmap (a*) this] ++ end) addEquations :: IsLinear a => Int -> Int -> a -> Transformation (LinearSystem a) -addEquations i j a = makeTrans "addEquations" $ \xs -> do +addEquations i j a = makeTrans $ \xs -> do guard (i/=j && validEquation i xs && validEquation j xs) let (begin, this:end) = splitAt i xs exprj = xs!!j return $ begin++[combineWith (+) this (fmap (a*) exprj)]++end changeCover :: (Int -> Int) -> Transformation (Context (LinearSystem a)) -changeCover f = makeTrans "changeCover" $ \c -> do - let new = f (get covered c) - guard (new >= 0 && new <= length (equations c)) - return (set covered new c) +changeCover f = makeTrans $ withCM $ \ls -> do + new <- liftM f (readVar covered) + guard (new >= 0 && new <= length ls) + writeVar covered new + return ls -- local helper function +combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a +combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2 + validEquation :: Int -> [a] -> Bool validEquation n xs = n >= 0 && n < length xs -------------------- -- TEMP -equations :: Context (LinearSystem a) -> LinearSystem a -equations = fromContext - -- | The equations that remain to be solved -remaining :: Context (LinearSystem a) -> Equations a -remaining c = drop (get covered c) (equations c) +remaining :: LinearSystem a -> ContextMonad (Equations a) +remaining ls = do + cov <- readVar covered + return (drop cov ls) -- | The minimal variable in the remaining equations -minvar :: IsLinear a => Context (LinearSystem a) -> Maybe String -minvar c | null list = Nothing - | otherwise = Just (minimum list) - where - list = getVarsSystem (remaining c) - -liftSystemTrans :: Transformation (LinearSystem a) -> Transformation (Context (LinearSystem a)) -liftSystemTrans = lift $ makeLiftPair (return . equations) (fmap . const) +minvar :: IsLinear a => LinearSystem a -> ContextMonad String +minvar ls = do + list <- liftM getVarsSystem (remaining ls) + guard (not $ null list) + return (minimum list) systemInNF :: (Arbitrary a, IsLinear a) => Gen (LinearSystem a) systemInNF = do @@ -192,3 +203,6 @@ fromIntegerSystem :: RealFrac a => LinearSystem Integer -> LinearSystem a fromIntegerSystem = map (fmap fromInteger) + +findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int +findIndexM p = maybe mzero return . findIndex p diff --git a/src/Domain/LinearAlgebra/Exercises.hs b/src/Domain/LinearAlgebra/Exercises.hs --- a/src/Domain/LinearAlgebra/Exercises.hs +++ b/src/Domain/LinearAlgebra/Exercises.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -27,41 +27,43 @@ import Domain.LinearAlgebra.Parser import Domain.LinearAlgebra.Strategies import Domain.LinearAlgebra.Vector -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Simplification import Test.QuickCheck -import Text.Parsing (SyntaxError(..)) gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr)) -gramSchmidtExercise = testableExercise +gramSchmidtExercise = makeExercise { description = "Gram-Schmidt" , exerciseCode = makeCode "linalg" "gramschmidt" - , status = Provisional + , status = Alpha , parser = \s -> case parseVectorSpace s of - (a, []) -> Right (fmap simplified a) - (_, m:_) -> Left $ ErrorMessage $ show m + Right a -> Right (fmap simplified a) + Left msg -> Left msg , prettyPrinter = unlines . map show . vectors , equivalence = \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt in f x == f y , extraRules = rulesGramSchmidt , isReady = orthonormalList . filter (not . isZero) . vectors , strategy = gramSchmidtStrategy - , randomExercise = simpleGenerator arbitrary + , randomExercise = let f = simplified . fromInteger . (`mod` 25) + in simpleGenerator (liftM (fmap f) arbitrary) } linearSystemExercise :: Exercise (Equations Expr) -linearSystemExercise = testableExercise +linearSystemExercise = makeExercise { description = "Solve Linear System" , exerciseCode = makeCode "linalg" "linsystem" , status = Stable , parser = \s -> case parseSystem s of - (a, []) -> Right (simplify a) - (_, m:_) -> Left $ ErrorMessage $ show m + Right a -> Right (simplify a) + Left msg -> Left msg , prettyPrinter = unlines . map show - , equivalence = \x y -> let f = getSolution . equations . applyD linearSystemStrategy - . inContext . map toStandardForm - in f x == f y + , equivalence = \x y -> let f = fromContext . applyD linearSystemStrategy + . inContext linearSystemExercise . map toStandardForm + in case (f x, f y) of + (Just a, Just b) -> getSolution a == getSolution b + _ -> False , extraRules = equationsRules , isReady = inSolvedForm , strategy = linearSystemStrategy @@ -69,13 +71,13 @@ } gaussianElimExercise :: Exercise (Matrix Expr) -gaussianElimExercise = testableExercise +gaussianElimExercise = makeExercise { description = "Gaussian Elimination" , exerciseCode = makeCode "linalg" "gaussianelim" , status = Stable , parser = \s -> case parseMatrix s of - (a, []) -> Right (simplify a) - (_, m:_) -> Left $ ErrorMessage $ show m + Right a -> Right (simplify a) + Left msg -> Left msg , prettyPrinter = ppMatrixWith show , equivalence = \x y -> fmap simplified x === fmap simplified y , extraRules = matrixRules @@ -84,23 +86,31 @@ , randomExercise = simpleGenerator arbMatrix } -systemWithMatrixExercise :: Exercise (Either (LinearSystem Expr) (Matrix Expr)) -systemWithMatrixExercise = testableExercise +systemWithMatrixExercise :: Exercise Expr +systemWithMatrixExercise = makeExercise { description = "Solve Linear System with Matrix" , exerciseCode = makeCode "linalg" "systemwithmatrix" , status = Provisional , parser = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of - (Right ok, _) -> Right $ Left ok - (_, Right ok) -> Right $ Right ok - (Left _, Left _) -> Left $ ErrorMessage "Syntax error" -- FIX THIS - , prettyPrinter = either (unlines . map show) ppMatrix - , equivalence = \x y -> let f = either id matrixToSystem - in equivalence linearSystemExercise (f x) (f y) - , extraRules = map liftRuleContextLeft equationsRules ++ map liftRuleContextRight matrixRules - , isReady = either inSolvedForm (const False) + (Right ok, _) -> Right $ toExpr ok + (_, Right ok) -> Right $ toExpr ok + (Left _, Left _) -> Left "Syntax error" + , prettyPrinter = \expr -> case (fromExpr expr, fromExpr expr) of + (Just ls, _) -> (unlines . map show) (ls :: Equations Expr) + (_, Just m) -> ppMatrix (m :: Matrix Expr) + _ -> show expr + , equivalence = \x y -> let f expr = case (fromExpr expr, fromExpr expr) of + (Just ls, _) -> Just (ls :: Equations Expr) + (_, Just m) -> Just $ matrixToSystem (m :: Matrix Expr) + _ -> Nothing + in case (f x, f y) of + (Just a, Just b) -> equivalence linearSystemExercise a b + _ -> False + , extraRules = map liftExpr equationsRules ++ map liftExpr (matrixRules :: [Rule (Context (Matrix Expr))]) + , isReady = inSolvedForm . (fromExpr :: Expr -> Equations Expr) , strategy = systemWithMatrixStrategy - , randomExercise = simpleGenerator (fmap (Left . matrixToSystem) arbMatrix) - , testGenerator = fmap (liftM Left) (testGenerator linearSystemExercise) + , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr))) + , testGenerator = fmap (liftM toExpr) (testGenerator linearSystemExercise) } -------------------------------------------------------------- @@ -108,6 +118,7 @@ instance Arbitrary a => Arbitrary (Vector a) where arbitrary = liftM fromList $ oneof $ map vector [0..2] +instance CoArbitrary a => CoArbitrary (Vector a) where coarbitrary = coarbitrary . toList instance Arbitrary a => Arbitrary (VectorSpace a) where @@ -116,21 +127,17 @@ j <- choose (0, 10 `div` i) xs <- replicateM i (liftM fromList $ replicateM j arbitrary) return $ makeVectorSpace xs +instance CoArbitrary a => CoArbitrary (VectorSpace a) where coarbitrary = coarbitrary . vectors arbMatrix :: Num a => Gen (Matrix a) arbMatrix = fmap (fmap fromInteger) arbNiceMatrix -liftRuleContextLeft :: Rule (Context a) -> Rule (Context (Either a b)) -liftRuleContextLeft = lift $ makeLiftPair (maybeInContext . fmap isLeft) (\a _ -> fmap Left a) - -liftRuleContextRight :: Rule (Context b) -> Rule (Context (Either a b)) -liftRuleContextRight = lift $ makeLiftPair (maybeInContext . fmap isRight) (\b _ -> fmap Right b) - instance Arbitrary a => Arbitrary (Matrix a) where arbitrary = do (i, j) <- arbitrary arbSizedMatrix (i `mod` 5, j `mod` 5) +instance CoArbitrary a => CoArbitrary (Matrix a) where coarbitrary = coarbitrary . rows arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a) diff --git a/src/Domain/LinearAlgebra/GramSchmidtRules.hs b/src/Domain/LinearAlgebra/GramSchmidtRules.hs --- a/src/Domain/LinearAlgebra/GramSchmidtRules.hs +++ b/src/Domain/LinearAlgebra/GramSchmidtRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,14 +13,14 @@ import Common.Context import Common.Transformation +import Common.Navigator hiding (current) import Common.Utils import Domain.LinearAlgebra.Vector import Control.Monad -import Data.List varI, varJ :: Var Int -varI = "considered" := 0 -varJ = "j" := 0 +varI = newVar "considered" 0 +varJ = newVar "j" 0 rulesGramSchmidt :: Floating a => [Rule (Context (VectorSpace a))] rulesGramSchmidt = [ruleNormalize, ruleOrthogonal, ruleNext] @@ -28,51 +28,60 @@ -- Make the current vector of length 1 -- (only applicable if this is not already the case) ruleNormalize :: Floating a => Rule (Context (VectorSpace a)) -ruleNormalize = makeSimpleRule "Turn into unit Vector" $ - \c -> do v <- current c - guard (norm v `notElem` [0, 1]) - setCurrent (toUnit v) c +ruleNormalize = makeSimpleRule "Turn into unit Vector" $ withCM $ \vs -> do + v <- current vs + guard (norm v `notElem` [0, 1]) + setCurrent (toUnit v) vs -- Make the current vector orthogonal with some other vector -- that has already been considered ruleOrthogonal :: Floating a => Rule (Context (VectorSpace a)) ruleOrthogonal = makeRule "Make orthogonal" $ supplyLabeled2 descr args transOrthogonal where - descr = ("vector 1", "vector 2") - args c = do let i = get varI c-1 - j = get varJ c-1 - guard (i>j) - return (j, i) + descr = ("vector 1", "vector 2") + args = evalCM $ \_ -> do + i <- liftM pred (readVar varI) + j <- liftM pred (readVar varJ) + guard (i>j) + return (j, i) -- Variable "j" is for administrating which vectors are already orthogonal ruleNextOrthogonal :: Rule (Context (VectorSpace a)) -ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $ - \c -> do guard (get varJ c + 1 < get varI c) - return (change varJ (+1) c) +ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $ withCM $ \vs -> do + i <- readVar varI + j <- liftM succ (readVar varJ) + guard (j < i) + writeVar varJ j + return vs -- Consider the next vector -- This rule should fail if there are no vectors left ruleNext :: Rule (Context (VectorSpace a)) -ruleNext = minorRule $ makeSimpleRule "Consider next vector" $ - \c -> do guard (get varI c < length (vectors (fromContext c))) - return $ change varI (+1) $ set varJ 0 c +ruleNext = minorRule $ makeSimpleRule "Consider next vector" $ withCM $ \vs -> do + i <- readVar varI + guard (i < length (vectors vs)) + writeVar varI (i+1) + writeVar varJ 0 + return vs -current :: Context (VectorSpace a) -> Maybe (Vector a) -current c = - case drop (get varI c - 1) (vectors (fromContext c)) of - v:_ -> Just v - _ -> Nothing +current :: VectorSpace a -> ContextMonad (Vector a) +current vs = do + i <- readVar varI + case drop (i-1) (vectors vs) of + v:_ -> return v + _ -> mzero -setCurrent :: Vector a -> Context (VectorSpace a) -> Maybe (Context (VectorSpace a)) -setCurrent v c = - case splitAt (get varI c - 1) (vectors (fromContext c)) of - (xs, _:ys) -> Just $ fmap (makeVectorSpace . const (xs ++ v:ys)) c - _ -> Nothing +setCurrent :: Vector a -> VectorSpace a -> ContextMonad (VectorSpace a) +setCurrent v vs = do + i <- readVar varI + case splitAt (i-1) (vectors vs) of + (xs, _:ys) -> return $ makeVectorSpace (xs ++ v:ys) + _ -> mzero -- Two indices, change the second vector and make it orthogonal -- to the first transOrthogonal :: Floating a => Int -> Int -> Transformation (Context (VectorSpace a)) -transOrthogonal i j = contextTrans "transOrthogonal" $ \xs -> +transOrthogonal i j = contextTrans $ \xs -> do guard (i /= j && i >=0 && j >= 0) u <- safeHead $ drop i (vectors xs) guard (isUnit u) @@ -81,7 +90,8 @@ _ -> Nothing -- Find proper abstraction, and move this function to transformation module -contextTrans :: String -> (a -> Maybe a) -> Transformation (Context a) -contextTrans s f = makeTrans s $ \c -> do - new <- f (fromContext c) - return (fmap (const new) c) +contextTrans :: (a -> Maybe a) -> Transformation (Context a) +contextTrans f = makeTrans $ \c -> do + a <- fromContext c + new <- f a + return (replace new c) diff --git a/src/Domain/LinearAlgebra/LinearSystem.hs b/src/Domain/LinearAlgebra/LinearSystem.hs --- a/src/Domain/LinearAlgebra/LinearSystem.hs +++ b/src/Domain/LinearAlgebra/LinearSystem.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- module Domain.LinearAlgebra.LinearSystem where -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows) import Domain.LinearAlgebra.LinearView import Data.List @@ -26,7 +26,9 @@ getVarsSystem = foldr (\(lhs :==: rhs) xs -> getVars lhs `union` getVars rhs `union` xs) [] evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool -evalSystem = all . evalEquationWith . evalLinearExpr +evalSystem f = + let eval (x :==: y) = x==y + in all (eval . fmap (evalLinearExpr f)) invalidSystem :: IsLinear a => LinearSystem a -> Bool invalidSystem = any invalidEquation @@ -40,8 +42,8 @@ guard (null (vars `intersect` frees)) mapM make xs where - vars = concatMap (getVars . getLHS) xs - frees = concatMap (getVars . getRHS) xs + vars = concatMap (getVars . leftHandSide) xs + frees = concatMap (getVars . rightHandSide) xs make (lhs :==: rhs) = do v <- isVar lhs return (v, rhs) @@ -60,7 +62,7 @@ inSolvedForm xs = invalidSystem xs || isJust (getSolution xs) homogeneous :: IsLinear a => LinearSystem a -> Bool -homogeneous = all ((== 0) . getRHS) +homogeneous = all ((== 0) . rightHandSide) -- Conversions systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String]) diff --git a/src/Domain/LinearAlgebra/LinearView.hs b/src/Domain/LinearAlgebra/LinearView.hs --- a/src/Domain/LinearAlgebra/LinearView.hs +++ b/src/Domain/LinearAlgebra/LinearView.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -18,10 +18,8 @@ import Control.Monad import Data.List import Common.Uniplate -import Data.Maybe import Common.View hiding (simplify) -import GHC.Real -import Domain.Math.Expr +import Domain.Math.Expr hiding (isVariable) import qualified Data.Map as M data LinearMap a = LM { lmMap :: M.Map String a, lmConstant :: a } @@ -35,7 +33,7 @@ -- compositional (sumView would be a more restrictive alternative) f expr = case expr of - Nat n -> return $ LM M.empty (fromInteger n) + Nat _ -> return $ LM M.empty expr Var s -> return $ LM (M.singleton s 1) 0 a :+: b -> liftM2 plusLM (f a) (f b) a :-: b -> liftM2 plusLM (f a) (liftM negateLM (f b)) @@ -43,6 +41,7 @@ a :*: b -> join $ liftM2 timesLM (f a) (f b) a :/: b -> join $ liftM2 divLM (f a) (f b) Sqrt a -> join $ liftM sqrtLM (f a) + Number _ -> return $ LM M.empty expr Sym s as -> mapM f as >>= symLM s g (LM m c) = build sumView (concatMap make (M.toList m) ++ [c | c /= 0]) diff --git a/src/Domain/LinearAlgebra/Matrix.hs b/src/Domain/LinearAlgebra/Matrix.hs --- a/src/Domain/LinearAlgebra/Matrix.hs +++ b/src/Domain/LinearAlgebra/Matrix.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/LinearAlgebra/MatrixRules.hs b/src/Domain/LinearAlgebra/MatrixRules.hs --- a/src/Domain/LinearAlgebra/MatrixRules.hs +++ b/src/Domain/LinearAlgebra/MatrixRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,14 +13,13 @@ import Domain.Math.Simplification import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.Symbols () import Common.Context +import Common.Navigator import Common.Transformation import Control.Monad import Data.List -instance Simplify a => Simplify (Matrix a) where - simplify = fmap simplify - matrixRules :: (Argument a, Fractional a) => [Rule (Context (Matrix a))] matrixRules = let noArgs f = f (const Nothing) @@ -30,43 +29,51 @@ ] ruleFindColumnJ :: Num a => Rule (Context (Matrix a)) -ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ \c -> do - let cols = columns (subMatrix c) - i <- findIndex nonZero cols - return (set columnJ i c) +ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ withCM $ \m -> do + cols <- liftM columns (subMatrix m) + i <- findIndexM nonZero cols + writeVar columnJ i + return m ruleExchangeNonZero :: (Simplify a, Num a) => Rule (Context (Matrix a)) -ruleExchangeNonZero = simplify $ ruleExchangeRows $ \c -> do - nonEmpty c - let col = column (get columnJ c) (subMatrix c) - i <- findIndex (/= 0) col - return (get covered c, i + get covered c) +ruleExchangeNonZero = simplify $ ruleExchangeRows $ evalCM $ \m -> do + nonEmpty m + j <- readVar columnJ + col <- liftM (column j) (subMatrix m) + i <- findIndexM (/= 0) col + cov <- readVar covered + return (cov, i + cov) ruleScaleToOne :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) -ruleScaleToOne = simplify $ ruleScaleRow $ \c -> do - nonEmpty c - let pv = entry (0, get columnJ c) (subMatrix c) +ruleScaleToOne = simplify $ ruleScaleRow $ evalCM $ \m -> do + nonEmpty m + j <- readVar columnJ + pv <- liftM (entry (0, j)) (subMatrix m) guard (pv /= 0) - return (get covered c, 1 / pv) + cov <- readVar covered + return (cov, 1 / pv) ruleZerosFP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) -ruleZerosFP = simplify $ ruleAddMultiple $ \c -> do - nonEmpty c - let col = drop 1 $ column (get columnJ c) (subMatrix c) - i <- findIndex (/= 0) col +ruleZerosFP = simplify $ ruleAddMultiple $ evalCM $ \m -> do + nonEmpty m + j <- readVar columnJ + col <- liftM (drop 1 . column j) (subMatrix m) + i <- findIndexM (/= 0) col + cov <- readVar covered let v = negate (col!!i) - return (i + get covered c + 1, get covered c, v) + return (i + cov + 1, cov, v) ruleZerosBP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) -ruleZerosBP = simplify $ ruleAddMultiple $ \c -> do - nonEmpty c - let ri = row 0 (subMatrix c) - j = length $ takeWhile (==0) ri - col = column j (matrix c) +ruleZerosBP = simplify $ ruleAddMultiple $ evalCM $ \m -> do + nonEmpty m + ri <- liftM (row 0) (subMatrix m) + let j = length $ takeWhile (==0) ri + col = column j m guard (any (/= 0) ri) - k <- findIndex (/= 0) col + k <- findIndexM (/= 0) col let v = negate (col!!k) - return (k, get covered c, v) + cov <- readVar covered + return (k, cov, v) ruleCoverRow :: Rule (Context (Matrix a)) ruleCoverRow = minorRule $ makeRule "CoverRow" $ changeCover (+1) @@ -93,42 +100,48 @@ -- Parameterized transformations rowExchange :: Int -> Int -> Transformation (Context (Matrix a)) -rowExchange i j = matrixTrans "rowExchange" $ \m -> do +rowExchange i j = matrixTrans $ \m -> do guard (i /= j && validRow i m && validRow j m) return (switchRows i j m) rowScale :: Num a => Int -> a -> Transformation (Context (Matrix a)) -rowScale i k = matrixTrans "rowScale" $ \m -> do +rowScale i k = matrixTrans $ \m -> do guard (k `notElem` [0, 1] && validRow i m) return (scaleRow i k m) rowAdd :: Num a => Int -> Int -> a -> Transformation (Context (Matrix a)) -rowAdd i j k = matrixTrans "rowAdd" $ \m -> do +rowAdd i j k = matrixTrans $ \m -> do guard (k /= 0 && i /= j && validRow i m && validRow j m) return (addRow i j k m) changeCover :: (Int -> Int) -> Transformation (Context (Matrix a)) -changeCover f = makeTrans "changeCover" $ \c -> do - let new = f (get covered c) - guard (new >= 0 && new <= fst (dimensions (matrix c))) - return $ set covered new c -- c {get covered = new} +changeCover f = makeTrans $ withCM $ \m -> do + new <- liftM f (readVar covered) + guard (new >= 0 && new <= fst (dimensions m)) + writeVar covered new + return m -matrixTrans :: String -> (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a)) -matrixTrans s f = makeTrans s $ \c -> do - new <- f (fromContext c) - return (fmap (const new) c) +matrixTrans :: (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a)) +matrixTrans f = makeTrans $ \c -> do + a <- fromContext c + new <- f a + return (replace new c) -- local helper function validRow :: Int -> Matrix a -> Bool validRow i m = i >= 0 && i < fst (dimensions m) -nonEmpty :: Context (Matrix a) -> Maybe () -nonEmpty = guard . not . isEmpty . subMatrix +nonEmpty :: Matrix a -> ContextMonad () +nonEmpty m = subMatrix m >>= guard . not . isEmpty covered, columnJ :: Var Int -covered = "covered" := 0 -columnJ = "columnJ" := 0 +covered = newVar "covered" 0 +columnJ = newVar "columnJ" 0 -matrix, subMatrix :: Context (Matrix a) -> Matrix a -matrix = fromContext -subMatrix c = makeMatrix $ drop (get covered c) $ rows $ matrix c +subMatrix :: Matrix a -> ContextMonad (Matrix a) +subMatrix m = do + cov <- readVar covered + return $ makeMatrix $ drop cov $ rows $ m + +findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int +findIndexM p = maybe mzero return . findIndex p diff --git a/src/Domain/LinearAlgebra/Parser.hs b/src/Domain/LinearAlgebra/Parser.hs --- a/src/Domain/LinearAlgebra/Parser.hs +++ b/src/Domain/LinearAlgebra/Parser.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,29 +14,25 @@ , parseSystem ) where -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.LinearSystem import Domain.LinearAlgebra.LinearView (isLinear) import Domain.LinearAlgebra.Vector -import Control.Monad -import Data.List -import Data.Char import Domain.Math.Expr -import Domain.Math.Expr.Parser import Text.Parsing {- testje = case parseSystem " \n\n x == 43 \n 3*y == sqrt 4 \n" of -- "\n\n 1*x + 3*y + 2 + 87 == 2 \n " of this -> this -} -parseSystem :: String -> (LinearSystem Expr, [String]) -parseSystem = f . parse pSystem . scanWith s +parseSystem :: String -> Either String (LinearSystem Expr) +parseSystem = either Left f . parseWithM s pSystem where - s0 = newlinesAsSpecial scannerExpr + s0 = specialSymbols "\n" scannerExpr s = s0 {keywordOperators = "==" : keywordOperators s0 } - f (Nothing, xs) = ([], "System is not linear" : map show xs) - f (Just m, xs) = (m, map show xs) + f Nothing = Left "System is not linear" + f (Just m) = Right m pSystem :: TokenParser (Maybe (LinearSystem Expr)) pSystem = convertSystem <$> pEquations pExpr @@ -51,23 +47,23 @@ ----------------------------------------------------------- --- Parser -parseMatrix :: String -> (Matrix Expr, [String]) -parseMatrix = f . parse p . scanWith s +parseMatrix :: String -> Either String (Matrix Expr) +parseMatrix = either Left f . parseWithM s p where - s = newlinesAsSpecial scannerExpr + s = specialSymbols "\n" scannerExpr p = pMatrix pFractional - f (Nothing, xs) = (makeMatrix [], "Matrix is not rectangular" : map show xs) - f (Just m, xs) = (m, map show xs) + f Nothing = Left "Matrix is not rectangular" + f (Just m) = Right m pMatrix :: TokenParser a -> TokenParser (Maybe (Matrix a)) pMatrix p = make <$> pLines True (pList1 p) where make xs = if isRectangular xs then Just (makeMatrix xs) else Nothing -parseVectorSpace :: String -> (VectorSpace Expr, [Message Token]) -parseVectorSpace = parse p . scanWith s +parseVectorSpace :: String -> Either String (VectorSpace Expr) +parseVectorSpace = parseWithM s p where - s = newlinesAsSpecial scannerExpr + s = specialSymbols "\n" scannerExpr p = makeVectorSpace <$> pVectors pExpr pVectors :: TokenParser a -> TokenParser [Vector a] diff --git a/src/Domain/LinearAlgebra/Strategies.hs b/src/Domain/LinearAlgebra/Strategies.hs --- a/src/Domain/LinearAlgebra/Strategies.hs +++ b/src/Domain/LinearAlgebra/Strategies.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,18 +13,21 @@ ( gaussianElimStrategy, linearSystemStrategy , gramSchmidtStrategy, systemWithMatrixStrategy , forwardPass - , isLeft, isRight, maybeInContext + , liftExpr ) where import Prelude hiding (repeat) import Domain.Math.Expr +import Common.Rewriting import Domain.Math.Simplification import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.MatrixRules import Domain.LinearAlgebra.EquationsRules import Domain.LinearAlgebra.GramSchmidtRules import Domain.LinearAlgebra.LinearSystem +import Domain.LinearAlgebra.Symbols () import Common.Apply +import Common.Navigator import Common.Strategy hiding (not) import Common.Transformation import Common.Context @@ -70,7 +73,7 @@ label "System to Echelon Form (EEO)" $ simplifyFirst <*> repeat ( dropEquation - <|> check (not . null . remaining) + <|> check (maybe False (not . null) . evalCM remaining) <*> label "Exchange equations" (try ruleExchangeEquations) <*> label "Scale equation to one" (option ruleScaleEquation) <*> label "Eliminate variable" (repeat ruleEliminateVar) @@ -87,13 +90,13 @@ linearSystemStrategy = label "General solution to a linear system" $ systemToEchelonWithEEO <*> backSubstitution -systemWithMatrixStrategy :: LabeledStrategy (Context (Either (LinearSystem Expr) (Matrix Expr))) +systemWithMatrixStrategy :: LabeledStrategy (Context Expr) systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $ - repeat (liftLeft dropEquation) + repeat (mapRules liftExpr dropEquation) <*> conv1 - <*> liftRight gaussianElimStrategy + <*> mapRules liftExpr gaussianElimStrategy <*> conv2 - <*> repeat (liftLeft dropEquation) + <*> repeat (mapRules liftExpr dropEquation) gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr))) gramSchmidtStrategy = @@ -103,45 +106,28 @@ <*> label "Normalize" (try ruleNormalize) vars :: Var [String] -vars = "variables" := [] +vars = newVar "variables" [] simplifyFirst :: Rule (Context (LinearSystem Expr)) simplifyFirst = simplifySystem idRule -conv1 :: Rule (Context (Either (LinearSystem Expr) (Matrix Expr))) -conv1 = translationToContext "Linear system to matrix" $ \c -> - let (m, vs) = systemToMatrix (fromContext c) - in return $ set vars vs $ fmap (const (simplify m)) c +conv1 :: Rule (Context Expr) +conv1 = makeSimpleRule "Linear system to matrix" $ withCM $ \expr -> do + ls <- fromExpr expr + let (m, vs) = systemToMatrix ls + writeVar vars vs + return (toExpr (simplify (m :: Matrix Expr))) -conv2 :: Rule (Context (Either (LinearSystem Expr) (Matrix Expr))) -conv2 = translationFromContext "Matrix to linear system" $ \c -> - let linsys = matrixToSystemWith (get vars c) (fromContext c) - in return $ applyD simplifyFirst $ fmap (const linsys) c - -liftLeft :: (IsStrategy f, Lift f) => f (Context a) -> f (Context (Either a b)) -liftLeft = lift $ makeLiftPair (maybeInContext . fmap isLeft) (\a _ -> fmap Left a) - -liftRight :: (IsStrategy f, Lift f) => f (Context b) -> f (Context (Either a b)) -liftRight = lift $ - makeLiftPair (maybeInContext . fmap isRight) (\b _ -> fmap Right b) - -maybeInContext :: Context (Maybe a) -> Maybe (Context a) -maybeInContext c = fmap (\a -> fmap (const a) c) (fromContext c) - -isLeft :: Either a b -> Maybe a -isLeft = either Just (const Nothing) - -isRight :: Either a b -> Maybe b -isRight = either (const Nothing) Just - -translationToContext :: String -> (Context a -> Maybe (Context b)) -> Rule (Context (Either a b)) -translationToContext s f = makeSimpleRule s (maybe Nothing (fmap (fmap Right) . f) . maybeInContext . fmap isLeft) +conv2 :: Rule (Context Expr) +conv2 = makeSimpleRule "Matrix to linear system" $ withCM $ \expr -> do + vs <- readVar vars + m <- fromExpr expr + let linsys = matrixToSystemWith vs (m :: Matrix Expr) + a <- fromContext $ applyD simplifyFirst $ newContext emptyEnv (noNavigator linsys) -- !! + return $ toExpr a -translationFromContext :: String -> (Context b -> Maybe (Context a)) -> Rule (Context (Either a b)) -translationFromContext s f = makeSimpleRule s (maybe Nothing (fmap (fmap Left) . f) . maybeInContext . fmap isRight) - -instance Simplify a => Simplify (Vector a) where - simplify = fmap simplify - -instance Simplify a => Simplify (VectorSpace a) where - simplify = fmap simplify +liftExpr :: IsTerm a => Rule (Context a) -> Rule (Context Expr) +liftExpr r = makeSimpleRuleList (name r) $ \a -> do + b <- castT exprView a + c <- applyAll r b + castT exprView c diff --git a/src/Domain/LinearAlgebra/Symbols.hs b/src/Domain/LinearAlgebra/Symbols.hs --- a/src/Domain/LinearAlgebra/Symbols.hs +++ b/src/Domain/LinearAlgebra/Symbols.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,42 +9,57 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra.Symbols - ( -- linalg2 - matrixSymbol, matrixrowSymbol, vectorSymbol - ) where +module Domain.LinearAlgebra.Symbols () where -import Domain.Math.Expr.Conversion import Domain.Math.Expr.Symbolic +import Domain.Math.Simplification import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.Vector import Control.Monad -import Text.OpenMath.Dictionary.Linalg2 +import qualified Text.OpenMath.Dictionary.Linalg2 as Linalg2 +import Common.Rewriting.Term +vectorSymbol, matrixSymbol, matrixrowSymbol :: Symbol +vectorSymbol = toSymbol Linalg2.vectorSymbol +matrixSymbol = toSymbol Linalg2.matrixSymbol +matrixrowSymbol = toSymbol Linalg2.matrixrowSymbol + ------------------------------------------------------- -- Conversion to the Expr data type -instance IsExpr a => IsExpr (Matrix a) where - toExpr = - let f = function matrixrowSymbol . map toExpr +instance IsTerm a => IsTerm (Matrix a) where + toTerm = + let f = function matrixrowSymbol . map toTerm in function matrixSymbol . map f . rows - fromExpr a = do + fromTerm a = do rs <- isSymbol matrixSymbol a xss <- mapM (isSymbol matrixrowSymbol) rs - yss <- mapM (mapM fromExpr) xss + yss <- mapM (mapM fromTerm) xss guard (isRectangular yss) return (makeMatrix yss) - -instance IsExpr a => IsExpr (Vector a) where - toExpr = function vectorSymbol . map toExpr . toList - fromExpr expr = do - xs <- isSymbol vectorSymbol expr - ys <- mapM fromExpr xs + +instance IsTerm a => IsTerm (Vector a) where + toTerm = function vectorSymbol . map toTerm . toList + fromTerm a = do + xs <- isSymbol vectorSymbol a + ys <- mapM fromTerm xs return (fromList ys) -instance IsExpr a => IsExpr (VectorSpace a) where - toExpr = toExpr . vectors - fromExpr expr = do - xs <- fromExpr expr +instance IsTerm a => IsTerm (VectorSpace a) where + toTerm = toTerm . vectors + fromTerm a = do + xs <- fromTerm a guard (sameDimension xs) return (makeVectorSpace xs) + +------------------------------------------------------- +-- Simplification + +instance Simplify a => Simplify (Matrix a) where + simplify = fmap simplify + +instance Simplify a => Simplify (Vector a) where + simplify = fmap simplify + +instance Simplify a => Simplify (VectorSpace a) where + simplify = fmap simplify diff --git a/src/Domain/LinearAlgebra/Vector.hs b/src/Domain/LinearAlgebra/Vector.hs --- a/src/Domain/LinearAlgebra/Vector.hs +++ b/src/Domain/LinearAlgebra/Vector.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Logic.hs b/src/Domain/Logic.hs --- a/src/Domain/Logic.hs +++ b/src/Domain/Logic.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -18,7 +18,6 @@ , module Domain.Logic.BuggyRules , module Domain.Logic.GeneralizedRules , module Domain.Logic.Exercises - , module Domain.Logic.FeedbackText ) where import Domain.Logic.Formula @@ -29,5 +28,4 @@ import Domain.Logic.BuggyRules import Domain.Logic.GeneralizedRules import Domain.Logic.Exercises -import Domain.Logic.FeedbackText diff --git a/src/Domain/Logic/BuggyRules.hs b/src/Domain/Logic/BuggyRules.hs --- a/src/Domain/Logic/BuggyRules.hs +++ b/src/Domain/Logic/BuggyRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Logic/Exercises.hs b/src/Domain/Logic/Exercises.hs --- a/src/Domain/Logic/Exercises.hs +++ b/src/Domain/Logic/Exercises.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -19,6 +19,7 @@ import Common.Context import Common.Derivation import Common.Exercise +import Common.Navigator import Common.Rewriting (differenceMode) import Common.Strategy import Data.Maybe @@ -29,15 +30,14 @@ import Domain.Logic.Rules import Domain.Logic.Strategies import Test.QuickCheck -import Text.Parsing (fromRanged) - + -- Currently, we use the DWA strategy dnfExercise :: Exercise SLogic dnfExercise = makeExercise { description = "Proposition to DNF" , exerciseCode = makeCode "logic" "dnf" , status = Stable - , parser = either Left (Right . fromRanged) . parseLogicPars + , parser = parseLogicPars , prettyPrinter = ppLogicPars , equivalence = eqLogic , similarity = equalLogicA @@ -45,8 +45,9 @@ , isSuitable = suitable , extraRules = map liftToContext (logicRules ++ buggyRules) , strategy = dnfStrategyDWA + , navigation = navigator , difference = differenceMode eqLogic - , testGenerator = Just (restrictGenerator suitable generateLogic) + , testGenerator = Just (restrictGenerator suitable arbitrary) , randomExercise = useGenerator (const True) logicExercise } @@ -55,7 +56,7 @@ dnfUnicodeExercise = dnfExercise { description = description dnfExercise ++ " (unicode support)" , exerciseCode = makeCode "logic" "dnf-unicode" - , parser = either Left (Right . fromRanged) . parseLogicUnicodePars + , parser = parseLogicUnicodePars , prettyPrinter = ppLogicUnicodePars } @@ -74,7 +75,7 @@ stepsRemaining :: Int -> SLogic -> Maybe Int stepsRemaining i = - lengthMax i . derivationTree dnfStrategyDWA . inContext + lengthMax i . derivationTree dnfStrategyDWA . inContext dnfExercise -- QuickCheck property to monitor the number of steps needed -- to normalize a random proposition (30-40% is ok) @@ -86,9 +87,6 @@ testme :: IO () testme = quickCheck testGen - - -import Service.TypedAbstractService start = ((r :<->: p) :||: (q :->: s)) :&&: (Not s :<->: (p :||: r)) where diff --git a/src/Domain/Logic/FeedbackText.hs b/src/Domain/Logic/FeedbackText.hs --- a/src/Domain/Logic/FeedbackText.hs +++ b/src/Domain/Logic/FeedbackText.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,35 +12,19 @@ -- by Josje Lodder. -- ----------------------------------------------------------------------------- -module Domain.Logic.FeedbackText - ( feedbackSyntaxError, ruleText, appliedRule - , feedbackBuggy, feedbackNotEquivalent - , feedbackSame - , feedbackOk, feedbackDetour, feedbackUnknown - ) where +module Domain.Logic.FeedbackText where +import Data.List import Data.Maybe -import Text.Parsing import Common.Transformation import Domain.Logic.Rules import Domain.Logic.BuggyRules --- This is more general than the logic domain. Perhaps it should --- be defined elsewhere -feedbackSyntaxError :: SyntaxError -> String -feedbackSyntaxError syntaxError = - case syntaxError of - ParNotClosed token -> - "Opening parenthesis symbol '(' at position " ++ tokenPos token ++ " is not closed." - ParNoOpen token -> - "Closing parenthesis symbol ')' at position " ++ tokenPos token ++ " has no matching opening parenthesis." - ParMismatch token1 token2 -> - "The openening parenthesis at position " ++ tokenPos token1 ++ - " does not match with the closing parenthesis at position " ++ tokenPos token2 ++ "." - ErrorMessage txt -> - txt - Unexpected token -> - "Unexpected " ++ showToken token +feedbackSyntaxError :: String -> String +feedbackSyntaxError msg + | take 1 msg == "(" = "Syntax error at " ++ msg + | "Syntax error" `isPrefixOf` msg = msg + | otherwise = "Syntax error: " ++ msg feedbackBuggy :: Bool -> [Rule a] -> String feedbackBuggy ready [br] @@ -185,12 +169,3 @@ inGroup r n = let rs = filter (~= r) (logicRules ++ buggyRules) in n `elem` concatMap ruleGroups rs - -showToken :: Token -> String -showToken token = tokenText token ++ " at position " ++ tokenPos token - -tokenPos :: Token -> String -tokenPos token = - let p@(l, c) = toPosition token - in if l==1 then show c else show p - diff --git a/src/Domain/Logic/Formula.hs b/src/Domain/Logic/Formula.hs --- a/src/Domain/Logic/Formula.hs +++ b/src/Domain/Logic/Formula.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,11 +11,14 @@ ----------------------------------------------------------------------------- module Domain.Logic.Formula where +import Domain.Math.Expr.Symbolic +import Text.OpenMath.Dictionary.Logic1 import Common.Uniplate (Uniplate(..), universe) import Common.Rewriting -import Common.Utils +import Common.Traversable +import Common.Utils (ShowString, subsets) import Data.List -import Data.Maybe +import Control.Monad infixr 2 :<->: infixr 3 :->: @@ -32,14 +35,26 @@ | Not (Logic a) -- not | T -- true | F -- false - deriving (Show, Eq, Ord) + deriving (Eq, Ord) -- | For simple use, we assume the variables to be strings -type SLogic = Logic String +type SLogic = Logic ShowString +instance Show a => Show (Logic a) where + show = ppLogic + instance Functor Logic where fmap f = foldLogic (Var . f, (:->:), (:<->:), (:&&:), (:||:), Not, T, F) +instance Crush Logic where + crush p = [ x | Var x <- universe p ] + +instance Switch Logic where + switch = foldLogic + ( liftM Var, liftM2 (:->:), liftM2 (:<->:), liftM2 (:&&:) + , liftM2 (:||:), liftM Not, return T, return F + ) + -- | The type LogicAlg is the algebra for the data type Logic -- | Used in the fold for Logic. type LogicAlg b a = (b -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a, a) @@ -58,7 +73,23 @@ Not p -> not (rec p) T -> true F -> false - + +-- | Pretty-printer for propositions +ppLogic :: Show a => Logic a -> String +ppLogic = ppLogicPrio 0 + +ppLogicPrio :: Show a => Int -> Logic a -> String +ppLogicPrio n p = foldLogic (pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\", binop 1 "||", nott, pp "T", pp "F") p n "" + where + binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio) + pp s = const (s++) + nott p _ = ("~"++) . p 4 + parIf b f = if b then ("("++) . f . (")"++) else f + +-- | The monadic join for logic +catLogic :: Logic (Logic a) -> Logic a +catLogic = foldLogic (id, (:->:), (:<->:), (:&&:), (:||:), Not, T, F) + -- | evalLogic takes a function that gives a logic value to a variable, -- | and a Logic expression, and evaluates the boolean expression. evalLogic :: (a -> Bool) -> Logic a -> Bool @@ -151,10 +182,30 @@ (F , F ) -> True _ -> False -instance MetaVar a => MetaVar (Logic a) where - isMetaVar (Var a) = isMetaVar a - isMetaVar _ = Nothing - metaVar = Var . metaVar +instance Different (Logic a) where + different = (T, F) + +instance IsTerm a => IsTerm (Logic a) where + toTerm = foldLogic + ( toTerm, binary impliesSymbol, binary equivalentSymbol + , binary andSymbol, binary orSymbol, unary notSymbol + , nullary trueSymbol, nullary falseSymbol + ) + + fromTerm a = + fromTermWith f a `mplus` liftM Var (fromTerm a) + where + f s [] + | s == trueSymbol = return T + | s == falseSymbol = return F + f s [x] + | s == notSymbol = return (Not x) + f s [x, y] + | s == impliesSymbol = return (x :->: y) + | s == equivalentSymbol = return (x :<->: y) + | s == andSymbol = return (x :&&: y) + | s == orSymbol = return (x :||: y) + f _ _ = fail "fromTerm" logicOperators :: Operators (Logic a) logicOperators = [andOperator, orOperator] diff --git a/src/Domain/Logic/GeneralizedRules.hs b/src/Domain/Logic/GeneralizedRules.hs --- a/src/Domain/Logic/GeneralizedRules.hs +++ b/src/Domain/Logic/GeneralizedRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Logic/Generator.hs b/src/Domain/Logic/Generator.hs --- a/src/Domain/Logic/Generator.hs +++ b/src/Domain/Logic/Generator.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,19 +14,23 @@ ( generateLogic, generateLevel, equalLogicA, Level(..) ) where +import Common.Utils (ShowString(..)) import Domain.Logic.Formula import Control.Monad import Data.Char -import Test.QuickCheck hiding (defaultConfig) +import Test.QuickCheck import Common.Rewriting import Common.Uniplate +import Domain.Math.Expr.Symbolic +import Text.OpenMath.Dictionary.Logic1 ------------------------------------------------------------- -- Code that doesn't belong here, but the arbitrary instance -- is needed for the Rewrite instance. instance Rewrite SLogic where - operators = logicOperators + operators = logicOperators + associativeOps = const $ map toSymbol [andSymbol, orSymbol] -- | Equality modulo associativity of operators equalLogicA:: SLogic -> SLogic -> Bool @@ -65,16 +69,16 @@ -- Use the propositions with 7-18 steps difficultGenerator :: Gen SLogic difficultGenerator = do - let vars = "s" : varList + let vars = ShowString "s" : varList n <- return 4 -- oneof [return 4, return 8] p0 <- sizedGen False (oneof $ map return vars) n p1 <- preventSameVar vars p0 return (removePartsInDNF p1) -varList :: [String] -varList = ["p", "q", "r"] +varList :: [ShowString] +varList = map ShowString ["p", "q", "r"] -varGen :: Gen String +varGen :: Gen ShowString varGen = oneof $ map return varList sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a) @@ -122,10 +126,11 @@ --- QuickCheck generator instance Arbitrary SLogic where - arbitrary = sized (sizedGen True varGen) + arbitrary = sized (\i -> sizedGen True varGen (i `min` 4)) +instance CoArbitrary SLogic where coarbitrary logic = case logic of - Var x -> variant 0 . coarbitrary (map ord x) + Var x -> variant 0 . coarbitrary (map ord (fromShowString x)) p :->: q -> variant 1 . coarbitrary p . coarbitrary q p :<->: q -> variant 2 . coarbitrary p . coarbitrary q p :&&: q -> variant 3 . coarbitrary p . coarbitrary q diff --git a/src/Domain/Logic/Parser.hs b/src/Domain/Logic/Parser.hs --- a/src/Domain/Logic/Parser.hs +++ b/src/Domain/Logic/Parser.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,21 +11,22 @@ ----------------------------------------------------------------------------- module Domain.Logic.Parser ( parseLogic, parseLogicPars, parseLogicUnicodePars - , ppLogic, ppLogicPrio, ppLogicPars, ppLogicUnicodePars + , ppLogicPars, ppLogicUnicodePars ) where +import Common.Utils (ShowString(..)) import Text.Parsing import Control.Arrow import Domain.Logic.Formula logicScanner :: Scanner -logicScanner = (makeCharsSpecial "~" defaultScanner) +logicScanner = (specialSymbols "~" defaultScanner) { keywords = ["T", "F"] , keywordOperators = "~" : concatMap (map fst . snd) operatorTable } logicUnicodeScanner :: Scanner -logicUnicodeScanner = (makeCharsSpecial (concat unicodeSyms) defaultScanner) +logicUnicodeScanner = (specialSymbols (concat unicodeSyms) defaultScanner) { keywords = ["T", "F"] , keywordOperators = unicodeSyms } @@ -43,7 +44,7 @@ -- | Parser for logic formulas that respects all associativity and priority laws -- | of the constructors -parseLogic :: String -> Either SyntaxError (Ranged SLogic) +parseLogic :: String -> Either String SLogic parseLogic = analyseAndParse pLogic . scanWith logicScanner where pLogic = pOperators operatorTable (basicWithPos pLogic) @@ -52,14 +53,14 @@ -- | but implication and equivalence are not. Priorities of the operators are unknown, and thus -- | parentheses have to be written explicitly. No parentheses are needed for Not (Not p). Superfluous -- | parentheses are permitted -parseLogicPars :: String -> Either SyntaxError (Ranged SLogic) +parseLogicPars :: String -> Either String SLogic parseLogicPars s = either Left suspiciousVariable $ left (ambiguousOperators parseLogic s) $ analyseAndParse (pLogicGen asciiTuple) $ scanWith logicScanner s -parseLogicUnicodePars :: String -> Either SyntaxError (Ranged SLogic) +parseLogicUnicodePars :: String -> Either String SLogic parseLogicUnicodePars s = either Left suspiciousVariable $ left (ambiguousOperators (parseLogic . concatMap f) s) @@ -78,43 +79,44 @@ where pLogic = flip ($) <$> basic <*> optional composed id basic = basicWithPosGen (nt, tr, fl) pLogic - composed = flip (binaryOp (:<->:)) <$ pKey equiv <*> basic - <|> flip (binaryOp (:->:)) <$ pKey impl <*> basic - <|> (\xs p -> foldr1 (binaryOp (:&&:)) (p:xs)) <$> pList1 (pKey and *> basic) - <|> (\xs p -> foldr1 (binaryOp (:||:)) (p:xs)) <$> pList1 (pKey or *> basic) + composed = flip (:<->:) <$ pKey equiv <*> basic + <|> flip (:->:) <$ pKey impl <*> basic + <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey and *> basic) + <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey or *> basic) -basicWithPos :: Parser Token (Ranged SLogic) -> Parser Token (Ranged SLogic) +basicWithPos :: Parser Token SLogic -> Parser Token SLogic basicWithPos = basicWithPosGen ("~", "T", "F") basicWithPosGen t@(nt, tr, fl) p = - (\(s, r) -> toRanged (Var s) r) <$> pVarid + (Var . ShowString) <$> pVarid <|> pParens p - <|> toRanged T <$> pKey tr - <|> toRanged F <$> pKey fl - <|> unaryOp Not <$> pKey nt <*> basicWithPosGen t p + <|> T <$ pKey tr + <|> F <$ pKey fl + <|> Not <$ pKey nt <*> basicWithPosGen t p ----------------------------------------------------------- --- Helper-functions for syntax warnings -- analyze parentheses -analyseAndParse :: Parser Token a -> [Token] -> Either SyntaxError a +analyseAndParse :: Parser Token a -> [Token] -> Either String a analyseAndParse p ts = case checkParentheses ts of - Just err -> Left err - Nothing -> case parse p ts of - (_, m:_) -> Left (fromMessage m) - (a, _) -> Right a + Just err -> Left (show err) + Nothing -> either (Left . f) Right (parse p ts) + where + f (Just t) = show (tokenPosition t) ++ ": Unexpected " ++ show t + f Nothing = "Syntax error" -ambiguousOperators :: (String -> Either a b) -> String -> SyntaxError -> SyntaxError +ambiguousOperators :: (String -> Either a b) -> String -> String -> String ambiguousOperators p s err = - let msg = ErrorMessage "Ambiguous use of operators (write parentheses)" + let msg = "Ambiguous use of operators (write parentheses)" in either (const err) (const msg) (p s) -- Report variables -suspiciousVariable :: Ranged SLogic -> Either SyntaxError (Ranged SLogic) +suspiciousVariable :: SLogic -> Either String SLogic suspiciousVariable r = - case filter p (varsLogic (fromRanged r)) of - v:_ -> Left $ ErrorMessage $ "Unexpected variable " ++ v + case filter p (map fromShowString (varsLogic r)) of + v:_ -> Left $ "Unexpected variable " ++ v ++ ". Did you forget an operator?" _ -> Right r where @@ -123,17 +125,6 @@ ----------------------------------------------------------- --- Pretty-Printer -ppLogic :: SLogic -> String -ppLogic = ppLogicPrio 0 - -ppLogicPrio :: Int -> SLogic -> String -ppLogicPrio n p = foldLogic (var, binop 3 "->", binop 0 "<->", binop 2 "/\\", binop 1 "||", nott, var "T", var "F") p n "" - where - binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio) - var = const . (++) - nott p _ = ("~"++) . p 4 - parIf b f = if b then ("("++) . f . (")"++) else f - -- | Pretty printer that produces extra parentheses: also see parseLogicPars ppLogicPars :: SLogic -> String ppLogicPars = ppLogicParsGen asciiTuple @@ -144,10 +135,10 @@ ppLogicParsGen (impl, equiv, and, or, nt, tr, fl) p = foldLogic alg p 0 "" where - alg = (var, binop 3 impl, binop 3 equiv, binop 1 and, binop 2 or, nott, var tr, var fl) + alg = (pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 and, binop 2 or, nott, pp tr, pp fl) binop prio op p q n = parIf (n/=0 && (n==3 || prio/=n)) (p prio . ((" "++op++" ")++) . q prio) - var = const . (++) + pp s = const (s++) nott p _ = (nt++) . p 3 parIf b f = if b then ("("++) . f . (")"++) else f diff --git a/src/Domain/Logic/Rules.hs b/src/Domain/Logic/Rules.hs --- a/src/Domain/Logic/Rules.hs +++ b/src/Domain/Logic/Rules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -262,4 +262,4 @@ ruleImplSame :: Rule SLogic ruleImplSame = rule "ImplSame" $ - \x -> x :->: x :~> T + \x -> x :->: (x::SLogic) :~> T diff --git a/src/Domain/Logic/Strategies.hs b/src/Domain/Logic/Strategies.hs --- a/src/Domain/Logic/Strategies.hs +++ b/src/Domain/Logic/Strategies.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -16,10 +16,11 @@ import Domain.Logic.Rules import Domain.Logic.GeneralizedRules import Domain.Logic.Formula -import Common.Context (Context, liftToContext, currentFocus) +import Common.Context (Context, liftToContext) import Common.Rewriting (isOperator) import Common.Transformation import Common.Strategy +import Common.Navigator ----------------------------------------------------------------------------- -- To DNF, with priorities (the "DWA" approachs) @@ -57,9 +58,14 @@ -- the strategy only at (top-level) disjuncts somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic) somewhereOr s = - let isOr = maybe False (isOperator orOperator) . currentFocus + let isOr = maybe False (isOperator orOperator) . current in fix $ \this -> check (Prelude.not . isOr) <*> s <|> check isOr <*> once this + +--check1, check2 :: (a -> Bool) -> Rule a +--check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing +--check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing + ----------------------------------------------------------------------------- -- To DNF, in four steps diff --git a/src/Domain/Math/Approximation.hs b/src/Domain/Math/Approximation.hs --- a/src/Domain/Math/Approximation.hs +++ b/src/Domain/Math/Approximation.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -18,6 +18,13 @@ type Function = Double -> Double type Approximation = [Double] + +------------------------------------------------------------ +-- Precision of a floating-point number + +precision :: Int -> Double -> Double +precision n = (/a) . fromIntegral . round . (*a) + where a = 10 Prelude.^ (max 0 n) ------------------------------------------------------------ -- Stop criteria diff --git a/src/Domain/Math/Clipboard.hs b/src/Domain/Math/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Clipboard.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for a clipboard, on which expressions can be placed. The clipboard +-- is part of the environment (terms that are placed in a context) +-- +----------------------------------------------------------------------------- +module Domain.Math.Clipboard + ( addToClipboard, addListToClipboard + , lookupClipboard, lookupListClipboard, removeClipboard + -- generalized interface + , addToClipboardG, addListToClipboardG + , lookupClipboardG, lookupListClipboardG + ) where + +import Common.Context +import Control.Monad +import Common.Rewriting +import Common.Rewriting.Term (Term) +import Data.Maybe +import Domain.Math.Data.Relation +import Domain.Math.Expr +import qualified Data.Map as M + +--------------------------------------------------------------------- +-- Expression variables (internal) + +newtype ExprVar a = ExprVar (Var Term) + +exprVar :: (Show a, IsTerm a) => String -> a -> ExprVar a +exprVar s a = ExprVar (makeVar showF readF s (toTerm a)) + where + showF = show . toExpr -- pretty-print as an Expr + readF = either (fail . show) (return . toTerm) . parseExpr + +readExprVar :: IsTerm a => ExprVar a -> ContextMonad a +readExprVar (ExprVar var) = do + term <- readVar var + maybeCM (fromTerm term) + +modifyExprVar :: IsTerm a => ExprVar a -> (a -> a) -> ContextMonad () +modifyExprVar (ExprVar var) f = + let safe f a = fromMaybe a (f a) + g = fmap (toTerm . f) . fromTerm + in modifyVar var (safe g) + +--------------------------------------------------------------------- +-- Clipboard variable + +newtype Key = Key String deriving (Show, Eq, Ord) + +instance (IsTerm k, Ord k, IsTerm a) => IsTerm (M.Map k a) where + toTerm = toTerm . map (\(k, a) -> toTerm k :==: toTerm a) . M.toList + fromTerm term = do + eqs <- fromTerm term + xs <- forM eqs $ \(a :==: b) -> + liftM2 (,) (fromTerm a) (fromTerm b) + return (M.fromList xs) + +instance IsTerm Key where + toTerm (Key s) = variable s + fromTerm = liftM Key . getVariable + +clipboard :: ExprVar (M.Map Key Expr) +clipboard = exprVar "clipboard" M.empty + +--------------------------------------------------------------------- +-- Interface to work with clipboard + +addToClipboard :: String -> Expr -> ContextMonad () +addToClipboard = addToClipboardG + +addListToClipboard :: [String] -> [Expr] -> ContextMonad () +addListToClipboard = addListToClipboardG + +lookupClipboard :: String -> ContextMonad Expr +lookupClipboard = lookupClipboardG + +lookupListClipboard :: [String] -> ContextMonad [Expr] +lookupListClipboard = lookupListClipboardG + +removeClipboard :: String -> ContextMonad () +removeClipboard s = + modifyExprVar clipboard (M.delete (Key s)) + +--------------------------------------------------------------------- +-- Generalized interface to work with clipboard + +addToClipboardG :: IsTerm a => String -> a -> ContextMonad () +addToClipboardG s a = modifyExprVar clipboard (M.insert (Key s) (toExpr a)) + +addListToClipboardG :: IsTerm a => [String] -> [a] -> ContextMonad () +addListToClipboardG = zipWithM_ addToClipboardG + +lookupClipboardG :: IsTerm a => String -> ContextMonad a +lookupClipboardG s = do + m <- readExprVar clipboard + expr <- maybeCM (M.lookup (Key s) m) + fromExpr expr + +lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a] +lookupListClipboardG = mapM lookupClipboardG diff --git a/src/Domain/Math/Data/Equation.hs b/src/Domain/Math/Data/Equation.hs deleted file mode 100644 --- a/src/Domain/Math/Data/Equation.hs +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Mathematical equations --- ------------------------------------------------------------------------------ -module Domain.Math.Data.Equation where - -import Common.Uniplate -import Common.Rewriting -import Common.Traversable -import Test.QuickCheck -import Control.Monad - -infix 1 :==: - -type Equations a = [Equation a] - -data Equation a = a :==: a - deriving (Eq, Ord) - -instance Functor Equation where - fmap f (x :==: y) = f x :==: f y - -instance Once Equation where - onceM f (lhs :==: rhs) = - liftM (:==: rhs) (f lhs) `mplus` liftM (lhs :==:) (f rhs) - -instance Switch Equation where - switch (ma :==: mb) = liftM2 (:==:) ma mb - -instance Crush Equation where - crush (a :==: b) = [a, b] - -instance Show a => Show (Equation a) where - show (x :==: y) = show x ++ " == " ++ show y - -getLHS, getRHS :: Equation a -> a -getLHS (x :==: _) = x -getRHS (_ :==: y) = y - -evalEquation :: Eq a => Equation a -> Bool -evalEquation = evalEquationWith id - -evalEquationWith :: Eq b => (a -> b) -> Equation a -> Bool -evalEquationWith f (x :==: y) = f x == f y - -substEquation :: (Uniplate a, MetaVar a) => Substitution a -> Equation a -> Equation a -substEquation sub (x :==: y) = (sub |-> x) :==: (sub |-> y) - -substEquations :: (Uniplate a, MetaVar a) => Substitution a -> Equations a -> Equations a -substEquations = map . substEquation - -combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a -combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2 - -flipSides :: Equation a -> Equation a -flipSides (x :==: y) = y :==: x - ------------------------------------------------------ --- QuickCheck generators - -instance Arbitrary a => Arbitrary (Equation a) where - arbitrary = liftM2 (:==:) arbitrary arbitrary - coarbitrary (x :==: y) = coarbitrary x . coarbitrary y diff --git a/src/Domain/Math/Data/Interval.hs b/src/Domain/Math/Data/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/Interval.hs @@ -0,0 +1,363 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for mathematical intervals (open, closed, unbounded). @Intervals@ +-- is a normalized (and sorted) list of intervals that supports testing for +-- equality. +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.Interval + ( -- Data types + Intervals, Interval + -- Interval constructors + , empty, singleton, unbounded, open, closed + , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo + , lessThan, lessThanOrEqualTo + -- Inspecing an interval + , isEmpty, leftPoint, rightPoint, Endpoint(..) + -- Making intervals + , except, toList, fromList + , union, intersect, complement + , isIn, isInInterval + -- QuickChecks + , testMe + ) where + +import Common.Utils (commaList) +import Control.Monad +import Data.Maybe +import Test.QuickCheck + +-------------------------------------------------------------------- +-- Data declarations + +newtype Intervals a = IS [Interval a] + deriving Eq + +data Interval a = Empty | I (Endpoint a) (Endpoint a) + deriving Eq + +data Endpoint a = Excluding a | Including a | Unbounded + deriving Eq + +instance Show a => Show (Intervals a) where + show xs = "{ " ++ commaList (map show (toList xs)) ++ " }" + +instance Show a => Show (Interval a) where + show interval = + case interval of + Empty -> "{}" + I a b -> showLeft a ++ "," ++ showRight b + +instance Functor Endpoint where + fmap f (Excluding a) = Excluding (f a) + fmap f (Including a) = Including (f a) + fmap _ Unbounded = Unbounded + +instance Functor Interval where + fmap _ Empty = Empty + fmap f (I a b) = I (fmap f a) (fmap f b) -- function should not change order + +instance Functor Intervals where + fmap f (IS xs) = IS (map (fmap f) xs) + +showLeft, showRight :: Show a => Endpoint a -> String +showLeft (Excluding a) = "(" ++ show a +showLeft (Including a) = "[" ++ show a +showLeft Unbounded = "(-inf" +showRight (Excluding a) = show a ++ ")" +showRight (Including a) = show a ++ "]" +showRight Unbounded = "inf)" + +-------------------------------------------------------------------- +-- Interval constructors + +empty :: Interval a +empty = Empty + +singleton :: Ord a => a -> Interval a +singleton a = closed a a + +unbounded :: Ord a => Interval a +unbounded = makeInterval Unbounded Unbounded + +open :: Ord a => a -> a -> Interval a +open a b = makeInterval (Excluding a) (Excluding b) + +closed :: Ord a => a -> a -> Interval a +closed a b = makeInterval (Including a) (Including b) + +leftOpen :: Ord a => a -> a -> Interval a +leftOpen a b = makeInterval (Excluding a) (Including b) + +rightOpen :: Ord a => a -> a -> Interval a +rightOpen a b = makeInterval (Including a) (Excluding b) + +greaterThan :: Ord a => a -> Interval a +greaterThan a = makeInterval (Excluding a) Unbounded + +greaterThanOrEqualTo :: Ord a => a -> Interval a +greaterThanOrEqualTo a = makeInterval (Including a) Unbounded + +lessThan :: Ord a => a -> Interval a +lessThan a = makeInterval Unbounded (Excluding a) + +lessThanOrEqualTo :: Ord a => a -> Interval a +lessThanOrEqualTo a = makeInterval Unbounded (Including a) + +-- local constructor +makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a +makeInterval pl pr = + case liftM2 compare (getPoint pl) (getPoint pr) of + Just LT -> I pl pr + Just EQ + | isIncluding pl && isIncluding pr -> I pl pr + | otherwise -> Empty + Just GT -> Empty + Nothing -> I pl pr + +isIncluding :: Endpoint a -> Bool +isIncluding (Including _) = True +isIncluding _ = False + +isExcluding :: Endpoint a -> Bool +isExcluding (Excluding _) = True +isExcluding _ = False + +-------------------------------------------------------------------- +-- Inspecting an interval + +isEmpty :: Interval a -> Bool +isEmpty Empty = True +isEmpty _ = False + +leftPoint, rightPoint :: Interval a -> Endpoint a +leftPoint (I a _) = a +leftPoint Empty = error "leftPoint Empty" +rightPoint (I _ a) = a +rightPoint Empty = error "rightPoint Empty" + +-------------------------------------------------------------------- +-- Combining multiple intervals + +except :: Ord a => a -> Intervals a +except a = fromList [lessThan a, greaterThan a] + +toList :: Intervals a -> [Interval a] +toList (IS xs) = xs + +fromList :: Ord a => [Interval a] -> Intervals a +fromList = foldr insert (IS []) + +insert :: Ord a => Interval a -> Intervals a -> Intervals a +insert Empty xs = xs +insert iv@(I l _) (IS xs) = rec xs + where + rec [] = IS [iv] + rec (hd:rest) = + case (hd, merge iv hd) of + (Empty, _) -> rec rest + (_, Just new) -> insert new (IS rest) + (I a _, Nothing) + | minPointLeft a l == a -> let IS tl = rec rest in IS (hd:tl) + | otherwise -> IS (iv:hd:rest) + +union :: Ord a => Intervals a -> Intervals a -> Intervals a +union xs = foldr insert xs . toList + +intersect :: Ord a => Intervals a -> Intervals a -> Intervals a +intersect (IS xs) (IS ys) = fromList (f xs ys) + where + f (a@(I _ ar):as) (b@(I _ br):bs) = inBoth a b : rest + where + rest | maxPointRight ar br == ar = f (a:as) bs + | otherwise = f as (b:bs) + f _ _ = [] + +complement :: Ord a => Intervals a -> Intervals a +complement (IS xs) = fromList (left ++ zipWith f xs (drop 1 xs) ++ right) + where + f (I _ a) (I b _) = fromMaybe Empty (liftM2 I (g a) (g b)) + f _ _ = Empty + + g (Including a) = Just (Excluding a) + g (Excluding a) = Just (Including a) + g Unbounded = Nothing + + left = case xs of + I al _:_ -> maybe [] (return . I Unbounded) (g al) + _ -> [unbounded] + right = case reverse xs of + I _ ar:_ -> maybe [] (return . flip I Unbounded) (g ar) + _ -> [unbounded] + +isIn :: Ord a => a -> Intervals a -> Bool +isIn a (IS xs) = any (isInInterval a) xs + +isInInterval :: Ord a => a -> Interval a -> Bool +isInInterval _ Empty = False +isInInterval a (I b c) = f GT b && f LT c + where + f value x = + let g c = (c==EQ && isIncluding x) || c==value + in maybe True (g . compare a) (getPoint x) + +--------------------------------------------------------------------- +-- Local helper functions + +getPoint :: Endpoint a -> Maybe a +getPoint (Including a) = Just a +getPoint (Excluding a) = Just a +getPoint Unbounded = Nothing + +merge :: Ord a => Interval a -> Interval a -> Maybe (Interval a) +merge a Empty = Just a +merge Empty b = Just b +merge ia@(I al ar) ib@(I bl br) + | minPointLeft al bl /= al = merge ib ia + | otherwise = + case liftM2 compare (getPoint ar) (getPoint bl) of + Just LT -> Nothing + Just EQ + | isIncluding ar || isIncluding bl -> ok + | otherwise -> Nothing + Just GT -> ok + Nothing -> ok + where + ok = Just (I al (maxPointRight ar br)) + +inBoth :: Ord a => Interval a -> Interval a -> Interval a +inBoth _ Empty = Empty +inBoth Empty _ = Empty +inBoth (I al ar) (I bl br) = makeInterval (maxPointLeft al bl) (minPointRight ar br) + +minPointLeft, minPointRight, maxPointLeft, maxPointRight + :: Ord a => Endpoint a -> Endpoint a -> Endpoint a +minPointLeft = compareEndpoint True True +minPointRight = compareEndpoint True False +maxPointLeft = compareEndpoint False False +maxPointRight = compareEndpoint False True + +compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a +compareEndpoint b1 b2 a b = + case liftM2 compare (getPoint a) (getPoint b) of + Just LT -> x + Just EQ | p a -> x + | otherwise -> y + Just GT -> y + Nothing | b2 -> Unbounded + | x==Unbounded -> y + | otherwise -> x + where + p = if b1==b2 then isIncluding else isExcluding + (x, y) = if b1 then (a, b) else (b, a) + +--------------------------------------------------------------------- +-- QuickCheck + +instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where + arbitrary = frequency + [ (2, liftM Excluding arbitrary) + , (2, liftM Including arbitrary) + , (1, return Unbounded) + ] +instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where + coarbitrary (Excluding a) = variant 0 . coarbitrary a + coarbitrary (Including a) = variant 1 . coarbitrary a + coarbitrary Unbounded = variant 2 + +instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where + arbitrary = frequency + [ (1, return Empty) + , (5, liftM2 makeInterval arbitrary arbitrary) + ] +instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where + coarbitrary Empty = variant 0 + coarbitrary (I a b) = variant 1 . coarbitrary a . coarbitrary b + +instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where + arbitrary = do + n <- choose (0, 100) + xs <- replicateM n arbitrary + return (fromList xs) +instance (CoArbitrary a, Ord a) => CoArbitrary (Intervals a) where + coarbitrary (IS xs) = coarbitrary xs + +testMe :: IO () +testMe = do + putStrLn "** Intervals" + -- Constructor functions + quickCheck $ op0 empty (const False) + quickCheck $ op0 unbounded (const True) + + quickCheck $ op1 greaterThan (>) + quickCheck $ op1 greaterThanOrEqualTo (>=) + quickCheck $ op1 lessThan (<) + quickCheck $ op1 lessThanOrEqualTo (<=) + quickCheck $ op1 singleton (==) + + quickCheck $ op2 open (<) (<) + quickCheck $ op2 closed (<=) (<=) + quickCheck $ op2 leftOpen (<) (<=) + quickCheck $ op2 rightOpen (<=) (<) + + -- From/to lists + quickCheck fromTo1 + quickCheck fromTo2 + + -- Combinators + quickCheck defExcept + quickCheck defUnion + quickCheck defIntersect + quickCheck defComplement + + -- Combinator properties + quickCheck $ selfInverse complement + quickCheck $ transitive union + quickCheck $ commutative union + quickCheck $ absorption union + quickCheck $ transitive intersect + quickCheck $ commutative intersect + quickCheck $ absorption intersect + +fromTo1, fromTo2 :: Intervals Int -> Bool +fromTo1 a = fromList (toList a) == a +fromTo2 a = fromList (reverse (toList a)) == a + +defExcept :: Int -> Int -> Bool +defExcept a b = isIn a (except b) == (a/=b) + +defUnion, defIntersect :: Int -> Intervals Int -> Intervals Int -> Bool +defUnion a b c = isIn a (b `union` c) == (isIn a b || isIn a c) +defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c) + +defComplement :: Int -> Intervals Int -> Bool +defComplement a b = isIn a (complement b) == not (isIn a b) + +op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool +op0 g p a = isInInterval a g == p a + +op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool +op1 g op a b = isInInterval a (g b) == (a `op` b) + +op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool +op2 g opl opr a b c = isInInterval a (g b c) == (b `opl` a && a `opr` c) + +transitive :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Intervals Int -> Bool +transitive op a b c = op a (op b c) == op (op a b) c + +commutative :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Bool +commutative op a b = op a b == op b a + +absorption :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Bool +absorption op a = op a a == a + +selfInverse :: (Intervals Int -> Intervals Int) -> Intervals Int -> Bool +selfInverse op a = op (op a) == a diff --git a/src/Domain/Math/Data/OrList.hs b/src/Domain/Math/Data/OrList.hs --- a/src/Domain/Math/Data/OrList.hs +++ b/src/Domain/Math/Data/OrList.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,10 +14,15 @@ , orList, (\/), true, false , isTrue, isFalse , disjunctions, normalize, idempotent + , orView ) where +import Common.View import Control.Monad import Common.Traversable +import Common.Rewriting.Term +import qualified Domain.Logic.Formula as Logic +import Domain.Logic.Formula (Logic((:||:))) import Test.QuickCheck import Data.List (intersperse, nub, sort) @@ -96,11 +101,16 @@ rec (x:xs) = liftM (\/ orList xs) (f x) `mplus` liftM (return x \/) (rec xs) +instance IsTerm a => IsTerm (OrList a) where + toTerm = toTerm . build orView + fromTerm expr = fromTerm expr >>= matchM orView + instance Arbitrary a => Arbitrary (OrList a) where arbitrary = do n <- choose (1, 3) xs <- vector n return (OrList xs) +instance CoArbitrary a => CoArbitrary (OrList a) where coarbitrary T = variant 0 coarbitrary (OrList xs) = variant 1 . coarbitrary xs @@ -109,3 +119,20 @@ show (OrList xs) | null xs = "false" | otherwise = unwords (intersperse "or" (map show xs)) + +------------------------------------------------------------ +-- View to the logic data type + +orView :: View (Logic a) (OrList a) +orView = makeView f g + where + f p = case p of + Logic.Var a -> return (return a) + Logic.T -> return true + Logic.F -> return false + a :||: b -> liftM2 (\/) (f a) (f b) + _ -> Nothing + g xs = case disjunctions xs of + Nothing -> Logic.T + Just [] -> Logic.F + Just ys -> foldr1 (:||:) (map Logic.Var ys) diff --git a/src/Domain/Math/Data/Polynomial.hs b/src/Domain/Math/Data/Polynomial.hs --- a/src/Domain/Math/Data/Polynomial.hs +++ b/src/Domain/Math/Data/Polynomial.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -143,8 +143,12 @@ -- polynomial division, no remainder division :: Fractional a => Polynomial a -> Polynomial a -> Maybe (Polynomial a) -division p1 p2 = if b==0 then return a else Nothing - where (a, b) = longDivision p1 p2 +division p1 p2 + | degree p1 < degree p2 = Nothing + | b==0 = return a + | otherwise = Nothing + where + (a, b) = longDivision p1 p2 -- polynomial long division longDivision :: Fractional a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) @@ -155,7 +159,7 @@ monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) monicLongDivision p1 p2 | d1 >= d2 && isMonic p2 = (toP quot, toP rem) - | otherwise = error "invalid monic division" + | otherwise = error $ "invalid monic division" ++ show (p1, p2) where d1 = degree p1 d2 = degree p2 diff --git a/src/Domain/Math/Data/PrimeFactors.hs b/src/Domain/Math/Data/PrimeFactors.hs --- a/src/Domain/Math/Data/PrimeFactors.hs +++ b/src/Domain/Math/Data/PrimeFactors.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -64,6 +64,7 @@ primes = take 1000 $ rec [2..] where rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) + rec [] = error "PrimeFactors: empty list" ------------------------------------------------------------- -- Type class instances diff --git a/src/Domain/Math/Data/Relation.hs b/src/Domain/Math/Data/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/Relation.hs @@ -0,0 +1,280 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Mathematical relations +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.Relation + ( -- * Type class + Relational(..), mapLeft, mapRight, updateLeft, updateRight + -- * Relation data type + , Relation, relationType, RelationType(..), relationSymbols + -- * Constructor functions + , makeType, (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) + -- * Equation (or equality) + , Equations, Equation(..), equationView + -- * Inequality + , Inequality(..), inequalityView + ) where + +import Common.View +import Common.Rewriting (IsTerm(..), Rewrite) +import Common.Traversable +import Domain.Math.Expr.Symbolic +import qualified Text.OpenMath.Dictionary.Relation1 as Relation1 +import Data.Maybe +import Test.QuickCheck +import Control.Monad + +----------------------------------------------------------------------------- +-- Type class for relations + +class Functor f => Relational f where + leftHandSide :: f a -> a + rightHandSide :: f a -> a + flipSides :: f a -> f a -- possibly also flips operator + constructor :: f a -> (b -> b -> f b) + isSymmetric :: f a -> Bool + -- default definitions + isSymmetric _ = False + +mapLeft, mapRight :: Relational f => (a -> a) -> f a -> f a +mapLeft f p = updateLeft (f (leftHandSide p)) p +mapRight f p = updateRight (f (rightHandSide p)) p + +updateLeft, updateRight :: Relational f => a -> f a -> f a +updateLeft a p = constructor p a (rightHandSide p) +updateRight a p = constructor p (leftHandSide p) a + +----------------------------------------------------------------------------- +-- Relation data type + +data Relation a = R { lhs :: a, relationType :: RelationType, rhs :: a } + deriving (Eq, Ord) + +-- Corresponds exactly to the symbols in the relation1 OpenMath dictionary +data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan + | LessThanOrEqualTo | GreaterThanOrEqualTo | Approximately + deriving (Show, Eq, Ord, Enum) + +instance Show a => Show (Relation a) where + show r = unwords [show (lhs r), showRelType (relationType r), show (rhs r)] + +instance Functor Relation where + fmap f (R x rt y) = R (f x) rt (f y) + +instance Relational Relation where + leftHandSide = lhs + rightHandSide = rhs + flipSides (R x rt y) = R y (flipRelType rt) x + constructor (R _ rt _) x y = R x rt y + isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType + +instance IsTerm a => IsTerm (Relation a) where + toTerm p = + let op = relationType p + sym = maybe (toSymbol (show op)) snd (lookup op relationSymbols) + in binary sym (toTerm (leftHandSide p)) (toTerm (rightHandSide p)) + fromTerm a = + let f (relType, (_, s)) = do + (e1, e2) <- isBinary s a + liftM2 (makeType relType) (fromTerm e1) (fromTerm e2) + in msum (map f relationSymbols) + +instance Rewrite a => Rewrite (Relation a) + +relationSymbols :: [(RelationType, (String, Symbol))] +relationSymbols = + [ (EqualTo, ("==", eqSymbol)), (NotEqualTo, ("/=", neqSymbol)) + , (LessThan, ("<", ltSymbol)), (GreaterThan, (">", gtSymbol)) + , (LessThanOrEqualTo, ("<=", leqSymbol)) + , (GreaterThanOrEqualTo, (">=", geqSymbol)) + , (Approximately, ("~=", approxSymbol)) + ] + +-- helpers +showRelType :: RelationType -> String +showRelType = fst . (? relationSymbols) + +flipRelType :: RelationType -> RelationType +flipRelType relType = fromMaybe relType (lookup relType table) + where + table = pairs ++ map (\(a,b) -> (b,a)) pairs + pairs = [(LessThan, GreaterThan), (LessThanOrEqualTo, GreaterThanOrEqualTo)] + +(?) :: Eq a => a -> [(a, b)] -> b +a ? xs = fromMaybe (error "Relation: Error in lookup") (lookup a xs) + +----------------------------------------------------------------------------- +-- Traversable instance declarations + +instance Once Relation where onceM = onceMRelation +instance Switch Relation where switch = switchRelation +instance Crush Relation where crush = crushRelation + +switchRelation :: (Relational f, Monad m) => f (m a) -> m (f a) +switchRelation p = + liftM2 (constructor p) (leftHandSide p) (rightHandSide p) + +onceMRelation :: (Relational f, MonadPlus m) => (a -> m a) -> f a -> m (f a) +onceMRelation f p = + liftM (`updateLeft` p) (f (leftHandSide p)) `mplus` + liftM (`updateRight` p) (f (rightHandSide p)) + +crushRelation :: Relational f => f a -> [a] +crushRelation p = [leftHandSide p, rightHandSide p] + +----------------------------------------------------------------------------- +-- QuickCheck generators + +instance Arbitrary a => Arbitrary (Relation a) where + arbitrary = liftM3 R arbitrary arbitrary arbitrary +instance CoArbitrary a => CoArbitrary (Relation a) where + coarbitrary p = coarbitrary (relationType p) . coarbitrary (crush p) + +instance Arbitrary RelationType where + arbitrary = oneof $ map return [EqualTo .. Approximately] +instance CoArbitrary RelationType where + coarbitrary op = variant (fromEnum op) + +----------------------------------------------------------------------------- +-- Constructor functions + +infix 1 .==., ./=., .<., .>., .<=., .>=., .~=. + +(.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) :: a -> a -> Relation a +(.==.) = makeType EqualTo +(./=.) = makeType NotEqualTo +(.<.) = makeType LessThan +(.>.) = makeType GreaterThan +(.<=.) = makeType LessThanOrEqualTo +(.>=.) = makeType GreaterThanOrEqualTo +(.~=.) = makeType Approximately + +makeType :: RelationType -> a -> a -> Relation a +makeType = flip R + +----------------------------------------------------------------------------- +-- Equation data type (view on Relation) + +infix 1 :==: + +type Equations a = [Equation a] + +data Equation a = a :==: a + deriving (Eq, Ord) + +instance Show a => Show (Equation a) where + show = show . build equationView + +instance Functor Equation where + fmap f (x :==: y) = f x :==: f y + +instance Relational Equation where + leftHandSide = leftHandSide . build equationView + rightHandSide = rightHandSide . build equationView + flipSides = \(x :==: y) -> y :==: x + constructor = const (:==:) + isSymmetric = const True + +instance Once Equation where onceM = onceMRelation +instance Switch Equation where switch = switchRelation +instance Crush Equation where crush = crushRelation + +instance Arbitrary a => Arbitrary (Equation a) where + arbitrary = liftM2 (:==:) arbitrary arbitrary +instance CoArbitrary a => CoArbitrary (Equation a) where + coarbitrary = coarbitrary . build equationView + +instance IsTerm a => IsTerm (Equation a) where + toTerm = toTerm . build equationView + fromTerm a = fromTerm a >>= matchM equationView + +instance Rewrite a => Rewrite (Equation a) + +equationView :: View (Relation a) (Equation a) +equationView = makeView f g + where + f (R x op y) + | op == EqualTo = return (x :==: y) + | otherwise = Nothing + g (x :==: y) = x .==. y + +----------------------------------------------------------------------------- +-- Inequality (view on Relation) + +infix 1 :<:, :>:, :<=:, :>=: + +data Inequality a = a :<: a | a :>: a | a :<=: a | a :>=: a + +instance Show a => Show (Inequality a) where + show = show . build inequalityView + +instance Functor Inequality where + fmap f ineq = + let a = leftHandSide ineq + b = rightHandSide ineq + in constructor ineq (f a) (f b) + +instance Relational Inequality where + leftHandSide = leftHandSide . build inequalityView + rightHandSide = rightHandSide . build inequalityView + flipSides = fromMaybe (error "inequality: flipSides") . matchM inequalityView + . flipSides . build inequalityView + constructor ineq = + let relType = relationType (build inequalityView ineq) + in fst (relType ? inequalityTable) + +instance Once Inequality where onceM = onceMRelation +instance Switch Inequality where switch = switchRelation +instance Crush Inequality where crush = crushRelation + +instance Arbitrary a => Arbitrary (Inequality a) where + arbitrary = do + op <- oneof $ map (return . fst . snd) inequalityTable + liftM2 op arbitrary arbitrary +instance CoArbitrary a => CoArbitrary (Inequality a) where + coarbitrary = coarbitrary . build inequalityView + +instance IsTerm a => IsTerm (Inequality a) where + toTerm = toTerm . build inequalityView + fromTerm a = fromTerm a >>= matchM inequalityView + +instance Rewrite a => Rewrite (Inequality a) + +inequalityView :: View (Relation a) (Inequality a) +inequalityView = makeView f g + where + f (R x op y) = fmap (\pair -> fst pair x y) (lookup op inequalityTable) + g ineq = + case ineq of + x :<: y -> x .<. y + x :>: y -> x .>. y + x :<=: y -> x .<=. y + x :>=: y -> x .>=. y + +inequalityTable :: [(RelationType, (a -> a -> Inequality a, a -> a -> Relation a))] +inequalityTable = + [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.))) + , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.))) + ] + +----------------------------------------------------------------------------- +-- OpenMath symbols + +eqSymbol, ltSymbol, gtSymbol, neqSymbol, leqSymbol, + geqSymbol, approxSymbol :: Symbol +eqSymbol = toSymbol Relation1.eqSymbol +ltSymbol = toSymbol Relation1.ltSymbol +gtSymbol = toSymbol Relation1.gtSymbol +neqSymbol = toSymbol Relation1.neqSymbol +leqSymbol = toSymbol Relation1.leqSymbol +geqSymbol = toSymbol Relation1.geqSymbol +approxSymbol = toSymbol Relation1.approxSymbol diff --git a/src/Domain/Math/Data/SquareRoot.hs b/src/Domain/Math/Data/SquareRoot.hs --- a/src/Domain/Math/Data/SquareRoot.hs +++ b/src/Domain/Math/Data/SquareRoot.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Math/DerivativeExercise.hs b/src/Domain/Math/DerivativeExercise.hs --- a/src/Domain/Math/DerivativeExercise.hs +++ b/src/Domain/Math/DerivativeExercise.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-case-merge #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -17,14 +17,13 @@ import Domain.Math.DerivativeRules import Common.Strategy (Strategy, somewhere, (<*>), alternatives, label, LabeledStrategy, try) import qualified Common.Strategy +import Common.Navigator import Common.Context (Context, liftToContext) import Common.Exercise import Common.Transformation import Control.Monad import Domain.Math.Simplification import Domain.Math.Expr -import Domain.Math.Expr.Symbols -import Domain.Math.Expr.Parser derivativeExercise :: Exercise Expr derivativeExercise = makeExercise @@ -35,6 +34,7 @@ , isReady = noDiff , extraRules = map liftToContext derivativeRules ++ [tidyup] , strategy = derivativeStrategy + , navigation = navigator , examples = [ex1, ex2, ex3, ex4] } diff --git a/src/Domain/Math/DerivativeRules.hs b/src/Domain/Math/DerivativeRules.hs --- a/src/Domain/Math/DerivativeRules.hs +++ b/src/Domain/Math/DerivativeRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,8 +14,6 @@ import Prelude hiding ((^)) import Common.Transformation import Domain.Math.Expr -import Domain.Math.Expr.Symbolic -import Domain.Math.Expr.Symbols import Common.Rewriting derivativeRules :: [Rule Expr] diff --git a/src/Domain/Math/Equation/CoverUpExercise.hs b/src/Domain/Math/Equation/CoverUpExercise.hs --- a/src/Domain/Math/Equation/CoverUpExercise.hs +++ b/src/Domain/Math/Equation/CoverUpExercise.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -19,7 +19,7 @@ import Common.View import Control.Monad import Data.Ratio -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Equation.CoverUpRules import Domain.Math.Equation.Views @@ -36,10 +36,10 @@ { description = "solve an equation by covering up" , exerciseCode = makeCode "math" "coverup" , status = Provisional - , parser = parseWith (pOrList (pEquation pExpr)) + , parser = parseExprWith (pOrList (pEquation pExpr)) , equivalence = \_ _ -> True , isReady = solvedEquations - , extraRules = map ignoreContext coverUpRulesOr + , extraRules = map liftToContext coverUpRulesOr , strategy = coverUpStrategy , examples = map (orList . return) (concat (fillInResult ++ coverUpEquations)) } @@ -49,7 +49,7 @@ coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) coverUpStrategy = label "Cover-up" $ - repeat (alternatives $ map (ignoreContext . cleanUp) coverUpRulesOr) + repeat (alternatives $ map (liftToContext . cleanUp) coverUpRulesOr) cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr)) cleanUp = doAfter $ fmap $ fmap cleanUpExpr diff --git a/src/Domain/Math/Equation/CoverUpRules.hs b/src/Domain/Math/Equation/CoverUpRules.hs --- a/src/Domain/Math/Equation/CoverUpRules.hs +++ b/src/Domain/Math/Equation/CoverUpRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -20,24 +20,25 @@ , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith + -- temporarily exported + , coverUpBinaryRule, commOp, flipOp ) where import Common.View import Domain.Math.Expr -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Control.Monad.Identity import Common.Transformation -import Domain.Math.Expr.Symbols import Domain.Math.Data.OrList import Common.Traversable -import Domain.Math.Expr.Symbolic --------------------------------------------------------------------- -- Constructors for cover-up rules -coverUpBinary2Rule :: (OnceJoin f, Switch f) => String -> (Expr -> [(Expr, Expr)]) +coverUpBinary2Rule :: (OnceJoin f, Switch f, Relational r) + => String -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> [f Expr]) - -> ConfigCoverUp -> Rule (f (Equation Expr)) + -> ConfigCoverUp -> Rule (f (r Expr)) coverUpBinary2Rule opName fm fb cfg = makeSimpleRuleList name $ onceJoinM $ \eq -> (guard (coverLHS cfg) >> coverLeft eq) ++ @@ -46,22 +47,23 @@ name = coverUpRuleName opName (configName cfg) coverRight = map (fmap flipSides) . coverLeft . flipSides - coverLeft (lhs :==: rhs) = do - (e1, e2) <- fm lhs + coverLeft eq = do + (e1, e2) <- fm (leftHandSide eq) guard (predicateCovered cfg e1) - new <- fb rhs e2 + new <- fb (rightHandSide eq) e2 switch $ fmap (guard . predicateCombined cfg) new - return (fmap (e1 :==:) new) + return (fmap (constructor eq e1) new) -coverUpBinaryRule :: String -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) - -> ConfigCoverUp -> Rule (Equation Expr) +coverUpBinaryRule :: Relational r => String + -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) + -> ConfigCoverUp -> Rule (r Expr) coverUpBinaryRule opName fm fb = - let lp = makeLiftPair (return . Identity) (const . runIdentity) + let v = makeView (return . Identity) runIdentity fbi x y = [Identity (fb x y)] - in lift lp . coverUpBinary2Rule opName fm fbi + in liftRule v . coverUpBinary2Rule opName fm fbi -coverUpUnaryRule :: String -> (Expr -> [Expr]) -> (Expr -> Expr) - -> ConfigCoverUp -> Rule (Equation Expr) +coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr) + -> ConfigCoverUp -> Rule (r Expr) coverUpUnaryRule opName fm fb = coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb) @@ -106,8 +108,8 @@ fb rhs e2 = do n <- isNat e2 guard (n > 0) - new1 <- canonicalM identity (makeRoot n rhs) - new2 <- canonicalM identity (negate (makeRoot n rhs)) + let new1 = root rhs (fromIntegral n) + new2 = (neg new1) return $ orList $ new1 : [ new2 | new1 /= new2, even n ] coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr) @@ -183,9 +185,3 @@ isNat :: MonadPlus m => Expr -> m Integer isNat (Nat n) = return n isNat _ = mzero - -makeRoot :: Integer -> Expr -> Expr -makeRoot n a - | n == 1 = a - | n == 2 = sqrt a - | otherwise = root (fromInteger n) a diff --git a/src/Domain/Math/Equation/Views.hs b/src/Domain/Math/Equation/Views.hs --- a/src/Domain/Math/Equation/Views.hs +++ b/src/Domain/Math/Equation/Views.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,13 +10,35 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Equation.Views - ( equationSolvedForm, solvedEquation, solvedEquations ) where + ( solvedRelations, solvedRelation + , equationSolvedForm, solvedEquation, solvedEquations + , solvedRelationWith + ) where import Domain.Math.Expr import Domain.Math.Data.OrList -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Common.View import Common.Traversable + +-- generalized to relation +solvedRelations :: (Crush f, Relational g) => f (g Expr) -> Bool +solvedRelations = all solvedRelation . crush + +-- The variable may appear on one of the sides of the relation (right-hand side +-- is thus allowed), but must be isolated +solvedRelation :: Relational f => f Expr -> Bool +solvedRelation r = + case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of + (Just _, Just _) -> False + (Just x, Nothing) -> x `notElem` collectVars (rightHandSide r) + (Nothing, Just x) -> x `notElem` collectVars (leftHandSide r) + _ -> noVars (leftHandSide r) && noVars (rightHandSide r) + +-- The variable must appear on the left +solvedRelationWith :: Relational f => (Expr -> Bool) -> f Expr -> Bool +solvedRelationWith p r = + isVariable (leftHandSide r) && p (rightHandSide r) ------------------------------------------------------------- -- Views on equations diff --git a/src/Domain/Math/Examples/DWO1.hs b/src/Domain/Math/Examples/DWO1.hs --- a/src/Domain/Math/Examples/DWO1.hs +++ b/src/Domain/Math/Examples/DWO1.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,16 +14,14 @@ module Domain.Math.Examples.DWO1 ( calculateResults, fillInResult , coverUpEquations, linearEquations - , quadraticEquations, higherDegreeEquations + , quadraticEquations, findFactors , modulusEquations, sqrtEquations, sqrtSubstEquations, brokenEquations , simplerSqrt, simplerSqrt2, simplerSqrt3 ) where import Prelude hiding ((^)) -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Expr -import Domain.Math.Expr.Symbolic -import Domain.Math.Expr.Symbols calculateResults :: [[Expr]] calculateResults = [level1, level2, level3] @@ -296,21 +294,23 @@ , (1-x)^2 :==: x+2 ] -higherDegreeEquations :: [Equation Expr] -higherDegreeEquations = +-- Ontbinden in factoren (VWO B, hoofdstuk 1) +findFactors :: [[Expr]] +findFactors = let x = variable "x" in - [ x^3 + x^2 :==: 0 - , x^3 - 5*x :==: 0 - , x^3 - 11*x^2 + 18*x :==: 0 - , x^3 + 36*x :==: 13*x^2 - , x^3 + 2*x^2 :==: 24*x - , 7*x^3 :==: 8*x^2 - , x^4 :==: 9*x^2 - , 64*x^7 :==: x^5 - , x^3 - 4*x^2 - 9*x :==: 0 - , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2 + [ -- (buiten haakjes brengen) + [ 4*x^2 -4*x + , 36*x^2+30*x + , -6*x^2-18*x + , 14*x^2-10*x + ] --(product-som methode) + , [ x^2+11*x+24 + , x^2-8*x+15 + , x^2-x-2 + , x^2-11*x+28 + ] ] - + modulusEquations :: [[Equation Expr]] modulusEquations = let x = variable "x" in diff --git a/src/Domain/Math/Examples/DWO2.hs b/src/Domain/Math/Examples/DWO2.hs --- a/src/Domain/Math/Examples/DWO2.hs +++ b/src/Domain/Math/Examples/DWO2.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,17 +15,31 @@ import Prelude hiding ((^)) import Domain.Math.Expr -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation -data InEq a = a :<: a | a :>: a +-------------------------------------------------------------------- +-- Algemene applet -infix 1 :<:, :>: +higherDegreeEquations :: [Equation Expr] +higherDegreeEquations = + let x = variable "x" in + [ x^3 + x^2 :==: 0 + , x^3 - 5*x :==: 0 + , x^3 - 11*x^2 + 18*x :==: 0 + , x^3 + 36*x :==: 13*x^2 + , x^3 + 2*x^2 :==: 24*x + , 7*x^3 :==: 8*x^2 + , x^4 :==: 9*x^2 + , 64*x^7 :==: x^5 + , x^3 - 4*x^2 - 9*x :==: 0 + , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2 + ] -------------------------------------------------------------------- -- Havo applets -- Havo B Voorkennis: lineaire ongelijkheden -ineqLin1 :: [[InEq Expr]] +ineqLin1 :: [[Inequality Expr]] ineqLin1 = let a = Var "a" in let x = Var "x" in @@ -49,8 +63,8 @@ -- Havo B Voorkennis: kwadratische ongelijkheden -- (door eerst gelijkheid op te lossen) -- (level 2 uit Hoofdstuk 3) -ineqKwad1 :: [[InEq Expr]] -ineqKwad1 = +ineqQuad1 :: [[Inequality Expr]] +ineqQuad1 = let x = Var "x" in [ [ x^2 +3*x-4 :<: 0 , x^2-4*x-12 :>: 0 @@ -70,7 +84,7 @@ -- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact -- (door eerst gelijkheid op te lossen) -ineqHigh :: [InEq Expr] +ineqHigh :: [Inequality Expr] ineqHigh = let x = Var "x" in [ 2*x^3 :>: 54 @@ -111,8 +125,8 @@ -- VWO A/C applets -- hoofdstuk 2 -ineqKwad2 :: [InEq Expr] -ineqKwad2 = +ineqQuad2 :: [Inequality Expr] +ineqQuad2 = let x = Var "x" in [ x^2 + 9*x :<: 3*x - 5 , x^2 - x :>: 12 @@ -209,3 +223,13 @@ , 4*x^6 + 2 :==: -9*x^3 ] ] + +-------------------------------------------------------------------- +-- Extra test cases + +extraIneqQuad :: [Inequality Expr] +extraIneqQuad = + let x = Var "x" in + [ x^2-x-7 :>: -100, x^2-x-7 :<: -100, x^2 :<: x^2, x :>=: x + , x^2 :>=: 0, x^2 :>: 0, x^2 :<: 0, x^2 :<=: 0 + ] diff --git a/src/Domain/Math/Examples/DWO3.hs b/src/Domain/Math/Examples/DWO3.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Examples/DWO3.hs @@ -0,0 +1,481 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Examples.DWO3 where + +import Prelude hiding ((^)) +import Domain.Math.Expr + +---------------------------------------------------------- +-- HAVO B applets + +simplerPowers :: [[Expr]] +simplerPowers = [level1, level2, level3, level4] + where + a = variable "a" + b = variable "b" + level1 = + [ 4*a^3 * 5*a^2 + , 14*a^6 / (-2*a^3) + , -21*a^7 / (3*a) + , 5*a * (-3)*a^2 * 2*a^3 + ] + + level2 = + [ a^2 * (-2*a)^3 + , (2*a)^5 / (-4*a)^2 + , (2*a)^4 * (-3)*a^2 + , (-3*a)^4 / (9*a^2) + ] + + level3 = + [ (a^2 * b^3)^7 + , -a^3 * (2*b)^5 * a^2 + , 3*a * (-2*b)^3 * (-a*b)^2 + , (2*a*b^3)^2 * (-3*a^2*b)^3 + ] + + level4 = + [ ((1/2)*a)^3 - (4*a)^2 * (1/4)*a + , (2*a)^5 + ((1/3)*a)^2 * (-3*a)^3 + , (2*a^3)^4 - 6*a^3 * (-a^3)^3 + , (-2*a^3)^2 - 6*(3*a)^2 * (-4*a^4) + ] + +powersOfA :: [[Expr]] +powersOfA = [level1, level2, level3, level4] + where + a = variable "a" + level1 = + [ a^3 * a^(-4) + , a^4 * (1/a^2) + , a^(-1) * a^5 + , (1/a^3) * a + ] + + level2 = + [ (a^(-2))^3 + , (a^(-3))^4 + , (1/a^6) * a^(-2) + , (1/a^2) * (1/a^4) + ] + + level3 = + [ (a^(-2))^3 * (1/a^4) + , (1/a^3)^2 + , (a^3)^2 * (1/a) + , (a^(-2))^(-3) * a^(-4) + ] + + level4 = + [ (a^(-1))^2 / a^3 + , (a^2)^(-3) / a^(-1) + , ((a^(-2))^4 / (a^2)^3) * a + , (1/a^(-3))^4 * (1/a)^3 + ] + +nonNegExp :: [[Expr]] +nonNegExp = [level1, level2] + where + a = variable "a" + b = variable "b" + level1 = + [ a * b^(-2) + , a^(-1) * b^2 + , a^(-2) * b^(-3) + , (1/a^(-3)) * (b^(-2))^2 + ] + + level2 = + [ (1/(a*b)^(-2)) * a * b^(-1) + , (2*a)^(-1) / (4*b)^(-2) + , (4*a*b)^(-1) * (b^2)^(-3) + , (5*a)^(-2) * 10*b^(-1) + ] + +-- schrijf als een macht van x +powersOfX :: [[Expr]] +powersOfX = + [ [root x 3, 1/root x 4, sqrt (1/x), (x^2) / (root (x^2) 5)] + , [sqrt x/(x^2), root (x/(x^3)) 3, x*root x 3, root x 3 * root (1/(x^2)) 4] + ] + where + x = Var "x" + +-- Schrijf zonder negatieve of gebroken exponenten +nonNegExp2 :: [[Expr]] +nonNegExp2 = + [ [ 4^(1/3), 5^(-(1/4)), 5*a^(1/2), 3*a^(-(1/4))] + , [ 4/(a^(-1)*b^(1/3)), a^(-1)/(8*b^(-(2/3))) + , 1/(3*a^(2/5)*b^(-1)), 3*a^(1/4)*b^(-(1/2)) + ] + ] + where + a = Var "a" + b = Var "b" + +---------------------------------------------------------- +-- VWO A/C applets + +-- herleid +powers1 :: [[Expr]] +powers1 = + [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7 + , 2*a^4*5*a^3, 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a + ] + , [ 5*a^4*(1/a), 8*a^4*(1/2*a^2), 2*a^6*(6/a^4), a^2*(8/a) + , (4*a^3)/(a^5), a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3) + ] + , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3 + , (-a^6)^5, (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4 + ] + , [ 6*a^5+7*a^5-4*a^9, 8*a^2-4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2 + , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7 + , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3 + ] + , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2 + , 6*a^7*(2*a^4)^3, a^17/((a^3)^5), a^9/((a^3)^2) + , a^14/((a^2)^4), a^16/((a^5)^3) + ] + ] + where + a = Var "a" + +-- herleid +powers2 :: [[Expr]] +powers2 = + [ [ 4*a^3*5*a^2, (14*a^6)/(-2*a^3), (-21*a^7)/(3*a) + , 5*a*(-3*a^2)*(2*a^3) + ] + , [ a^2*(-2*a)^3, (2*a)^5/(-4*a)^2 + , (2*a)^4*(-3*(a^2)), (-3*a)^4/(9*a^2) + ] + , [ (a^2*b^3)^7, (-a)^3*(2*b)^5*a^2 + , 3*a*(-2*b)^3*(-a*b)^2, (2*a*b^3)^2*(-3*a^2*b)^3 + ] + , [ (2*a^3)^4-6*a^3*(-a^3)^3, (-2*a^3)^2-6*(3*a)^2*(-4*a^4) + ] + ] + where + a = Var "a" + b = Var "b" + +negExp1 :: [[Expr]] +negExp1 = + [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5 + , (1/a^3)/a, a/a^7, (1/a^2)/a + ] + , [ (1/(a^4))/a^6, (1/(a^3))/a^5, (1/a^5)/a^2, 1/(a^4)/a^3 + , 1/a^3, 1/a^5, 1/a^(-4), 1/a^(-6) + ] + , [ a^8/(1/a^2), a^4/(1/a^4), (a^6)/(1/a^5), a^3/(1/a^6) + , 1/(a^3)/a^(-2), (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8) + ] + ] + where + a = Var "a" + +negExp2 :: [[Expr]] +negExp2 = + [ [ a^3*a^(-4), a^4*(1/a^2), a^(-1)*a^5, (1/a^3)*a] + , [ (a^(-2))^3,(a^(-3))^4, (1/a^6)*a^(-2), (1/a^2)*(1/a^4)] + , [ (a^(-2))^3*(1/a^4), (1/a^3)^2, (a^3)^2*(1/a), (a^(-2))^(-3)*a^(-4)] + , [ (a^(-1))^2/a^3, (a^2)^(-3)/a^(-1), ((a^(-2))^4/(a^2)^3)*a + , (1/a^(-3))^4*(1/a)^3 + ] + ] + where + a = Var "a" + +negExp3 :: [[Expr]] +negExp3 = + [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5) + , (1/4)^(-3), (1/7)^(-2), (1/2)^(-4), (1/3)^(-4) + ] + , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1) + , 5*3^(-2), 7*2^(-5), 6*5^(-2), 4*7^(-2) + ] + , [ (1/3)/(6^(-2)), (1/2)/(8^(-2)), (1/8)/4^(-2), (1/10)/5^(-2) -- original in negExp5 + , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3) + ] + ] + +negExp4 :: [[Expr]] +negExp4 = + [ [ a*b^(-2), a^(-1)*b^2, a^(-2)*b^(-3), (1/a^(-3))*(b^(-2))^2] + , [ (1/((a*b)^(-2)))*a*b^(-1), (2*a)^(-1)/(4*b)^(-2) + , (4*a*b)^(-1)*(b^2)^(-3), (5*a)^(-2) * 10*b^(-1) + ] + ] + where + a = Var "a" + b = Var "b" + +negExp5 :: [[Expr]] +negExp5 = + [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3) + , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3) + ] + , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7) + , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2) + ] + , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5) + , 9*a^(-7)*(2*b)^(-4), (a^5) / ((2*b)^(-2)), ((2*a)^(-3))/b^2 + , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4) + ] + ] + where + a = Var "a" + b = Var "b" + +brokenExp1, brokenExp1' :: [[Expr]] +brokenExp1 = + [ [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5) + , 4*a^(2/3), 2*a^(3/4), 3*a^(2/5), 4*a^(3/5) + ] + , [ 6*a^(-(1/2)), 4*a^(-(1/3)), 2*(3*a)^(-(1/4)), (3*a)^(-(1/5)) + , 5*a^(-(2/3)), 7*a^(-(3/4)), 6*a^(-(2/5)), 2*a^(-(3/7)) + ] + , [ (1/2)*a^(1/3)*b^(-(1/2)), (1/7)*a^(-(1/4))*b^(2/3), 4*a^(1/2)*b^(-(1/5)) + , 3*a^(-(3/5))*b^(1/3), (2*a)^(-(2/3)), (6*a)^(-(2/5)) + , (3*a)^(-(3/5)), (2*a)^(-(4/7)) + ] + ] + where + a = Var "a" + b = Var "b" + +brokenExp1' = + [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7 + , a*root (a^2) 3, a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6 + ] + , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3) + , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3) + ] + ] + where + a = Var "a" + +brokenExp2 :: [[Expr]] +brokenExp2 = + [ [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5 + , sqrt (a^6), root (a^6) 3, sqrt (a^4), root (a^9) 3 + ] + , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a/(1/a^2) + , root a 3/(1/a^5), (a^2*sqrt a)/(a*root a 3) + , (a^3*sqrt a)/(a^2*root (a^2) 3), (a^2*root a 5)/(a^3*root a 3) + , (a^4*root a 3)/(a^6*sqrt a) + ] + ] + where + a = Var "a" + +brokenExp3 :: [[Expr]] +brokenExp3 = + [ [root x 3, 1/root x 4, sqrt (1/x), x^2/root (x^2) 5] + , [sqrt x/x^2, root (x/x^3) 3, x*root x 3, root x 3*root (1/x^2) 4] + ] + where + x = Var "x" + +---------------------------------------------------------- +-- VWO B applets (hoofdstuk 4) + +-- herleiden van wortelvormen +normSqrt1 :: [[Expr]] +normSqrt1 = + [ [ 9*sqrt 5 * 7*sqrt 3, 3*sqrt 2 * 2 * sqrt 5, 5*sqrt 2*6*sqrt 7 + , 4*sqrt 6 * 2*sqrt 7, 6*a*sqrt 3*9*sqrt 2, 5*sqrt 5 * 2 * a * sqrt 7 + , a*sqrt 6 * 7 * sqrt 5, 8*sqrt 7*a*sqrt 3 + ] + , [ sqrt 15/(6*sqrt 3), (5*sqrt 30)/sqrt 5, (4*sqrt 10)/(5*sqrt 2) + , (5*sqrt 21)/(2*sqrt 7), (6*a*sqrt 35)/(3*sqrt 5), (5*a*sqrt 14)/(9*sqrt 2) + , (a*sqrt 6)/(7*sqrt 3), (3*a*sqrt 42)/(7*sqrt 7) + ] + , [ 5/(2*sqrt 2), 2/(5*sqrt 3), 3/(2*sqrt 5), 8/(7*sqrt 6), (2*a)/(3*sqrt 7) + , (6*a)/(7*sqrt 10), (5*a)/(3*sqrt 11), (6*a)/(5*sqrt 13) + ] + , [ sqrt (2/3), sqrt (5+1/3), sqrt (1+1/2), sqrt (3+4/7), sqrt (5*a^2) + , sqrt (7*a^2), sqrt (3*a^2), sqrt (6*a^2) + ] + , [ sqrt ((2/9)*a^2), sqrt ((5/16)*a^2), sqrt ((3/25)*a^2), sqrt ((7/16)*a^2) + , ((1/3)*sqrt 2)^2, ((1/2)*sqrt 3)^2, ((2/7)*sqrt 5)^2, ((2/3)*sqrt 7)^2 + ] + ] + where + a = Var "a" + +normSqrt2 :: [[Expr]] +normSqrt2 = + [ [ ((1/7)*a*sqrt 2)^2, ((3/5)*a*sqrt 3)^2, ((1/3)*a*sqrt 5)^2 + , ((4/7)*a*sqrt 6)^2, sqrt 8 + sqrt 2, sqrt 2 + sqrt 18 + , sqrt 12 - sqrt 3, sqrt 7 - sqrt 28 + ] + , [ sqrt 12 + sqrt 48, sqrt 18 - sqrt 8, sqrt 45 - sqrt 20, sqrt 80 + sqrt 45 + , sqrt (50*a^2) - sqrt (32*a^2), sqrt (75*a^2) - sqrt (12*a^2) + , sqrt (27*a^2) + sqrt (3*a^2), sqrt (24*a^2) + sqrt (96*a^2) + ] + , [ sqrt 27 + 1/sqrt 3, sqrt 24 + 5/sqrt 6, sqrt 72 - 7/sqrt 2 + , sqrt 98 - 5/sqrt 2, sqrt 24 + sqrt (1+1/2), sqrt 40 - sqrt (2+1/2) + , sqrt 75 - sqrt (1+1/3), sqrt (1+2/3) + sqrt 60 + ] + ] + where + a = Var "a" + +normSqrt3 :: [[Expr]] +normSqrt3 = + [ [ (2*sqrt 7 + 7*sqrt 3)^2, (sqrt 2+6*sqrt 3)^2, (4*sqrt 3 + 3*sqrt 2)^2 + , (2*sqrt 5 + sqrt 7)^2, (3*sqrt 6-4*sqrt 5)^2, (5*sqrt 3 - sqrt 2)^2 + , (4*sqrt 6 - 2*sqrt 7)^2, (sqrt 5 - 2*sqrt 3)^2 + ] + , [ (2*sqrt 3 - 2)^2, (5*sqrt 2-1)^2, (3+4*sqrt 3)^2, (2+3*sqrt 6)^2 + , (4*sqrt 2 + 3)*(4*sqrt 2 - 3), (sqrt 7+sqrt 3)*(sqrt 7-sqrt 3) + , (2*sqrt 2 - sqrt 5)*(2*sqrt 2 + sqrt 5), (6-3*sqrt 3)*(6+3*sqrt 3) + ] + , [ (a-sqrt 3)^2, (2*sqrt 6+a)^2, (2*a+a*sqrt 5)^2, (a*sqrt 3 - 2*a*sqrt 2)^2 + , (a-sqrt 7)*(a+sqrt 7), (3*a+2*sqrt 3)*(3*a-2*sqrt 3) + , (2*a+a*sqrt 2)*(2*a-a*sqrt 2), (3*a*sqrt 5 - a)*(3*a*sqrt 5 + a) + ] + , [ 4/ (sqrt 2 + 2), 3/(sqrt 5 + 1), 2 / (sqrt 3 - 3), 5/(sqrt 6-2) + , 6/(sqrt 7+sqrt 5), 4/(2*sqrt 3 + sqrt 6), 5/(3*sqrt 2 - sqrt 3) + , 2 / (sqrt 11 - sqrt 2) + ] + , [ (2*sqrt 3)/(sqrt 5 + sqrt 2), (6*sqrt 5)/(sqrt 7+sqrt 3) + , (4*sqrt 3)/(sqrt 5 - sqrt 3), (8*sqrt 7)/(sqrt 6 - sqrt 5) + ] + ] + where + a = Var "a" + +-- Machten herleiden +normPower1 :: [[Expr]] +normPower1 = + [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7, 2*a^4*5*a^3 + , 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a + ] + , [ 5*a^4*(1/a), 8*a^4*(1/(2*a^2)), 2*a^6*(6/a^4), a^2*8/a + , (4*a^3)/a^5, a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3) + ] + , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3, (-(a^6))^5 + , (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4 + ] + , [ 6*a^5 + 7*a^5 - 4*a^9, 8*a^2 - 4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2 + , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7 + , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3 + ] + , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2, 6*a^7*(2*a^4)^3 + , a^17/(a^3)^5, a^9/(a^3)^2, a^14/(a^2)^4, a^16/(a^5)^3 + ] + ] + where + a = Var "a" + +normPower2 :: [[Expr]] +normPower2 = + [ -- one level only + [ (3*a)^3+4*a^3, (2*a^2)^3 +(4*a^3)^2, (-2*a^6)^2+(a^2)^6 + , (-3*a^2)^3+(4*a^3)^2, (4*a*b^2)^2, (2*a^2*b^3)^3 + , (3*a^2*b)^2, (-3*a^2*b^2)^4 + ] + ] + where + a = Var "a" + b = Var "b" + +normPower3, normPower3' :: [[Expr]] +normPower3 = + [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5, (1/a^3)/a, a/a^7, (1/a^2)/a + ] + , [ (1/a^4)/a^6, (1/a^3)/a^5, (1/a^5)/a^2, (1/a^4)/a^3, 1/a^3, 1/a^5 + , 1/a^(-4), 1/a^(-6) + ] + , [ a^8/(1/a^2), a^4/(1/a^4), a^6/(1/a^5), a^3/(1/a^6), (1/a^3)/a^(-2) + , (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8) + ] + ] + where + a = Var "a" +normPower3' = -- bereken zonder rekenmachine + [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5), (1/4)^(-3), (1/7)^(-2) + , (1/2)^(-4), (1/3)^(-4) + ] + , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1), 5*3^(-2), 7*2^(-5) + , 6*5^(-2), 4*7^(-2) + ] + ] + +normPower4, normPower4' :: [[Expr]] +normPower4 = + [ -- bereken zonder rekenmachine + [ (1/3)/6^(-2), (1/2)/8^(-2), (1/8)/4^(-2), (1/10)/5^(-2) + , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3) + ] + ] +normPower4' = -- schrijf zonder negatieve exponenten + [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3) + , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3) + ] + , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7) + , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2) + ] + , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5) + , 9*a^(-7)*(2*b)^(-4), a^5/(2*b)^(-2), (2*a)^(-3)/b^2 + , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4) + ] + ] + where + a = Var "a" + b = Var "b" + +normPower5, normPower5' :: [[Expr]] +normPower5 = + [ -- schrijf zonder negatieve en gebroken exponent + [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5), (4*a)^(2/3) + , 2*a^(3/4), (3*a)^(2/5), 4*a^(3/5) + ] + , [ 6*a^(-1/2), 4*a^(-1/3), 2*(3*a)^(-1/4), (3*a)^(-1/5), 5*a^(-2/3) + , 7*a^(-3/4), 6*a^(-2/5), 2*a^(-3/7) + ] + , [ (1/2)*a^(1/3)*b^(-1/2), (1/7)*a^(-1/4)*b^(2/3), 4*a^(1/2)*b^(-1/5) + , 3*a^(-3/5)*b^(1/3), (2*a)^(-2/3), (6*a)^(-2/5), (3*a)^(-3/5), (2*a)^(-4/7) + ] + ] + where + a = Var "a" + b = Var "b" +normPower5' = -- schrijf als macht van a + [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7, a*root (a^2) 3 + , a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6 + ] + , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3) + , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3) + ] + ] + where + a = Var "a" + +normPower6 :: [[Expr]] +normPower6 = + [ -- schrijf als macht van a + [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5, sqrt (a^6) + , root (a^6) 3, sqrt (a^4), root (a^9) 3 + ] + , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a / (1/a^2), root a 3/(1/a^5) + , (a^2*sqrt a)/(a*root a 3), (a^3*sqrt a)/(a^2*root (a^2) 3) + , (a^2*root a 5)/(a^3*root a 3), (a^4*root a 3)/(a^6*sqrt a) + ] + ] + where + a = Var "a" diff --git a/src/Domain/Math/Expr.hs b/src/Domain/Math/Expr.hs --- a/src/Domain/Math/Expr.hs +++ b/src/Domain/Math/Expr.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,6 @@ , module Domain.Math.Expr.Symbolic , module Domain.Math.Expr.Symbols , module Domain.Math.Expr.Views - , module Domain.Math.Expr.Conversion ) where import Domain.Math.Expr.Data @@ -23,4 +22,3 @@ import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Expr.Views -import Domain.Math.Expr.Conversion diff --git a/src/Domain/Math/Expr/Conversion.hs b/src/Domain/Math/Expr/Conversion.hs deleted file mode 100644 --- a/src/Domain/Math/Expr/Conversion.hs +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Expr.Conversion where - -import Domain.Math.Expr.Data -import Domain.Math.Expr.Symbolic -import Domain.Math.Expr.Symbols -import Domain.Math.Data.Equation -import Domain.Math.Data.OrList -import Text.OpenMath.Object -import Common.View -import Control.Monad -import Data.Maybe -import Data.List - ------------------------------------------------------------------------ --- Type class for expressions - -class IsExpr a where - toExpr :: a -> Expr - fromExpr :: MonadPlus m => Expr -> m a - exprView :: View Expr a - - -- default definitions - toExpr = build exprView - fromExpr = maybe (fail "not an expression") return . match exprView - exprView = makeView fromExpr toExpr - -instance IsExpr Expr where - exprView = identity - -instance IsExpr a => IsExpr [a] where - toExpr = function listSymbol . map toExpr - fromExpr expr = isSymbol listSymbol expr >>= mapM fromExpr - -instance (IsExpr a, IsExpr b) => IsExpr (Either a b) where - toExpr = either toExpr toExpr - fromExpr expr = - liftM Left (fromExpr expr) `mplus` - liftM Right (fromExpr expr) - -------------------------------------------------------------- --- Conversions to the Expr data type - -instance IsExpr a => IsExpr (Equation a) where - toExpr (x :==: y) = binary eqSymbol (toExpr x) (toExpr y) - fromExpr expr = do - (e1, e2) <- isBinary eqSymbol expr - liftM2 (:==:) (fromExpr e1) (fromExpr e2) - -instance IsExpr a => IsExpr (OrList a) where - toExpr ors = - case disjunctions ors of - Just [] -> symbol falseSymbol - Just [x] -> toExpr x - Just xs -> function orSymbol (map toExpr xs) - Nothing -> symbol trueSymbol - - fromExpr expr = do - xs <- isSymbol orSymbol expr - ys <- mapM fromExpr xs - return (orList ys) - `mplus` do - guard (isConst falseSymbol expr) >> return false - `mplus` do - guard (isConst trueSymbol expr) >> return true - `mplus` - liftM return (fromExpr expr) - -------------------------------------------------------------- --- Symbol Conversion to/from OpenMath - -toOMOBJ :: Expr -> OMOBJ -toOMOBJ (Var x) = OMV x -toOMOBJ (Nat n) = OMI n -toOMOBJ expr = - case getFunction expr of - Just (s, []) -> - OMS s - Just (s, [Var x, e]) | s == lambdaSymbol -> - OMBIND (OMS lambdaSymbol) [x] (toOMOBJ e) - Just (s, xs) -> - OMA (OMS s:map toOMOBJ xs) - Nothing -> - error $ "toOMOBJ: " ++ show expr - -fromOMOBJ :: OMOBJ -> Expr -fromOMOBJ omobj = - case omobj of - OMI n -> fromInteger n - OMV x -> Var x - OMS s -> symbol s - OMA (OMS s:xs) -> function s (map fromOMOBJ xs) - OMBIND (OMS s) [x] body -> - binary s (Var x) (fromOMOBJ body) - _ -> symbol $ Symbol Nothing $ show omobj diff --git a/src/Domain/Math/Expr/Data.hs b/src/Domain/Math/Expr/Data.hs --- a/src/Domain/Math/Expr/Data.hs +++ b/src/Domain/Math/Expr/Data.hs @@ -1,5 +1,6 @@ +{-# OPTIONS -XDeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,15 +12,20 @@ ----------------------------------------------------------------------------- module Domain.Math.Expr.Data where -import Data.Char (isDigit, isAlphaNum) +import Data.Char (isAlphaNum) import Data.Ratio +import Data.Typeable import Test.QuickCheck import Control.Monad import Common.Uniplate -import Common.Rewriting hiding (operators, match) +import Common.Utils (commaList) +import Common.View +import Common.Rewriting hiding (operators) import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols +import qualified Common.Rewriting.Term as Term + ----------------------------------------------------------------------- -- Expression data type @@ -29,13 +35,15 @@ | Expr :-: Expr | Negate Expr | Nat Integer - -- Fractional & Floating + -- Fractional | Expr :/: Expr + -- Floating-point | Sqrt Expr + | Number Double -- positive only -- Symbolic | Var String | Sym Symbol [Expr] - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) ----------------------------------------------------------------------- -- Numeric instances (and symbolic) @@ -109,6 +117,11 @@ Sym s as -> return (s, as) _ -> mzero +fromDouble :: Double -> Expr +fromDouble d + | d < 0 = negate (Number (abs d)) + | otherwise = Number d + ----------------------------------------------------------------------- -- Uniplate instance @@ -128,6 +141,7 @@ {- let syms = [plusSymbol, timesSymbol, minusSymbol, negateSymbol, divSymbol] in sized (symbolGenerator (const [natGenerator]) syms) -} +instance CoArbitrary Expr where coarbitrary expr = case expr of a :+: b -> variant 0 . coarbitrary a . coarbitrary b @@ -136,9 +150,10 @@ Negate a -> variant 3 . coarbitrary a Nat n -> variant 4 . coarbitrary n a :/: b -> variant 5 . coarbitrary a . coarbitrary b - Sqrt a -> variant 6 . coarbitrary a - Var s -> variant 7 . coarbitrary s - Sym f xs -> variant 8 . coarbitrary (show f) . coarbitrary xs + Number d -> variant 6 . coarbitrary d + Sqrt a -> variant 7 . coarbitrary a + Var s -> variant 8 . coarbitrary s + Sym f xs -> variant 9 . coarbitrary (show f) . coarbitrary xs symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr symbolGenerator extras syms = f @@ -169,7 +184,8 @@ showExpr :: OperatorTable -> Expr -> String showExpr table = rec 0 where - rec _ (Nat n) = show n + rec _ (Nat n) = if n>=0 then show n else "(ERROR)" ++ show n + rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d rec _ (Var s) | all isAlphaNum s = s | otherwise = "\"" ++ s ++ "\"" @@ -178,32 +194,36 @@ -- To do: remove special case for sqrt Just (s, [a, b]) | s == rootSymbol && b == Nat 2 -> parIf (i>10000) $ unwords ["sqrt", rec 10001 a] + Just (s, xs) | s == listSymbol -> + "[" ++ commaList (map (rec 0) xs) ++ "]" Just (s, as) -> case (lookup s symbolTable, as) of (Just (InfixLeft, n, op), [x, y]) -> parIf (i>n) $ concat [rec n x, op, rec (n+1) y] (Just (InfixRight, n, op), [x, y]) -> parIf (i>n) $ concat [rec (n+1) x, op, rec n y] - (Just (Prefix, n, op), [x]) -> -- i>=5 prevents "3--5" + (Just (InfixNon, n, op), [x, y]) -> + parIf (i>n) $ concat [rec (n+1) x, op, rec (n+1) y] + (Just (PrefixNon, n, op), [x]) -> parIf (i>=n) $ concat [op, rec (n+1) x] _ -> - parIf (not (null as) && i>10000) $ unwords (show s : map (rec 10001) as) + parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as) Nothing -> error "showExpr" + showSymbol s + | s == rootSymbol = "root" + | otherwise = show s + symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ] parIf b = if b then par else id par s = "(" ++ s ++ ")" -instance MetaVar Expr where - metaVar n = Var ('_' : show n) - isMetaVar (Var ('_':is)) | not (null is) && all isDigit is = Just (read is) - isMetaVar _ = Nothing - instance ShallowEq Expr where shallowEq (Nat a) (Nat b) = a == b shallowEq (Var a) (Var b) = a == b + shallowEq (Number a) (Number b) = a == b shallowEq expr1 expr2 = case (getFunction expr1, getFunction expr2) of (Just (s1, as), Just (s2, bs)) -> @@ -211,6 +231,44 @@ _ -> False instance Rewrite Expr + +instance Different Expr where + different = (Nat 0, Nat 1) + +instance IsTerm Expr where + toTerm (Nat n) = Term.Num n + toTerm (Number d) = Term.Float d + toTerm (Var v) = Term.Var v + toTerm expr = + case getFunction expr of + Just (s, xs) -> Term.makeConTerm s (map toTerm xs) + Nothing -> error "IsTerm Expr" + + fromTerm (Term.Num n) = return (fromInteger n) + fromTerm (Term.Float d) = return (Number d) + fromTerm (Term.Var v) = return (Var v) + fromTerm t = + case Term.getSpine t of + (Term.Con s, xs) -> do + ys <- mapM fromTerm xs + return (function s ys) + _ -> fail "fromTerm" + +instance IsTerm a => IsTerm [a] where + toTerm = function listSymbol . map toTerm + fromTerm a = isSymbol listSymbol a >>= mapM fromTerm + +toExpr :: IsTerm a => a -> Expr +toExpr a = + case fromTerm (toTerm a) of + Just expr -> expr + Nothing -> error "Invalid term" + +fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a +fromExpr = fromTerm . toTerm + +exprView :: IsTerm a => View Expr a +exprView = makeView fromExpr toExpr ----------------------------------------------------------------------- -- AC Theory for expression diff --git a/src/Domain/Math/Expr/Parser.hs b/src/Domain/Math/Expr/Parser.hs --- a/src/Domain/Math/Expr/Parser.hs +++ b/src/Domain/Math/Expr/Parser.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,58 +10,37 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Expr.Parser - ( scannerExpr, parseExpr, parseWith, pExpr + ( scannerExpr, parseExpr, parseExprWith, pExpr , pEquations, pEquation, pOrList, pFractional + , pRelation, pLogic, pLogicRelation ) where import Prelude hiding ((^)) -import Text.Parsing hiding (pParens) +import Text.Parsing import Control.Monad -import Data.List -import Data.Maybe import Common.Transformation -import Domain.Math.Data.Equation +import qualified Domain.Logic.Formula as Logic +import Domain.Logic.Formula (Logic) +import Domain.Math.Data.Relation import Domain.Math.Expr.Data import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Data.OrList import Test.QuickCheck (arbitrary) -import Text.OpenMath.Dictionary.Arith1 -import Text.OpenMath.Dictionary.Logic1 -import Text.OpenMath.Dictionary.Relation1 -import Text.OpenMath.Dictionary.Calculus1 -import Text.OpenMath.Dictionary.Fns1 -import Text.OpenMath.Dictionary.Transc1 - -symbols :: [Symbol] -symbols = nubBy (\x y -> symbolName x == symbolName y) $ - concat dictionaries - -dictionaries :: [[Symbol]] -dictionaries = - [ arith1List, logic1List, relation1List, calculus1List - , fns1List, transc1List - ] - -dictionaryNames :: [String] -dictionaryNames = mapMaybe dictionary (concatMap (take 1) dictionaries) - scannerExpr :: Scanner scannerExpr = defaultScanner - { keywords = "sqrt" : map symbolName symbols ++ dictionaryNames - , keywordOperators = ["==" ] - , specialCharacters = "+-*/^()[]{},." + { keywords = ["sqrt", "root", "and", "or", "true", "false"] + , keywordOperators = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"] + , operatorCharacters = "+-*/^.=<>~" + , qualifiedIdentifiers = True } -parseWith :: TokenParser a -> String -> Either SyntaxError a -parseWith p = f . parse p . scanWith scannerExpr - where - f (e, []) = Right e - f (_, xs) = Left $ ErrorMessage $ unlines $ map show xs +parseExprWith :: TokenParser a -> String -> Either String a +parseExprWith = parseWithM scannerExpr -parseExpr :: String -> Either SyntaxError Expr -parseExpr = parseWith pExpr +parseExpr :: String -> Either String Expr +parseExpr = parseExprWith pExpr pExpr :: TokenParser Expr pExpr = expr6 @@ -69,7 +48,7 @@ -- This expression could have a fraction at top-level: both the numerator -- and denominator are atoms, optionally preceded by a (unary) minus pFractional :: TokenParser Expr -pFractional = expr6u -- flip ($) <$> expr6u <*> optional (flip (/) <$ pKey "/" <*> expr6u) id +pFractional = expr6u expr6, expr6u, expr7, expr8, term, atom :: TokenParser Expr expr6 = pChainl ((+) <$ pKey "+" <|> (-) <$ pKey "-") expr6u @@ -79,25 +58,18 @@ term = symb <*> pList atom <|> atom atom = fromInteger <$> pInteger - <|> (Var . fst) <$> pVarid + <|> Number <$> pReal + <|> Var <$> pVarid <|> pParens pExpr symb :: TokenParser ([Expr] -> Expr) -symb = unqualifiedSymb - <|> qualifiedSymb +symb = qualifiedSymb -- To fix: sqrt expects exactly one argument <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt" - -unqualifiedSymb :: TokenParser ([Expr] -> Expr) -unqualifiedSymb = pChoice (map (\s -> function s <$ pKey (symbolName s)) symbols) + <|> function rootSymbol <$ pKey "root" qualifiedSymb :: TokenParser ([Expr] -> Expr) -qualifiedSymb = pChoice (map f dictionaries) - where - f xs = case map dictionary xs of - Just d:_ -> pKey d <* pSpec '.' *> pChoice (map g xs) - _ -> pFail - g s = function s <$ pKey (symbolName s) +qualifiedSymb = (function . uncurry makeSymbol) <$> (pQVarid <|> pQConid) pEquations :: TokenParser a -> TokenParser (Equations a) pEquations = pLines True . pEquation @@ -105,6 +77,24 @@ pEquation :: TokenParser a -> TokenParser (Equation a) pEquation p = (:==:) <$> p <* pKey "==" <*> p +pRelation :: TokenParser a -> TokenParser (Relation a) +pRelation p = (\x f -> f x) <$> p <*> pRelationType <*> p + +pRelationChain :: TokenParser a -> TokenParser [Relation a] +pRelationChain p = f <$> p <*> pList1 ((,) <$> pRelationType <*> p) + where + f _ [] = [] + f a ((op, b):xs) = op a b:f b xs + +pRelationType :: TokenParser (a -> a -> Relation a) +pRelationType = pChoice (map make table) + where + make (s, f) = f <$ pKey s + table = + [ ("==", (.==.)), ("<=", (.<=.)), (">=", (.>=.)) + , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.)) + ] + pOrList :: TokenParser a -> TokenParser (OrList a) pOrList p = (join . orList) <$> pSepList pTerm (pKey "or") where @@ -113,8 +103,20 @@ <|> false <$ pKey "false" pSepList p q = (:) <$> p <*> pList (q *> p) -pParens :: TokenParser a -> TokenParser a -pParens p = pKey "(" *> p <* pKey ")" +pLogic :: TokenParser a -> TokenParser (Logic a) +pLogic p = levelOr + where + levelOr = pChainr ((Logic.:||:) <$ pKey "or") levelAnd + levelAnd = pChainr ((Logic.:&&:) <$ pKey "and") levelAtom + levelAtom = Logic.Var <$> p + <|> Logic.F <$ pKey "false" + <|> Logic.T <$ pKey "true" + <|> pParens levelOr + +pLogicRelation :: TokenParser a -> TokenParser (Logic (Relation a)) +pLogicRelation p = (Logic.catLogic . fmap f) <$> pLogic (pRelationChain p) + where + f xs = if null xs then Logic.T else foldr1 (Logic.:&&:) (map Logic.Var xs) ----------------------------------------------------------------------- -- Argument descriptor (for parameterized rules) diff --git a/src/Domain/Math/Expr/Symbolic.hs b/src/Domain/Math/Expr/Symbolic.hs --- a/src/Domain/Math/Expr/Symbolic.hs +++ b/src/Domain/Math/Expr/Symbolic.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,13 +11,41 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Expr.Symbolic - ( Symbol(..) - , module Domain.Math.Expr.Symbolic + ( module Domain.Math.Expr.Symbolic, Symbol ) where import Control.Monad -import Text.OpenMath.Symbol +import Data.Maybe +import Common.Rewriting.Term +import qualified Text.OpenMath.Symbol as OM +makeSymbol :: String -> String -> Symbol +makeSymbol = S . Just + +class IsSymbol a where + toSymbol :: a -> Symbol + fromSymbol :: Symbol -> a + +instance IsSymbol Symbol where + toSymbol = id + fromSymbol = id + +instance IsSymbol String where + toSymbol = S Nothing + fromSymbol (S (Just a) b) = a ++ "." ++ b + fromSymbol (S Nothing b) = b + +instance IsSymbol OM.Symbol where + toSymbol s = S (OM.dictionary s) (OM.symbolName s) + fromSymbol (S (Just a) b) = OM.makeSymbol a b + fromSymbol (S Nothing b) = OM.extraSymbol b + +stringToSymbol :: String -> Symbol +stringToSymbol s = + case break (=='.') s of + (xs, _:ys) -> S (Just xs) ys + _ -> S Nothing s + ------------------------------------------------------------------- -- Type class for symbolic representations @@ -41,31 +70,52 @@ guard (s==t) return as -unary :: Symbolic a => Symbol -> a -> a -unary f a = function f [a] +instance Symbolic Term where + variable = Var + symbol = Con + function = makeConTerm + getVariable = isVar + getSymbol = isCon + getFunction = getConSpine + +nullary :: (IsSymbol s, Symbolic a) => s -> a +nullary = symbol . toSymbol + +unary :: (IsSymbol s, Symbolic a) => s -> a -> a +unary f a = function (toSymbol f) [a] -binary :: Symbolic a => Symbol -> a -> a -> a -binary f a b = function f [a, b] +binary :: (IsSymbol s, Symbolic a) => s -> a -> a -> a +binary f a b = function (toSymbol f) [a, b] -isConst :: Symbolic a => Symbol -> a -> Bool -isConst s = maybe False null . isSymbol s +isConst :: (IsSymbol s, Symbolic a) => s -> a -> Bool +isConst s = maybe False null . isSymbol (toSymbol s) -isUnary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m a +isVariable :: Symbolic a => a -> Bool +isVariable = isJust . getVariable + +isUnary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m a isUnary s a = - case isSymbol s a of + case isSymbol (toSymbol s) a of Just [x] -> return x _ -> mzero -isBinary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m (a, a) +isBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a) isBinary s a = - case isSymbol s a of + case isSymbol (toSymbol s) a of Just [x, y] -> return (x, y) _ -> mzero -- left-associative by default -isAssoBinary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m (a, a) +isAssoBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a) isAssoBinary s a = - case isSymbol s a of + case isSymbol (toSymbol s) a of Just [x, y] -> return (x, y) - Just (x:xs) | length xs > 1 -> return (x, function s xs) + Just (x:xs) | length xs > 1 -> return (x, function (toSymbol s) xs) _ -> mzero + +fromTermWith :: (MonadPlus m, IsSymbol s, IsTerm a) + => (s -> [a] -> m a) -> Term -> m a +fromTermWith f term = do + (s, xs) <- getFunction term + ys <- mapM fromTermM xs + f (fromSymbol s) ys diff --git a/src/Domain/Math/Expr/Symbols.hs b/src/Domain/Math/Expr/Symbols.hs --- a/src/Domain/Math/Expr/Symbols.hs +++ b/src/Domain/Math/Expr/Symbols.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -8,54 +8,62 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- +-- Exports relevant OpenMath symbols, converted to the +-- Symbol data type from @Common.Rewriting@. +-- ----------------------------------------------------------------------------- -module Domain.Math.Expr.Symbols - ( module Domain.Math.Expr.Symbols - -- arith1 - , plusSymbol, timesSymbol, minusSymbol, divideSymbol - , rootSymbol, powerSymbol - -- logic1 - , orSymbol, trueSymbol, falseSymbol - -- list1 - , listSymbol - -- relation1 - , eqSymbol - -- calculus1 - , diffSymbol - -- nusm1 - , piSymbol - -- fns1 - , lambdaSymbol - -- transc1 - , sinSymbol, cosSymbol, lnSymbol - ) where +module Domain.Math.Expr.Symbols where import Control.Monad import Domain.Math.Expr.Symbolic -import Text.OpenMath.Symbol -import Text.OpenMath.Dictionary.Arith1 -import Text.OpenMath.Dictionary.Logic1 -import Text.OpenMath.Dictionary.List1 -import Text.OpenMath.Dictionary.Relation1 -import Text.OpenMath.Dictionary.Calculus1 -import Text.OpenMath.Dictionary.Nums1 -import Text.OpenMath.Dictionary.Fns1 -import Text.OpenMath.Dictionary.Transc1 +import Domain.Math.Data.Relation (relationSymbols) --- Check (rationalSymbol , oms "nums1" "rational") +-- OpenMath dictionaries +import qualified Text.OpenMath.Dictionary.Arith1 as Arith1 +import qualified Text.OpenMath.Dictionary.Calculus1 as Calculus1 +import qualified Text.OpenMath.Dictionary.Fns1 as Fns1 +import qualified Text.OpenMath.Dictionary.List1 as List1 +import qualified Text.OpenMath.Dictionary.Nums1 as Nums1 +import qualified Text.OpenMath.Dictionary.Transc1 as Transc1 ------------------------------------------------------------- +-- Converted OpenMath symbols + +plusSymbol, timesSymbol, minusSymbol, divideSymbol, + rootSymbol, powerSymbol, negateSymbol :: Symbol +plusSymbol = toSymbol Arith1.plusSymbol +timesSymbol = toSymbol Arith1.timesSymbol +minusSymbol = toSymbol Arith1.minusSymbol +divideSymbol = toSymbol Arith1.divideSymbol +rootSymbol = toSymbol Arith1.rootSymbol +powerSymbol = toSymbol Arith1.powerSymbol +negateSymbol = toSymbol Arith1.unaryMinusSymbol + +sinSymbol, cosSymbol, lnSymbol :: Symbol +sinSymbol = toSymbol Transc1.sinSymbol +cosSymbol = toSymbol Transc1.cosSymbol +lnSymbol = toSymbol Transc1.lnSymbol + +diffSymbol, piSymbol, lambdaSymbol, listSymbol :: Symbol +diffSymbol = toSymbol Calculus1.diffSymbol +piSymbol = toSymbol Nums1.piSymbol +lambdaSymbol = toSymbol Fns1.lambdaSymbol +listSymbol = toSymbol List1.listSymbol + +------------------------------------------------------------- -- Operator fixities type OperatorTable = [(Associativity, [(Symbol, String)])] -data Associativity = InfixLeft | InfixRight | Prefix -- InfixNon | Postfix +data Associativity = InfixLeft | InfixRight | PrefixNon + | InfixNon deriving (Show, Eq) operatorTable :: OperatorTable operatorTable = + (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) : [ (InfixLeft, [(plusSymbol, "+"), (minusSymbol, "-")]) -- 6 - , (Prefix, [(negateSymbol, "-")]) -- 6+ + , (PrefixNon, [(negateSymbol, "-")]) -- 6+ , (InfixLeft, [(timesSymbol, "*"), (divideSymbol, "/")]) -- 7 , (InfixRight, [(powerSymbol, "^")]) -- 8 ] @@ -63,25 +71,22 @@ ------------------------------------------------------------- -- Extra math symbols --- rename -negateSymbol = unaryMinusSymbol - -absSymbol = extraSymbol "abs" -signumSymbol = extraSymbol "signum" -logSymbol = extraSymbol "log" -- in Haskell, logbase e = log -expSymbol = extraSymbol "exp" -- exp 1 ~= 2.718 -tanSymbol = extraSymbol "tan" -asinSymbol = extraSymbol "asin" -atanSymbol = extraSymbol "atan" -acosSymbol = extraSymbol "acos" -sinhSymbol = extraSymbol "sinh" -tanhSymbol = extraSymbol "tanh" -coshSymbol = extraSymbol "cosh" -asinhSymbol = extraSymbol "asinh" -atanhSymbol = extraSymbol "atanh" -acoshSymbol = extraSymbol "acosh" -bottomSymbol = extraSymbol "error" -fcompSymbol = extraSymbol "compose" +absSymbol = toSymbol "abs" +signumSymbol = toSymbol "signum" +logSymbol = toSymbol "log" -- in Haskell, logbase e = log +expSymbol = toSymbol "exp" -- exp 1 ~= 2.718 +tanSymbol = toSymbol "tan" +asinSymbol = toSymbol "asin" +atanSymbol = toSymbol "atan" +acosSymbol = toSymbol "acos" +sinhSymbol = toSymbol "sinh" +tanhSymbol = toSymbol "tanh" +coshSymbol = toSymbol "cosh" +asinhSymbol = toSymbol "asinh" +atanhSymbol = toSymbol "atanh" +acoshSymbol = toSymbol "acosh" +bottomSymbol = toSymbol "error" +fcompSymbol = toSymbol "compose" ------------------------------------------------------------- -- Some match functions diff --git a/src/Domain/Math/Expr/Views.hs b/src/Domain/Math/Expr/Views.hs --- a/src/Domain/Math/Expr/Views.hs +++ b/src/Domain/Math/Expr/Views.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,6 @@ import Common.View import Domain.Math.Expr.Data import Domain.Math.Expr.Symbols -import Control.Monad import Data.List (nub) ------------------------------------------------------------ @@ -54,6 +53,7 @@ a ./. Nat 1 = a Negate a ./. b = neg (a ./. b) a ./. Negate b = neg (a ./. b) +(a :/: b) ./. c = a ./. (b .*. c) a ./. b = a :/: b recip :: Expr -> Expr @@ -141,7 +141,10 @@ productView = makeView (Just . second ($ []) . f False) g where f r (a :*: b) = f r a &&& f r b - f r (a :/: b) = f r a &&& f (not r) b + f r (a :/: b) = case a of -- two special cases (for efficiency) + Nat 1 -> f (not r) b + Negate (Nat 1) -> first not (f (not r) b) + _ -> f r a &&& f (not r) b f r (Negate a) = first not (f r a) f r e = (False, if r then (recip e:) else (e:)) diff --git a/src/Domain/Math/Numeric/Exercises.hs b/src/Domain/Math/Numeric/Exercises.hs --- a/src/Domain/Math/Numeric/Exercises.hs +++ b/src/Domain/Math/Numeric/Exercises.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -18,7 +18,6 @@ import Common.Strategy import Common.View import Domain.Math.Expr -import Domain.Math.Expr.Parser import Domain.Math.Numeric.Strategies import Domain.Math.Numeric.Views import Domain.Math.Numeric.Generators @@ -30,10 +29,10 @@ numericExercise :: LabeledStrategy Expr -> Exercise Expr numericExercise s = makeExercise - { status = Provisional + { status = Alpha , parser = parseExpr , equivalence = viewEquivalent rationalView - , strategy = liftToContext s + , strategy = mapRules liftToContext s } naturalExercise :: Exercise Expr diff --git a/src/Domain/Math/Numeric/Generators.hs b/src/Domain/Math/Numeric/Generators.hs --- a/src/Domain/Math/Numeric/Generators.hs +++ b/src/Domain/Math/Numeric/Generators.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -20,8 +20,6 @@ import Domain.Math.Numeric.Views import Test.QuickCheck import Domain.Math.Expr -import Domain.Math.Expr.Symbols -import Domain.Math.Expr.Symbolic ------------------------------------------------------------------- -- Generators @@ -80,6 +78,5 @@ nonZero = liftM (\a -> if a==0 then 1 else a) numSymbols :: [(Symbol, Maybe Int)] -numSymbols = - (negateSymbol, Just 1) : - zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2)) +numSymbols = (negateSymbol, Just 1) + : zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2)) diff --git a/src/Domain/Math/Numeric/Laws.hs b/src/Domain/Math/Numeric/Laws.hs --- a/src/Domain/Math/Numeric/Laws.hs +++ b/src/Domain/Math/Numeric/Laws.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Math/Numeric/Rules.hs b/src/Domain/Math/Numeric/Rules.hs --- a/src/Domain/Math/Numeric/Rules.hs +++ b/src/Domain/Math/Numeric/Rules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,7 +14,6 @@ import Common.Transformation import Control.Monad import Domain.Math.Expr -import Domain.Math.Expr.Symbols import Domain.Math.Numeric.Views import Common.View diff --git a/src/Domain/Math/Numeric/Strategies.hs b/src/Domain/Math/Numeric/Strategies.hs --- a/src/Domain/Math/Numeric/Strategies.hs +++ b/src/Domain/Math/Numeric/Strategies.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Math/Numeric/Tests.hs b/src/Domain/Math/Numeric/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Tests.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Tests (main) where + +import Common.Apply +import Common.View +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Numeric.Generators +import Domain.Math.Numeric.Strategies +import Domain.Math.Numeric.Views +import Test.QuickCheck + +main :: IO () +main = do + putStrLn "** Correctness numeric views" + let f v = forM_ numGenerators $ \g -> do + quickCheck $ propIdempotence g v + quickCheck $ propSoundness semEqDouble g v + f integerView + f rationalView + f integerNormalForm + f rationalNormalForm + f rationalRelaxedForm + + putStrLn "** Normal forms" + let f v = forM_ numGenerators $ \g -> + quickCheck $ propNormalForm g v + f integerNormalForm + -- f rationalNormalForm -- no longer a normal form + + putStrLn "** Correctness generators" + let f g v = quickCheck $ forAll (sized g) (`belongsTo` v) + f integerGenerator integerView + f rationalGenerator rationalView + f ratioExprGen rationalNormalForm + f ratioExprGenNonZero rationalNormalForm + + putStrLn "** View relations" + let va .>. vb = forM_ numGenerators $ \g -> + quickCheck $ forAll g $ \a -> + not (a `belongsTo` va) || a `belongsTo` vb + integerNormalForm .>. integerView + rationalNormalForm .>. rationalRelaxedForm + rationalRelaxedForm .>. rationalView + integerNormalForm .>. rationalNormalForm + integerView .>. rationalView + + putStrLn "** Pre/post conditions strategies" + let f s pre post = forM_ numGenerators $ \g -> + quickCheck $ forAll g $ \a -> + not (a `belongsTo` pre) || applyD s a `belongsTo` post + f naturalStrategy integerView integerNormalForm + f integerStrategy integerView integerNormalForm + f rationalStrategy rationalView rationalNormalForm + f fractionStrategy rationalView rationalNormalForm + +numGenerators :: [Gen Expr] +numGenerators = map sized + [ integerGenerator, rationalGenerator + , ratioExprGen, ratioExprGenNonZero, numGenerator + ] + +semEqDouble :: Expr -> Expr -> Bool +semEqDouble a b = + case (match doubleView a, match doubleView b) of + (Just a, Just b) -> a ~= b + (Nothing, Nothing) -> True + _ -> False + where + delta = 0.0001 + + (~=) :: Double -> Double -> Bool + a ~= b | abs a < delta || abs b < delta = True + | otherwise = abs (1 - (a/b)) < delta diff --git a/src/Domain/Math/Numeric/Views.hs b/src/Domain/Math/Numeric/Views.hs --- a/src/Domain/Math/Numeric/Views.hs +++ b/src/Domain/Math/Numeric/Views.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,8 +11,9 @@ ----------------------------------------------------------------------------- module Domain.Math.Numeric.Views ( integralView, realView - , integerView, rationalView, doubleView - , integerNormalForm, rationalNormalForm, rationalRelaxedForm, fractionForm + , integerView, rationalView, doubleView, mixedFractionView + , integerNormalForm, rationalNormalForm, mixedFractionNormalForm + , rationalRelaxedForm, fractionForm , intDiv, fracDiv, exprToNum ) where @@ -44,7 +45,8 @@ | s == powerSymbol = do let ry = toRational y guard (denominator ry == 1) - return (x Prelude.^ numerator ry) + let a = x Prelude.^ abs (numerator ry) + return (if numerator ry < 0 then 1/a else a) f _ _ = Nothing integerView :: View Expr Integer @@ -53,10 +55,23 @@ rationalView :: View Expr Rational rationalView = makeView (match realView) fromRational --- No floating view +mixedFractionView :: View Expr Rational +mixedFractionView = makeView (match realView) mix + where + mix r = + let (d, m) = abs (numerator r) `divMod` denominator r + rest = fromInteger m ./. fromInteger (denominator r) + sign = if numerator r < 0 then negate else id + in sign (fromInteger d .+. rest) + doubleView :: View Expr Double -doubleView = makeView (exprToNum doubleSym) - (fromRational . flip approxRational 0.0001) +doubleView = makeView rec Number + where + rec expr = + case expr of + Sym s xs -> mapM rec xs >>= doubleSym s + Number d -> return d + _ -> exprToNumStep rec expr ------------------------------------------------------------------- -- Numeric views in normal form @@ -68,15 +83,36 @@ f (Nat n) = Just n f _ = Nothing +-- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5) rationalNormalForm :: View Expr Rational -rationalNormalForm = makeView (optionNegate f) fromRational +rationalNormalForm = makeView f fromRational where - f (Nat a :/: Nat b) = do - guard (a > 0 && b > 1 && gcd a b == 1) - Just (fromInteger a / fromInteger b) - f (Nat n) = Just (fromInteger n) - f _ = Nothing + f (Nat a :/: Nat b) = simple a b + f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b) + f (Negate (Nat a) :/: Nat b) = fmap negate (simple a b) + f a = fmap fromInteger (match integerNormalForm a) + + simple a b + | a > 0 && b > 1 && gcd a b == 1 = + Just (fromInteger a / fromInteger b) + | otherwise = Nothing +mixedFractionNormalForm :: View Expr Rational +mixedFractionNormalForm = makeView f fromRational + where + f (Negate (Nat a) :-: (Nat b :/: Nat c)) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c) + f (Negate (Nat a :+: (Nat b :/: Nat c))) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c) + f (Nat a :+: (Nat b :/: Nat c)) | a > 0 = fmap (fromInteger a+) (simple b c) + f (Nat a :/: Nat b) = simple a b + f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b) + f (Negate (Nat a) :/: Nat b) = fmap negate (simple a b) + f a = fmap fromInteger (match integerNormalForm a) + + simple a b + | a > 0 && b > 1 && gcd a b == 1 && a < b = + Just (fromInteger a / fromInteger b) + | otherwise = Nothing + fractionForm :: View Expr (Integer, Integer) fractionForm = makeView f (\(a, b) -> (fromInteger a :/: fromInteger b)) where @@ -119,17 +155,22 @@ exprToNum :: (Monad m, Num a) => (Symbol -> [a] -> m a) -> Expr -> m a exprToNum f = rec where - rec expr = - case expr of - a :+: b -> liftM2 (+) (rec a) (rec b) - a :*: b -> liftM2 (*) (rec a) (rec b) - a :-: b -> liftM2 (-) (rec a) (rec b) - Negate a -> liftM negate (rec a) - Nat n -> return (fromInteger n) - a :/: b -> do x <- rec a; y <- rec b; f divideSymbol [x, y] - Sqrt a -> do x <- rec a; f rootSymbol [x, 2] - Var _ -> fail "exprToNum: variable" + rec expr = + case expr of Sym s xs -> mapM rec xs >>= f s + _ -> exprToNumStep rec expr + +exprToNumStep :: (Monad m, Num a) => (Expr -> m a) -> Expr -> m a +exprToNumStep rec expr = + case expr of + a :+: b -> liftM2 (+) (rec a) (rec b) + a :*: b -> liftM2 (*) (rec a) (rec b) + a :-: b -> liftM2 (-) (rec a) (rec b) + Negate a -> liftM negate (rec a) + Nat n -> return (fromInteger n) + a :/: b -> rec (Sym divideSymbol [a, b]) + Sqrt a -> rec (Sym rootSymbol [a, 2]) + _ -> fail "exprToNumStep" intDiv :: Integral a => a -> a -> Maybe a intDiv x y diff --git a/src/Domain/Math/Polynomial/BuggyRules.hs b/src/Domain/Math/Polynomial/BuggyRules.hs --- a/src/Domain/Math/Polynomial/BuggyRules.hs +++ b/src/Domain/Math/Polynomial/BuggyRules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,9 +14,10 @@ module Domain.Math.Polynomial.BuggyRules where import Domain.Math.Expr -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Polynomial.Views +import Domain.Math.Polynomial.Rules (abcFormula) import Domain.Math.Numeric.Views import Common.View import Common.Transformation @@ -24,11 +25,13 @@ import Control.Monad abcBuggyRules :: [Rule (OrList (Equation Expr))] -abcBuggyRules = [ minusB, twoA, minus4AC, oneSolution ] +abcBuggyRules = map f [ minusB, twoA, minus4AC, oneSolution ] + where + f r = r { ruleSiblings = [name abcFormula] } abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)]) -> Transformation (OrList (Equation Expr)) -abcMisconception f = makeTransList "abc misconception" $ +abcMisconception f = makeTransList $ onceJoinM $ \(lhs :==: rhs) -> do guard (rhs == 0) (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs diff --git a/src/Domain/Math/Polynomial/CleanUp.hs b/src/Domain/Math/Polynomial/CleanUp.hs --- a/src/Domain/Math/Polynomial/CleanUp.hs +++ b/src/Domain/Math/Polynomial/CleanUp.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,30 +10,46 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.CleanUp - ( cleanUp, cleanUpExpr, cleanUpExpr2, cleanUpSimple, collectLikeTerms + ( cleanUp, cleanUpRelation, cleanUpExpr, cleanUpExpr2 + , cleanUpSimple, collectLikeTerms , normalizeSum, normalizeProduct ) where -import qualified Prelude -import Prelude hiding ((^), recip) -import Domain.Math.Data.SquareRoot -import Data.Maybe -import Common.Utils -import Data.Ratio -import Data.List -import Control.Monad +import Common.Uniplate import Common.View -import Domain.Math.Numeric.Views +import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Data.SquareRoot (fromSquareRoot) import Domain.Math.Expr +import Domain.Math.Numeric.Views import Domain.Math.Power.Views -import Domain.Math.SquareRoot.Views -import Common.Uniplate import Domain.Math.Simplification (smartConstructors) -import Domain.Math.Data.Equation -import Domain.Math.Data.OrList -import qualified Domain.Math.Data.SquareRoot as SQ +import Domain.Math.SquareRoot.Views +import Prelude hiding ((^), recip) +import qualified Prelude +import Data.Ratio ---------------------------------------------------------------------- +-- Root simplification + +simplerRoot :: Rational -> Integer -> Expr +simplerRoot a b + | b < 0 = 1 ./. simplerRoot a (abs b) + | a < 0 && odd b = neg (simplerRoot (abs a) b) + | otherwise = f (numerator a) b ./. f (denominator a) b + where + f x y + | x == 0 = 0 + | y == 0 || x <= 0 = root (fromIntegral x) (fromIntegral y) + | a Prelude.^ y == x = fromIntegral a + | otherwise = root (fromIntegral x) (fromIntegral y) + where + a = round (fromIntegral x ** (1 / fromIntegral y)) + +---------------------------------------------------------------------- -- Expr normalization collectLikeTerms :: Expr -> Expr @@ -76,6 +92,7 @@ ------------------------------------------------------------ -- Testing +{- -- List with hard cases hardCases = map cleanUpExpr $ let x=Var "x" in [ -1/2*x*(x/1) @@ -93,7 +110,7 @@ , (-7+7*x)^2-(x*0)^2/(-3) , 1*(x+93)+4 , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9 - ] + ] -} ------------------------------------------------------------ -- Cleaning up @@ -105,7 +122,10 @@ f1 = simplify rationalView f2 = use identity f4 = smartConstructors - + +cleanUpRelation :: OrList (Relation Expr) -> OrList (Relation Expr) +cleanUpRelation = simplifyWith cleanUp (switchView equationView) + cleanUp :: OrList (Equation Expr) -> OrList (Equation Expr) cleanUp = idempotent . join . fmap (keepEquation . fmap cleanUpExpr) @@ -139,7 +159,7 @@ ------------------------------------------------------------ -- Technique 1: fixed points of views - +{- cleanUpFix :: Expr -> Expr cleanUpFix = fixpoint (f4 . f3 . f2 . f1) where @@ -149,7 +169,7 @@ f2 = use (squareRootViewWith rationalView) f3 = use (powerFactorViewWith rationalView) f4 = smartConstructors - +-} assoPlus :: View Expr a -> [Expr] -> [Expr] assoPlus v = rec . map (simplify v) where @@ -161,7 +181,7 @@ ------------------------------------------------------------ -- Technique 2a: one bottom-up traversal - +{- cleanUpBU :: Expr -> Expr cleanUpBU = transform (f4 . f3 . f2 . f1) where @@ -171,7 +191,7 @@ f2 = simplify (squareRootViewWith rationalView) f3 = use (powerFactorViewWith rationalView) f4 = smartConstructors - +-} ------------------------------------------------------------ -- Technique 2b: one bottom-up traversal @@ -203,17 +223,19 @@ smart :: Expr -> Expr smart (a :*: b) = a .*. b smart (a :/: b) = a ./. b -smart (Sym s [x, y]) | s == powerSymbol = x .^. y +smart expr@(Sym s [x, y]) + | s == powerSymbol = x .^. y + | s == rootSymbol = fromMaybe expr $ + liftM2 simplerRoot (match rationalView x) (match integerView y) smart (Negate a) = neg a smart (a :+: b) = a .+. b smart (a :-: b) = a .-. b -smart (Sqrt (Nat n)) | i*i == n = fromInteger i - where i = SQ.isqrt n +smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2 smart e = e ------------------------------------------------------------ -- Technique 3: lattice of views - +{- data T = R Rational | S (SquareRoot Rational) | P String Rational Int @@ -322,4 +344,4 @@ _ -> E e upgr (S a) = maybe (S a) R (fromSquareRoot a) upgr (P _ a n) | n==0 = R a -upgr t = t +upgr t = t -} diff --git a/src/Domain/Math/Polynomial/Equivalence.hs b/src/Domain/Math/Polynomial/Equivalence.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Equivalence.hs @@ -0,0 +1,308 @@ +{-# OPTIONS -XGeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Equivalence + ( linEq, quadrEqContext, highEqContext, simLogic, flipGT + , eqAfterSubstitution + ) where + +import Common.Context +import Common.Traversable +import Common.View +import Data.Maybe +import Domain.Math.Data.Polynomial hiding (eval) +import Data.List (sort, nub) +import Domain.Math.Polynomial.Views +import Prelude hiding ((^), sqrt) +import Domain.Logic.Formula hiding (Var, disjunctions) +import qualified Domain.Logic.Formula as Logic +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Numeric.Views +import Domain.Math.Data.Relation +import Domain.Math.Data.Interval +import Domain.Math.SquareRoot.Views +import Domain.Math.Expr +import Domain.Math.Data.SquareRoot +import Control.Monad +import Domain.Math.Clipboard +import Common.Rewriting hiding (constructor) +import Common.Uniplate + +relationIntervals :: Ord a => RelationType -> a -> Intervals a +relationIntervals relType a = + case relType of + EqualTo -> only singleton a + NotEqualTo -> except a + LessThan -> only lessThan a + GreaterThan -> only greaterThan a + LessThanOrEqualTo -> only lessThanOrEqualTo a + GreaterThanOrEqualTo -> only greaterThanOrEqualTo a + Approximately -> only singleton a -- i.e., equalTo + where + only f = fromList . return . f + +logicIntervals :: Ord a => Logic (Intervals a) -> Intervals a +logicIntervals = foldLogic + ( id + , \p q -> complement p `union` q -- p->q = ~p||q + , \p q -> (p `intersect` q) `union` (complement p `intersect` complement q) -- p<->q = (p&&q)||(~p&&~q) + , intersect + , union + , complement + , fromList [unbounded] + , fromList [empty] + ) + +----------------------------------------------------------- + +linEq :: Relation Expr -> Relation Expr -> Bool +linEq a b = fromMaybe False $ liftM2 (==) (linRel a) (linRel b) + +linRel :: Relation Expr -> Maybe (String, Intervals Rational) +linRel = linRelWith rationalView + +linRelWith :: (Ord a, Fractional a) + => View Expr a -> Relation Expr -> Maybe (String, Intervals a) +linRelWith v rel = + case match (linearViewWith v) (lhs - rhs) of + Nothing -> + case match (polyViewWith v) (lhs - rhs) of + Just (s, p) | degree p == 0 -> + case compare (coefficient 0 p) 0 of + LT | relationType rel `elem` [LessThan, LessThanOrEqualTo] -> + return (s, fromList [unbounded]) + | otherwise -> + return (s, fromList [empty]) + EQ | relationType rel `elem` [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo] -> + return (s, fromList [unbounded]) + | otherwise -> + return (s, fromList [empty]) + GT | relationType rel `elem` [GreaterThan, GreaterThanOrEqualTo] -> + return (s, fromList [unbounded]) + | otherwise -> + return (s, fromList [empty]) + _ -> Nothing + Just (s, a, b) + | a==0 -> + return (s, fromList [ unbounded | b==0 ]) + | otherwise -> do + let zero = -b/a + tp = relationType $ (if a<0 then flipSides else id) rel + return (s, relationIntervals tp zero) + where + lhs = leftHandSide rel + rhs = rightHandSide rel + +newtype Q = Q (SquareRoot Rational) deriving (Show, Eq, Num, Fractional) + +-- Use normal (numeric) ordering on square roots +instance Ord Q where + Q a `compare` Q b = f a `compare` f b + where + f :: SquareRoot Rational -> Double + f = eval . fmap fromRational + +qView :: View (SquareRoot Rational) Q +qView = makeView (return . Q) (\(Q a) -> a) + +quadrEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool +quadrEqContext = eqContextWith (polyEq quadrRel) + +highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool +highEqContext = eqContextWith (polyEq highRel) + +eqContextWith eq a b = isJust $ do + termA <- fromContext a + termB <- fromContext b + guard $ + case (ineqOnClipboard a, ineqOnClipboard b) of + (Just a, Just b) -> eq a b && eq termA termB + (Just a, Nothing) -> eq (fmap toEq a) termA && eq a termB + (Nothing, Just b) -> eq (fmap toEq b) termB && eq termA b + (Nothing, Nothing) -> eq termA termB + where + toEq :: Relation Expr -> Relation Expr + toEq r = leftHandSide r .==. rightHandSide r + +ineqOnClipboard :: Context a -> Maybe (Logic (Relation Expr)) +ineqOnClipboard = evalCM $ const $ do + expr <- lookupClipboard "ineq" + fromExpr expr + +polyEq :: (Relation Expr -> Maybe (String, Intervals Q)) -> Logic (Relation Expr) -> Logic (Relation Expr) -> Bool +polyEq f p q = fromMaybe False $ do + xs <- switch (fmap f p) + ys <- switch (fmap f q) + let vs = map fst (crush xs ++ crush ys) + guard (null vs || all (==head vs) vs) + let ix = logicIntervals (fmap snd xs) + iy = logicIntervals (fmap snd ys) + if ix == iy then return True else return False + +cuPlus :: Relation Expr -> Maybe (Relation Expr) +cuPlus rel = do + (a, b) <- match plusView (leftHandSide rel) + guard (noVars b && noVars (rightHandSide rel)) + return $ constructor rel a (rightHandSide rel - b) + `mplus` do + (a, b) <- match plusView (leftHandSide rel) + guard (noVars a && noVars (rightHandSide rel)) + return $ constructor rel b (rightHandSide rel - a) + `mplus` do + a <- isNegate (leftHandSide rel) + return $ constructor (flipSides rel) a (-rightHandSide rel) + +cuTimes :: Relation Expr -> Maybe (Relation Expr) +cuTimes rel = do + (a, b) <- match timesView (leftHandSide rel) + r1 <- match rationalView a + r2 <- match rationalView (rightHandSide rel) + guard (r1 /= 0) + let make = if r1>0 then constructor rel else constructor (flipSides rel) + new = make b (build rationalView (r2/r1)) + return new + +cuPower :: Relation Expr -> Maybe (Logic (Relation Expr)) +cuPower rel = do + (a, b) <- isBinary powerSymbol (leftHandSide rel) + n <- match integerView b + guard (n > 0 && noVars (rightHandSide rel)) + let expr = cleanUpExpr2 (root (rightHandSide rel) (fromIntegral n)) + new = constructor rel a expr + opp = constructor (flipSides rel) a (-expr) + rt = relationType rel + return $ if odd n + then Logic.Var new + else if rt `elem` [LessThan, LessThanOrEqualTo] + then Logic.Var new :&&: Logic.Var opp + else Logic.Var new :||: Logic.Var opp + +highRel2 :: Logic (Relation Expr) -> Maybe (String, Intervals Q) +highRel2 p = do + xs <- switch (fmap highRel p) + let vs = map fst (crush xs) + guard (null vs || all (==head vs) vs) + return (head vs, logicIntervals (fmap snd xs)) + +highRel :: Relation Expr -> Maybe (String, Intervals Q) +highRel rel = msum + [ cuTimes rel >>= highRel + , cuPower rel >>= highRel2 + , cuPlus rel >>= highRel + , quadrRel rel + ] + +quadrRel :: Relation Expr -> Maybe (String, Intervals Q) +quadrRel rel = + case match (quadraticViewWith rationalView) (lhs - rhs) of + Nothing -> + linRelWith (squareRootViewWith rationalView >>> qView) rel + Just (s, xa, xb, xc) -> do + let (tp, a, b, c) + | xa<0 = + (relationType (flipSides rel), -xa, -xb, -xc) + | otherwise = + (relationType rel, xa, xb, xc) + discr = b*b - 4*a*c + pa = Q ((-fromRational b-sqrtRational discr) / (2 * fromRational a)) + pb = Q ((-fromRational b+sqrtRational discr) / (2 * fromRational a)) + guard (a/=0) + (\is -> Just (s, is)) $ + case compare discr 0 of + LT | tp `elem` [NotEqualTo, GreaterThan, GreaterThanOrEqualTo] -> + fromList [unbounded] + | tp `elem` [EqualTo, Approximately, LessThan, LessThanOrEqualTo] -> + fromList [empty] + EQ | tp `elem` [EqualTo, Approximately, LessThanOrEqualTo] -> + fromList [singleton pa] + | tp == NotEqualTo -> + except pa + | tp == LessThan -> + fromList [empty] + | tp == GreaterThan -> + except pa + | tp == GreaterThanOrEqualTo -> + fromList [unbounded] + GT | tp `elem` [EqualTo, Approximately] -> + fromList [singleton pa, singleton pb] + | tp == NotEqualTo -> + except pa `intersect` except pb + | tp == LessThan -> + fromList [open pa pb] + | tp == LessThanOrEqualTo -> + fromList [closed pa pb] + | tp == GreaterThan -> + fromList [lessThan pa, greaterThan pb] + | tp == GreaterThanOrEqualTo -> + fromList [lessThanOrEqualTo pa, greaterThanOrEqualTo pb] + _ -> error "unknown case in quadrRel" + where + lhs = leftHandSide rel + rhs = rightHandSide rel + +flipGT :: Relation a -> Relation a +flipGT r + | relationType r == GreaterThan = + rightHandSide r .<. leftHandSide r + | relationType r == GreaterThanOrEqualTo = + rightHandSide r .<=. leftHandSide r + | otherwise = r + +-- for similarity +simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool +simLogic f a b = rec (fmap f a) (fmap f b) + where + rec a b + | isOperator orOperator a = + let collect = nub . sort . trueOr . collectOr + in recList (collect a) (collect b) + | isOperator andOperator a = + let collect = nub . sort . falseAnd . collectAnd + in recList (collect a) (collect b) + | otherwise = + shallowEq a b && recList (children a) (children b) + + recList xs ys = + length xs == length ys && and (zipWith rec xs ys) + + collectOr (p :||: q) = collectOr p ++ collectOr q + collectOr F = [] + collectOr a = [a] + + trueOr xs = if T `elem` xs then [] else xs + + collectAnd (p :&&: q) = collectAnd p ++ collectAnd q + collectAnd T = [] + collectAnd a = [a] + + falseAnd xs = if F `elem` xs then [] else xs + +eqAfterSubstitution :: (Functor f, Functor g) + => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool +eqAfterSubstitution eq ca cb = fromMaybe False $ do + a <- fromContext ca + b <- fromContext cb + let f = maybe id (fmap . fmap . substitute) . substOnClipboard + return (f ca a `eq` f cb b) + +substitute :: (String, Expr) -> Expr -> Expr +substitute (s, a) (Var b) | s==b = a +substitute pair expr = f (map (substitute pair) cs) + where + (cs, f) = uniplate expr + +substOnClipboard :: Context a -> Maybe (String, Expr) +substOnClipboard = evalCM $ const $ do + eq <- lookupClipboardG "subst" + case eq of + Var s :==: a -> return (s, a) + _ -> fail "not a substitution" diff --git a/src/Domain/Math/Polynomial/Exercises.hs b/src/Domain/Math/Polynomial/Exercises.hs --- a/src/Domain/Math/Polynomial/Exercises.hs +++ b/src/Domain/Math/Polynomial/Exercises.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,22 +11,29 @@ ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Exercises where -import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.Strategies -import Domain.Math.Polynomial.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.BuggyRules +import Domain.Math.Approximation +import Common.Context import Common.Exercise import Common.Rewriting -import Domain.Math.Data.Equation -import Domain.Math.Equation.Views -import Domain.Math.Expr +import Common.Strategy +import Common.Traversable +import Common.Transformation +import Common.View +import Data.Maybe import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.Views import Domain.Math.Examples.DWO1 -import Domain.Math.Expr.Parser -import Common.View -import Common.Context -import Data.List +import Domain.Math.Examples.DWO2 +import Domain.Math.Expr +import Domain.Math.Polynomial.BuggyRules +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.Polynomial.Views +import Domain.Math.Polynomial.Equivalence +import Domain.Math.Numeric.Views +import Control.Monad ------------------------------------------------------------ -- Exercises @@ -36,64 +43,185 @@ { description = "solve a linear equation" , exerciseCode = makeCode "math" "lineq" , status = Provisional - , parser = parseWith (pEquation pExpr) - , similarity = eqEquation cleanUpSimple + , parser = parseExprWith (pEquation pExpr) + , similarity = eqRelation cleanUpSimple , equivalence = viewEquivalent linearEquationView - , isReady = solvedEquation - , extraRules = linearRules - , strategy = ignoreContext linearStrategy - , examples = concat linearEquations + , isSuitable = (`belongsTo` linearEquationView) + , isReady = solvedRelationWith $ \a -> + a `belongsTo` mixedFractionNormalForm || + a `belongsTo` rationalNormalForm + , extraRules = liftToContext buggyPlus : linearRules + , strategy = mapRules liftToContext linearStrategy + , examples = concat (linearEquations ++ [specialCases]) } + where + specialCases = + let x = Var "x" + in [5 :==: x, 5 :==: x + 1, x - 1/5 :==: 2] + +linearMixedExercise :: Exercise (Equation Expr) +linearMixedExercise = linearExercise + { description = "solve a linear equation with mixed fractions" + , exerciseCode = makeCode "math" "lineq-mixed" + , isReady = solvedRelationWith (`belongsTo` mixedFractionNormalForm) + , strategy = mapRules liftToContext linearMixedStrategy + } -quadraticExercise :: Exercise (OrList (Equation Expr)) +quadraticExercise :: Exercise (OrList (Relation Expr)) quadraticExercise = makeExercise { description = "solve a quadratic equation" , exerciseCode = makeCode "math" "quadreq" , status = Provisional - , parser = parseWith (pOrList (pEquation pExpr)) + , parser = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of + Left err -> Left err + Right xs -> Right (build (switchView equationView) xs) , similarity = eqOrList cleanUpExpr2 - , equivalence = viewEquivalent quadraticEquationsView - , isReady = solvedEquations - , extraRules = map ignoreContext $ quadraticRules ++ abcBuggyRules - , strategy = ignoreContext quadraticStrategy - , examples = map (orList . return) (concat quadraticEquations) + , equivalence = equivalentRelation (viewEquivalent quadraticEquationsView) + , isSuitable = (`belongsTo` (switchView equationView >>> quadraticEquationsView)) + , isReady = solvedRelations + , extraRules = map (liftToContext . liftRule (switchView equationView)) $ + quadraticRules ++ abcBuggyRules + , strategy = quadraticStrategy + , examples = map (orList . return . build equationView) (concat quadraticEquations) } -higherDegreeExercise :: Exercise (OrList (Equation Expr)) +higherDegreeExercise :: Exercise (OrList (Relation Expr)) higherDegreeExercise = makeExercise - { description = "solve an equation (higher degree)" - , exerciseCode = makeCode "math" "higherdegree" + { description = "solve an equation (higher degree)" + , exerciseCode = makeCode "math" "higherdegree" + , status = Provisional + , parser = parser quadraticExercise + , similarity = eqOrList cleanUpExpr2 + , eqWithContext = Just $ eqAfterSubstitution $ + equivalentRelation (viewEquivalent higherDegreeEquationsView) + , isSuitable = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView)) + , isReady = solvedRelations + , extraRules = map (liftToContext . liftRule (switchView equationView)) higherDegreeRules + , strategy = higherDegreeStrategy + , examples = map (orList . return . build equationView) + (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations]) + } + +quadraticNoABCExercise :: Exercise (OrList (Relation Expr)) +quadraticNoABCExercise = quadraticExercise + { description = "solve a quadratic equation without abc-formula" + , exerciseCode = makeCode "math" "quadreq-no-abc" + , status = Alpha + , strategy = configure cfg quadraticStrategy + } + where + cfg = [ (ByName (name prepareSplitSquare), Reinsert) + , (ByName (name bringAToOne), Reinsert) + , (ByName "abc form", Remove) + , (ByName (name simplerPoly), Remove) + ] + +quadraticWithApproximation :: Exercise (OrList (Relation Expr)) +quadraticWithApproximation = quadraticExercise + { description = "solve a quadratic equation with approximation" + , exerciseCode = makeCode "math" "quadreq-with-approx" + , status = Alpha + , parser = parseExprWith (pOrList (pRelation pExpr)) + , strategy = configure cfg quadraticStrategy + , equivalence = equivalentApprox + } + where + cfg = [ (ByName "approximate result", Reinsert) + , (ByName "square root simplification", Remove) + ] + +-- fixMe = checksForList quadraticWithApproximation + +findFactorsExercise :: Exercise Expr +findFactorsExercise = makeExercise + { description = "factorize the expression" + , exerciseCode = makeCode "math" "factor" , status = Provisional - , parser = parseWith (pOrList (pEquation pExpr)) - , similarity = eqOrList cleanUpExpr2 - , equivalence = viewEquivalent higherDegreeEquationsView - , isReady = solvedEquations - , extraRules = map ignoreContext higherDegreeRules - , strategy = ignoreContext higherDegreeStrategy - , examples = map (orList . return) higherDegreeEquations + , parser = parseExprWith pExpr + , similarity = \a b -> cleanUpExpr a == cleanUpExpr b + , equivalence = viewEquivalent (polyViewWith rationalView) + , isReady = (`belongsTo` linearFactorsView) + , strategy = mapRules liftToContext findFactorsStrategy + , examples = concat findFactors } + +linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)]) +linearFactorsView = productView >>> second (listView myLinearView) + where + myLinearView :: View Expr (String, Expr, Expr) + myLinearView = makeView f (build linearView) + f expr = do + triple@(_, e1, e2) <- match linearView expr + a <- match integerView e1 + b <- match integerView e2 + guard (a > 0 && gcd a b == 1) -- gcd 0 0 is undefined + return triple + `mplus` do + guard (expr `belongsTo` rationalView) + return ("x", 0, expr) + -------------------------------------------- -- Equality -eqOrList :: (Expr -> Expr) -> OrList (Equation Expr) -> OrList (Equation Expr) -> Bool +equivalentApprox :: OrList (Relation Expr) -> OrList (Relation Expr) -> Bool +equivalentApprox a b + | hasApprox a || hasApprox b = + let norm = liftM ( normOrList cleanUpExpr + . fmap toApprox + . simplify quadraticEquationsView + ) . switch . fmap toEq + in fromMaybe False $ liftM2 (==) (norm a) (norm b) + | otherwise = + equivalentRelation (viewEquivalent quadraticEquationsView) a b + where + hasApprox = maybe False (any isApproximately) . disjunctions + isApproximately = (==Approximately) . relationType + toEq rel | relationType rel `elem` [EqualTo, Approximately] = + Just (leftHandSide rel :==: rightHandSide rel) + | otherwise = Nothing + toApprox (a :==: b) = + let f x = case match doubleView x of + Just d -> Number (precision 4 d) + Nothing -> x + in f a .~=. f b + +equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool +equivalentRelation f ra rb = fromMaybe False $ do + a <- switch (fmap (match equationView) ra) + b <- switch (fmap (match equationView) rb) + return (f a b) + +eqOrList :: (Relational f, Ord (f Expr)) => + (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -> Bool eqOrList f x y = normOrList f x == normOrList f y -eqEquation :: (Expr -> Expr) -> Equation Expr -> Equation Expr -> Bool -eqEquation f x y = normEquation f x == normEquation f y +eqRelation :: (Relational f, Eq (f Expr)) => + (Expr -> Expr) -> f Expr -> f Expr -> Bool +eqRelation f x y = normRelation f x == normRelation f y -normOrList :: (Expr -> Expr) -> OrList (Equation Expr) -> OrList (Equation Expr) -normOrList f = normalize . fmap (normEquation f) +normOrList :: (Relational f, Ord (f Expr)) => + (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) +normOrList f = normalize . fmap (normRelation f) -normEquation :: (Expr -> Expr) -> Equation Expr -> Equation Expr -normEquation f eq - | a <= b = a :==: b - | otherwise = b :==: a +normRelation :: Relational f => (Expr -> Expr) -> f Expr -> f Expr +normRelation f rel + | leftHandSide new > rightHandSide new && isSymmetric new = flipSides new + | otherwise = new where - a :==: b = fmap (normExpr f) eq + new = fmap (normExpr f) rel normExpr :: (Expr -> Expr) -> Expr -> Expr normExpr f = normalizeWith [plusOperator, timesOperator] . f where plusOperator = acOperator (+) isPlus timesOperator = acOperator (*) isTimes + +-- TODO: move this definition +buggyPlus :: Rule (Equation Expr) +buggyPlus = buggyRule $ makeSimpleRuleList "buggy plus" $ \(lhs :==: rhs) -> do + (a, b) <- matchM plusView lhs + [ a :==: rhs + b, b :==: rhs + a ] + `mplus` do + (a, b) <- matchM plusView rhs + [ lhs + a :==: b, lhs + b :==: a ] diff --git a/src/Domain/Math/Polynomial/Generators.hs b/src/Domain/Math/Polynomial/Generators.hs --- a/src/Domain/Math/Polynomial/Generators.hs +++ b/src/Domain/Math/Polynomial/Generators.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -16,7 +16,6 @@ import Prelude hiding ((^)) import Domain.Math.Expr -import Domain.Math.Expr.Symbols import Domain.Math.Numeric.Generators import Test.QuickCheck import Control.Monad diff --git a/src/Domain/Math/Polynomial/IneqExercises.hs b/src/Domain/Math/Polynomial/IneqExercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/IneqExercises.hs @@ -0,0 +1,301 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.IneqExercises + ( ineqLinearExercise, ineqQuadraticExercise, ineqHigherDegreeExercise + ) where + +import Common.Context +import Common.Exercise +import Common.Strategy hiding (not) +import Common.Transformation +import Common.Uniplate (uniplate) +import Common.View +import Control.Monad +import Data.List (nub, sort) +import Data.Maybe (fromMaybe) +import Domain.Math.Data.Interval +import Domain.Logic.Formula (Logic((:||:), (:&&:))) +import Domain.Math.Clipboard +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) +import Domain.Math.Polynomial.Exercises (eqRelation, normRelation) +import Domain.Math.Equation.Views +import Domain.Math.Examples.DWO2 +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.Polynomial.Equivalence +import Domain.Math.SquareRoot.Views +import Prelude hiding (repeat) +import qualified Domain.Logic.Formula as Logic + +ineqLinearExercise :: Exercise (Relation Expr) +ineqLinearExercise = makeExercise + { description = "solve a linear inequation" + , exerciseCode = makeCode "math" "linineq" + , status = Provisional + , parser = parseExprWith (pRelation pExpr) + , isReady = solvedRelation + , equivalence = linEq + , similarity = eqRelation cleanUpExpr2 + , strategy = mapRules liftToContext ineqLinear + , examples = let x = Var "x" + extra = (x-12) / (-2) :>: (x+3)/3 + in map (build inequalityView) (concat ineqLin1 ++ [extra]) + } + +ineqQuadraticExercise :: Exercise (Logic (Relation Expr)) +ineqQuadraticExercise = makeExercise + { description = "solve a quadratic inequation" + , exerciseCode = makeCode "math" "quadrineq" + , status = Provisional + , parser = parseExprWith (pLogicRelation pExpr) + , prettyPrinter = showLogicRelation + , isReady = solvedRelations + , eqWithContext = Just quadrEqContext + , similarity = simLogic (normRelation cleanUpExpr2 . flipGT) + , strategy = ineqQuadratic + , examples = map (Logic.Var . build inequalityView) + (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad]) + } + +ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr)) +ineqHigherDegreeExercise = makeExercise + { description = "solve an inequation of higher degree" + , exerciseCode = makeCode "math" "ineqhigherdegree" + , status = Provisional + , parser = parseExprWith (pLogicRelation pExpr) + , prettyPrinter = showLogicRelation + , isReady = solvedRelations + , eqWithContext = Just highEqContext + , similarity = simLogic (normRelation cleanUpExpr2 . flipGT) + , strategy = ineqHigherDegree + , examples = map (Logic.Var . build inequalityView) ineqHigh + } + +showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String +showLogicRelation logic = + case logic of + Logic.T -> "true" + Logic.F -> "false" + Logic.Var a -> show a + p :||: q -> showLogicRelation p ++ " or " ++ showLogicRelation q + p :&&: q -> case match betweenView logic of + Just (x, o1, y, o2, z) -> + let f b = if b then "<=" else "<" + in unwords [show x, f o1, show y, f o2, show z] + _ -> showLogicRelation p ++ " and " ++ showLogicRelation q + _ -> show logic + +betweenView :: Eq a => View (Logic (Relation a)) (a, Bool, a, Bool, a) +betweenView = makeView f h + where + f (Logic.Var r1 :&&: Logic.Var r2) = do + ineq1 <- match inequalityView r1 + ineq2 <- match inequalityView r2 + let g (a :>=: b) = b :<=: a + g (a :>: b) = b :<: a + g ineq = ineq + make (g ineq1) (g ineq2) + f _ = Nothing + + make a b + | la == rb && ra /= lb = make b a + | ra == lb = + Just (la, op a, ra, op b, rb) + | otherwise = Nothing + where + (la, ra) = (leftHandSide a, rightHandSide a) + (lb, rb) = (leftHandSide b, rightHandSide b) + op (_ :<=: _) = True + op _ = False + + h (x, o1, y, o2, z) = + let f b = if b then (.<=.) else (.<.) + in Logic.Var (f o1 x y) :&&: Logic.Var (f o2 y z) + + +ineqLinear :: LabeledStrategy (Relation Expr) +ineqLinear = cleanUpStrategy (fmap cleanUpSimple) $ + label "Linear inequation" $ + label "Phase 1" (repeat ( + removeDivision + <|> ruleMulti (ruleSomewhere distributeTimes) + <|> ruleMulti merge)) + <*> + label "Phase 2" ( + try varToLeft + <*> try (coverUpPlus id) + <*> try flipSign + <*> try coverUpTimesPositive) + +-- helper strategy +coverUpPlus :: (Rule (Relation Expr) -> Rule a) -> Strategy a +coverUpPlus f = alternatives $ map (f . ($ oneVar)) + [ coverUpBinaryRule "plus" (commOp . isPlus) (-) + , coverUpBinaryRule "minus left" isMinus (+) + , coverUpBinaryRule "minus right" (flipOp . isMinus) (flip (-)) + ] -- [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] + +coverUpTimesPositive :: Rule (Relation Expr) +coverUpTimesPositive = coverUpBinaryRule "times positive" (commOp . m) (/) varConfig + where + m expr = do + (a, b) <- matchM timesView expr + r <- matchM rationalView a + guard (r>0) + return (a, b) + +flipSign :: Rule (Relation Expr) +flipSign = makeSimpleRule "flip sign" $ \r -> do + let lhs = leftHandSide r + rhs = rightHandSide r + guard (isNegative lhs) + return $ constructor (flipSides r) (neg lhs) (neg rhs) + where + isNegative (Negate _) = True + isNegative expr = + maybe False fst (match productView expr) + +ineqQuadratic :: LabeledStrategy (Context (Logic (Relation Expr))) +ineqQuadratic = label "Quadratic inequality" $ + try (liftRule (contextView (orView >>> justOneView)) turnIntoEquation) + <*> mapRules (liftRule (contextView orView)) quadraticStrategy + <*> solutionInequation + +ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr))) +ineqHigherDegree = label "Inequality of a higher degree" $ + try (liftRule (contextView (orView >>> justOneView)) turnIntoEquation) + <*> mapRules (liftRule (contextView orView)) higherDegreeStrategy + <*> solutionInequation + +justOneView :: View (OrList a) a +justOneView = makeView (f . disjunctions) return + where + f (Just [r]) = Just r + f _ = Nothing + +turnIntoEquation :: Rule (Context (Relation Expr)) +turnIntoEquation = makeSimpleRule "turn into equation" $ withCM $ \r -> do + guard (relationType r `elem` ineqTypes) + addToClipboard "ineq" (toExpr r) + return (leftHandSide r .==. rightHandSide r) + where + ineqTypes = + [LessThan, GreaterThan, LessThanOrEqualTo, GreaterThanOrEqualTo] + +-- Todo: cleanup this function +solutionInequation :: Rule (Context (Logic (Relation Expr))) +solutionInequation = makeSimpleRule "solution inequation" $ withCM $ \r -> do + ineq <- lookupClipboard "ineq" >>= fromExpr + removeClipboard "ineq" + orv <- maybeCM (matchM orView r) + case disjunctions orv of + Nothing -> -- both sides are the same + if relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] + then return Logic.T + else return Logic.F + Just [] -> do -- no solutions found for equations + let vs = collectVars (toExpr ineq) + guard (not (null vs)) + if evalIneq ineq (head vs) 0 + then return Logic.T + else return Logic.F + Just xs -> do + (vs, ys) <- liftM unzip $ matchM (listView (equationView >>> equationSolvedForm)) xs + let v = head vs + zs = nub $ map (simplify (squareRootViewWith rationalView)) ys + ds <- matchM (listView doubleView) zs + guard (all (==v) vs) + let rs = makeRanges including (sort (zipWith A ds zs)) + including = relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] + return $ fromIntervals v fromDExpr $ + fromList [ this | (d, isP, this) <- rs, isP || evalIneq ineq v d ] + where + makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)] + makeRanges b xs = + [makeLeft $ head xs] + ++ concatMap (uncurry makeMiddle) (zip xs (drop 1 xs)) + ++ [makePoint (last xs) | b] + ++ [makeRight $ last xs] + where + makeLeft a@(A d _) + | b = (d-1, False, lessThanOrEqualTo a) + | otherwise = (d-1, False, lessThan a) + makeRight a@(A d _) + | b = (d+1, False, greaterThanOrEqualTo a) + | otherwise = (d+1, False, greaterThan a) + makePoint a@(A d _) = (d, True, singleton a) + makeMiddle a1@(A d1 _) a2@(A d2 _) = + [ makePoint a1 | b ] ++ + [ ( (d1+d2)/2 + , False + , open a1 a2 + ) + ] + + evalIneq :: Relation Expr -> String -> Double -> Bool + evalIneq r v d = fromMaybe False $ + liftM2 (evalType (relationType r)) (use leftHandSide) (use rightHandSide) + where + use f = match doubleView (sub (f r)) + + evalType tp = + case tp of + EqualTo -> (==) + NotEqualTo -> (/=) + LessThan -> (<) + GreaterThan -> (>) + LessThanOrEqualTo -> (<=) + GreaterThanOrEqualTo -> (>=) + Approximately -> \a b -> abs (a-b) < 0.001 + + sub (Var x) | x==v = Number d + sub expr = build (map sub cs) + where (cs, build) = uniplate expr + +data DExpr = A Double Expr + +instance Eq DExpr where + A d1 _ == A d2 _ = d1==d2 + +instance Ord DExpr where + A d1 _ `compare` A d2 _ = d1 `compare` d2 + +fromDExpr :: DExpr -> Expr +fromDExpr (A _ e) = e + +fromIntervals :: Eq a => String -> (a -> Expr) -> Intervals a -> Logic (Relation Expr) +fromIntervals v f = ors . map (fromInterval v f) . toList + where + ors [] = Logic.F + ors xs = foldr1 (:||:) xs + +fromInterval :: Eq a => String -> (a -> Expr) -> Interval a -> Logic (Relation Expr) +fromInterval v f i + | isEmpty i = Logic.F + | otherwise = + case (leftPoint i, rightPoint i) of + (Unbounded, Unbounded) -> Logic.T + (Unbounded, Including b) -> Logic.Var (Var v .<=. f b) + (Unbounded, Excluding b) -> Logic.Var (Var v .<. f b) + (Including a, Unbounded) -> Logic.Var (Var v .>=. f a) + (Excluding a, Unbounded) -> Logic.Var (Var v .>. f a) + (Including a, Including b) + | a == b -> Logic.Var (Var v .==. f a) + | otherwise -> Logic.Var (Var v .>=. f a) :&&: Logic.Var (Var v .<=. f b) + (Including a, Excluding b) -> Logic.Var (Var v .>=. f a) :&&: Logic.Var (Var v .<. f b) + (Excluding a, Including b) -> Logic.Var (Var v .>. f a) :&&: Logic.Var (Var v .<=. f b) + (Excluding a, Excluding b) -> Logic.Var (Var v .>. f a) :&&: Logic.Var (Var v .<. f b) diff --git a/src/Domain/Math/Polynomial/Rules.hs b/src/Domain/Math/Polynomial/Rules.hs --- a/src/Domain/Math/Polynomial/Rules.hs +++ b/src/Domain/Math/Polynomial/Rules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,33 +13,37 @@ import Common.Apply import Common.Context +import Common.Rewriting import Common.Transformation import Common.Traversable -import Common.Uniplate (universe) +import Common.Uniplate (universe, uniplate) import Common.Utils -import Common.View +import Common.View hiding (simplify) import Control.Monad import Data.List (nub, (\\), sort, sortBy) import Data.Maybe import Data.Ratio -import Domain.Math.Data.Equation +import Domain.Math.Approximation (precision) +import Domain.Math.Clipboard import Domain.Math.Data.OrList +import Domain.Math.Data.Relation import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) import Domain.Math.Expr import Domain.Math.Numeric.Views import Domain.Math.Polynomial.CleanUp import Domain.Math.Polynomial.Views import Domain.Math.Power.Views +import Domain.Math.Simplification import Prelude hiding (repeat, (^), replicate) +import qualified Domain.Math.Data.Polynomial as P import qualified Domain.Math.SquareRoot.Views as SQ -import qualified Prelude ------------------------------------------------------------ -- Rule collection linearRules :: [Rule (Context (Equation Expr))] -linearRules = map ignoreContext $ - [ removeDivision, ruleMulti merge, ruleMulti distributeTimes +linearRules = map liftToContext $ + [ removeDivision, ruleMulti merge, ruleMulti distributeTimesSomewhere , varToLeft, coverUpNegate, coverUpTimes ] ++ map ($ oneVar) @@ -47,22 +51,23 @@ quadraticRules :: [Rule (OrList (Equation Expr))] -quadraticRules = +quadraticRules = -- abcFormula [ ruleOnce commonFactorVar, ruleOnce noLinFormula, ruleOnce niceFactors - , ruleOnce simplerA, abcFormula, mulZero, coverUpPower, squareBothSides + , ruleOnce simplerPoly, mulZero, coverUpPower, squareBothSides ] ++ map (ruleOnce . ($ oneVar)) [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] ++ [ ruleOnce coverUpTimes, ruleOnce coverUpNegate, ruleOnce coverUpNumerator + , ruleOnce prepareSplitSquare, ruleOnce factorLeftAsSquare , ruleOnce2 (ruleSomewhere merge), ruleOnce cancelTerms - , ruleOnce2 (ruleSomewhere distributeTimes) + , ruleOnce2 distributeTimesSomewhere , ruleOnce2 (ruleSomewhere distributionSquare), ruleOnce flipEquation , ruleOnce moveToLeft, ruleMulti2 (ruleSomewhere simplerSquareRoot) ] higherDegreeRules :: [Rule (OrList (Equation Expr))] higherDegreeRules = - [ allPowerFactors, ruleOnce2 powerFactor, sameFactor + [ allPowerFactors, sameFactor ] ++ quadraticRules ------------------------------------------------------------ @@ -70,14 +75,17 @@ -- ax^2 + bx = 0 commonFactorVar :: Rule (Equation Expr) -commonFactorVar = makeSimpleRule "common factor var" $ \(lhs :==: rhs) -> do - guard (rhs == 0) - (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs +commonFactorVar = rhsIsZero commonFactorVarNew + +commonFactorVarNew :: Rule Expr +commonFactorVarNew = makeSimpleRule "common factor var" $ \expr -> do + (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) expr guard (c == 0 && b /= 0) -- also search for constant factor - let d = gcdFrac a b - return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d)) :==: 0) + let d = (if a<0 && b<0 then negate else id) (gcdFrac a b) + return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) + -- ax^2 + c = 0 noLinFormula :: Rule (Equation Expr) noLinFormula = makeSimpleRule "no linear term b" $ \(lhs :==: rhs) -> do @@ -90,43 +98,62 @@ -- search for (X+A)*(X+B) decomposition niceFactors :: Rule (Equation Expr) -niceFactors = makeSimpleRuleList "nice factors" $ \(lhs :==: rhs) -> do - guard (rhs == 0) +niceFactors = rhsIsZero niceFactorsNew + +-- search for (X+A)*(X+B) decomposition +niceFactorsNew :: Rule Expr +niceFactorsNew = makeSimpleRuleList "nice factors" $ \expr -> do let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t - (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs) + (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) expr) guard (a==1) b <- isInt rb c <- isInt rc let ok (i, j) = i+j == b f (i, j) | i == j = -- special case - (Var x + fromInteger i) ^ 2 :==: 0 + (Var x + fromInteger i) ^ 2 | otherwise = - (Var x + fromInteger i) * (Var x + fromInteger j) :==: 0 + (Var x + fromInteger i) * (Var x + fromInteger j) map f (filter ok (factors c)) -simplerA :: Rule (Equation Expr) -simplerA = makeSimpleRule "simpler polynomial" $ \(lhs :==: rhs) -> do +rhsIsZero :: Rule Expr -> Rule (Equation Expr) +rhsIsZero r = makeSimpleRuleList (name r) $ \(lhs :==: rhs) -> do guard (rhs == 0) - (x, (ra, rb, rc)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs - [a, b, c] <- mapM isInt [ra, rb, rc] - let d = a `gcd` b `gcd` c + a <- applyAll r lhs + return (a :==: rhs) + +-- Simplify polynomial by multiplying (or dividing) the terms: +-- 1) If a,b,c are ints, then find gcd +-- 2) If any of a,b,c is a fraction, find lcm of denominators +-- 3) If a<0, then also suggest to change sign (return two solutions) +simplerPoly :: Rule (Equation Expr) +simplerPoly = makeSimpleRuleList "simpler polynomial" $ \(lhs :==: rhs) -> do + guard (rhs == 0) + let thisView = polyNormalForm rationalView >>> second quadraticPolyView + (x, (a, b, c)) <- matchM thisView lhs + r <- findFactor [a, b, c] + d <- if a >= 0 then [r] else [-r, r] guard (d `notElem` [0, 1]) - return (build quadraticView (x, fromInteger (a `div` d), fromInteger (b `div` d), fromInteger (c `div` d)) :==: 0) + return (build thisView (x, (a*d, b*d, c*d)) :==: 0) + where + findFactor :: Monad m => [Rational] -> m Rational + findFactor rs + | null rs || any (==0) rs = + fail "no factor" + | all ((==1) . denominator) rs = + return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs + | otherwise = + return $ fromIntegral $ foldr1 lcm $ map denominator rs -abcFormula :: Rule (OrList (Equation Expr)) -abcFormula = makeSimpleRule "abc formula" $ onceJoinM $ \(lhs :==: rhs) -> do +-- Simplified variant of simplerPoly: just bring a to 1. +-- Needed for quadratic strategy without square formula +bringAToOne :: Rule (Equation Expr) +bringAToOne = makeSimpleRule "bring a to one" $ \(lhs :==: rhs) -> do guard (rhs == 0) - (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs - let discr = sqrt (fromRational (b*b - 4 * a * c)) - case compare discr 0 of - LT -> return false - EQ -> return $ return $ - Var x :==: (-fromRational b) / (2 * fromRational a) - GT -> return $ orList - [ Var x :==: (-fromRational b + discr) / (2 * fromRational a) - , Var x :==: (-fromRational b - discr) / (2 * fromRational a) - ] + let thisView = polyNormalForm rationalView >>> second quadraticPolyView + (x, (a, b, c)) <- matchM thisView lhs + guard (a `notElem` [0, 1]) + return (build thisView (x, (1, b/a, c/a)) :==: 0) ------------------------------------------------------------ -- General form rules: expr = 0 @@ -141,7 +168,8 @@ (_, xs) <- matchM productView lhs guard (length xs > 1) let f e = case match (polyNormalForm rationalView >>> second linearPolyView) e of - Just (x, (a, b)) -- special cases (simplify immediately) + -- special cases (simplify immediately, as in G&R) + Just (x, (a, b)) | a == 1 -> Var x :==: fromRational (-b) | a == -1 -> @@ -157,11 +185,17 @@ oneVar :: ConfigCoverUp oneVar = configCoverUp { configName = Just "one var" - , predicateCovered = (==1) . length . collectVars + , predicateCovered = \a -> p1 a || p2 a , predicateCombined = noVars , coverLHS = True , coverRHS = True } + where + p1 = (==1) . length . collectVars + -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56 + p2 a = fromMaybe False $ do + (x, y) <- match timesView a + return (hasVars x /= hasVars y) ------------------------------------------------------------ -- Top form rules: expr1 = expr2 @@ -208,12 +242,35 @@ return $ orList [a :==: b, a :==: -b] f _ = Nothing --- Afterwards, merge, sort, and (possibly) change sign +-- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c +prepareSplitSquare :: Rule (Equation Expr) +prepareSplitSquare = makeSimpleRule "prepare split square" $ \(lhs :==: rhs) -> do + d <- match rationalView rhs + let myView = polyNormalForm rationalView >>> second quadraticPolyView + (x, (a, b, c)) <- match myView lhs + let newC = (b/2)*(b/2) + newRHS = d + newC - c + guard (a==1 && b/=0 && c /= newC) + return (build myView (x, (a, b, newC)) :==: build rationalView newRHS) + +-- factor left-hand side into (ax + c)^2 +factorLeftAsSquare :: Rule (Equation Expr) +factorLeftAsSquare = makeSimpleRule "factor left as square" $ \(lhs :==: rhs) -> do + guard (noVars rhs) + (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs + let h = b/2 + guard (a==1 && b/=0 && h*h == c) + return ((Var x + build rationalView h)^2 :==: rhs) + +-- flip the two sides of an equation flipEquation :: Rule (Equation Expr) -flipEquation = makeSimpleRule "flip equation" $ \(lhs :==: rhs) -> do - guard (hasVars rhs && noVars lhs) - let new = fmap (applyListD [sortT, mergeT]) (rhs :==: lhs) - return $ applyD signT new +flipEquation = doBeforeTrans condition $ + rule "flip equation" $ \a b -> + (a :==: b) :~> (b :==: a) + where + condition = makeTrans $ \eq@(lhs :==: rhs) -> do + guard (hasVars rhs && noVars lhs) + return eq -- Afterwards, merge and sort moveToLeft :: Rule (Equation Expr) @@ -226,6 +283,29 @@ let new = applyD mergeT $ applyD sortT $ lhs - rhs return (new :==: 0) +ruleApproximate :: Rule (Relation Expr) +ruleApproximate = makeSimpleRule "approximate" $ \relation -> do + lhs :==: rhs <- match equationView relation + guard (not (simplify rhs `belongsTo` rationalView)) + x <- getVariable lhs + d <- match doubleView rhs + let new = fromDouble (precision 4 d) + return (Var x .~=. new) + +ruleNormalizeRational :: Rule Expr +ruleNormalizeRational = + ruleFromView "normalize rational number" rationalView + +ruleNormalizeMixedFraction :: Rule Expr +ruleNormalizeMixedFraction = + ruleFromView "normalize mixed fraction" mixedFractionView + +ruleFromView :: Eq a => String -> View a b -> Rule a +ruleFromView s v = makeSimpleRuleList s $ \a -> do + b <- canonicalM v a + guard (a /= b) + return b + ------------------------------------------------------------ -- Helpers and Rest @@ -261,23 +341,6 @@ return $ orList [Var s :==: 0, make xs :==: make ys] _ -> Nothing --- Factor-out variable -powerFactor :: Rule Expr -powerFactor = makeSimpleRule "power factor" $ \e -> do - xs <- match sumView e >>= mapM (match powerFactorView) - let (vs, as, ns) = unzip3 xs - r = minimum ns - v = Var (head vs) - f a n = a*v^fromIntegral (n-r) - unless (length xs > 1 && length (nub vs) == 1 && r >= 1) Nothing - -- also search for gcd constant - case mapM (match integerView) as of - Just is | g > 1 -> - return (fromInteger g * v^fromIntegral r * foldr1 (+) (zipWith f (map (fromIntegral . (`div` g)) is) ns)) - where g = foldr1 gcd is - _ -> - return (v^fromIntegral r * build sumView (zipWith f as ns)) - -- A*B = A*C implies A=0 or B=C sameFactor :: Rule (OrList (Equation Expr)) sameFactor = makeSimpleRule "same factor" $ onceJoinM $ \(lhs :==: rhs) -> do @@ -285,7 +348,95 @@ (b2, ys) <- match productView rhs (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasVars x ] -- equality is too strong? return $ orList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ] + +-- N*(A+B) = N*C + N*D recognize a constant factor on both sides +-- Example: 3(x^2+1/2) = 6+6x +sameConFactor :: Rule (Equation Expr) +sameConFactor = makeSimpleRule "same constant factor" $ \(lhs :==: rhs) -> do + xs <- match sumView lhs + ys <- match sumView rhs + ps <- mapM (match productView) (xs ++ ys) + let (bs, zs) = unzip ps + (rs, es) = unzip (map (f 1 []) zs) + f r acc [] = (r, reverse acc) + f r acc (x:xs) = case match rationalView x of + Just r2 -> f (r*r2) acc xs + Nothing -> f r (x:acc) xs + con <- whichCon rs + guard (con /= 1) + let make b r e = build productView (b, (fromRational (r/con):e)) + (newLeft, newRight) = splitAt (length xs) (zipWith3 make bs rs es) + return (build sumView newLeft :==: build sumView newRight) + where + whichCon :: [Rational] -> Maybe Rational + whichCon xs + | all (\x -> denominator x == 1 && x /= 0) xs = + Just (fromInteger (foldr1 gcd (map numerator xs))) + | otherwise = Nothing + +abcFormula :: Rule (Context (OrList (Equation Expr))) +abcFormula = makeSimpleRule "abc formula" $ withCM $ onceJoinM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs + addListToClipboard ["a", "b", "c"] (map fromRational [a, b, c]) + let discr = b*b - 4 * a * c + sqD = sqrt (fromRational discr) + addToClipboard "D" (fromRational discr) + case compare discr 0 of + LT -> return false + EQ -> return $ return $ + Var x :==: (-fromRational b) / (2 * fromRational a) + GT -> return $ orList + [ Var x :==: (-fromRational b + sqD) / (2 * fromRational a) + , Var x :==: (-fromRational b - sqD) / (2 * fromRational a) + ] + +higherSubst :: Rule (Context (Equation Expr)) +higherSubst = makeSimpleRule "higher subst" $ withCM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + let myView = polyView >>> second trinomialPolyView + (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs + guard (n1 == 0 && n2 > 1 && n3 `mod` n2 == 0 && x /= "p") + let new = build myView ("p", ((a, 0), (b, 1), (c, n3 `div` n2))) + addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2)) + return (new :==: 0) + +substBackVar :: (Crush f, Crush g) => Rule (Context (f (g Expr))) +substBackVar = makeSimpleRule "subst back var" $ withCM $ \a -> do + expr <- lookupClipboard "subst" + case fromExpr expr of + Just (Var p :==: rhs) -> do + guard (p `elem` concatMap collectVars (concatMap crush (crush a))) + return (fmap (fmap (subst p rhs)) a) + _ -> fail "no subst in clipboard" + where + subst a b (Var c) | a==c = b + subst a b expr = build (map (subst a b) cs) + where (cs, build) = uniplate expr + +exposeSameFactor :: Rule (Equation Expr) +exposeSameFactor = makeSimpleRuleList "expose same factor" $ \(lhs :==: rhs) -> do + (bx, xs) <- matchM (productView) lhs + (by, ys) <- matchM (productView) rhs + (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] ++ + [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ] + return (build productView (bx, nx) :==: build productView (by, ny)) + where + suitable p = fromMaybe False $ do + (_, _, b) <- match (linearViewWith rationalView) p + guard (b /= 0) + return True + exposeList _ [] = [] + exposeList a (b:bs) = map (++bs) (expose a b) ++ map (b:) (exposeList a bs) + + expose a b = do + (s1, p1) <- matchM (polyViewWith rationalView) a + (s2, p2) <- matchM (polyViewWith rationalView) b + guard (s1==s2) + case P.division p2 p1 of + Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3] + Nothing -> [] --------------------------------------------------------- -- From LinearEquations @@ -293,18 +444,18 @@ ------------------------------------------------------- -- Transformations -plusT, minusT :: Expr -> Transformation (Equation Expr) -plusT e = makeTrans "plus" $ return . fmap (applyD mergeT . (.+. e)) -minusT e = makeTrans "minus" $ return . fmap (applyD mergeT . (.-. e)) +plusT, minusT :: Functor f => Expr -> Transformation (f Expr) +plusT e = makeTrans $ return . fmap (applyD mergeT . (.+. e)) +minusT e = makeTrans $ return . fmap (applyD mergeT . (.-. e)) -timesT :: Expr -> Transformation (Equation Expr) -timesT e = makeTrans "times" $ \eq -> do +timesT :: Functor f => Expr -> Transformation (f Expr) +timesT e = makeTrans $ \eq -> do r <- match rationalView e guard (r /= 0) return $ fmap (applyD mergeT . applyD distributionOldT . (e .*.)) eq divisionT :: Expr -> Transformation (Equation Expr) -divisionT e = makeTrans "division" $ \eq -> do +divisionT e = makeTrans $ \eq -> do r <- match rationalView e guard (r /= 0) return $ fmap (applyD mergeT . applyD distributionOldT . (./. e)) eq @@ -313,7 +464,7 @@ -- Combine bottom-up, for example: 5*(x-5)*(x+5) -- However, in -2x(2x+10) (-2x) should be seen as "one term" distributionT :: Transformation Expr -distributionT = makeTransList "distributeT" f +distributionT = makeTransList f where f expr = do (b, xs) <- matchM simpleProductView expr @@ -332,63 +483,57 @@ g :: Expr -> Expr -> [Expr] g a b = do - as <- matchM sumView a - bs <- matchM sumView b + as <- matchM sumView a + bs <- matchM sumView b guard (length as > 1 || length bs > 1) return $ build sumView [ a .*. b | a <- as, b <- bs ] mergeT :: Transformation Expr -mergeT = makeTrans "merge" $ return . collectLikeTerms +mergeT = makeTrans $ return . collectLikeTerms -- high exponents first, non power-factor terms at the end sortT :: Transformation Expr -sortT = makeTrans "sort" $ \e -> do +sortT = makeTrans $ \e -> do xs <- match sumView e let f = fmap (negate . thd3) . match powerFactorView ps = sortBy cmp $ zip xs (map f xs) cmp (_, ma) (_, mb) = compare ma mb return $ build sumView $ map fst ps -signT :: Transformation (Equation Expr) -signT = makeTrans "sign" $ \(lhs :==: rhs) -> do - a <- match sumView lhs >>= safeHead - p <- match productView a - guard (fst p) - return (-lhs :==: -rhs) - ------------------------------------------------------- -- Rewrite Rules -varToLeft :: Rule (Equation Expr) +varToLeft :: Relational f => Rule (f Expr) varToLeft = makeRule "variable to left" $ flip supply1 minusT $ \eq -> do - (x, a, _) <- match (linearViewWith rationalView) (getRHS eq) + (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq) guard (a/=0) return (fromRational a * Var x) -{- -conToRight :: Rule (Equation Expr) -conToRight = makeRule "constant to right" $ flip supply1 minusT $ \eq -> do - (_, _, b) <- match (linearViewWith rationalView) (getLHS eq) - guard (b/=0) - return (fromRational b) - -scaleToOne :: Rule (Equation Expr) -scaleToOne = makeRule "scale to one" $ flip supply1 divisionT $ \eq -> do - (_, a, _) <- match (linearViewWith rationalView) (getLHS eq) - guard (a `notElem` [0, 1]) - return (fromRational a) -} - -removeDivision :: Rule (Equation Expr) -removeDivision = makeRule "remove division" $ flip supply1 timesT $ \(lhs :==: rhs) -> do - xs <- match sumView lhs - ys <- match sumView rhs +-- factor is always positive due to lcm function +removeDivision :: Relational r => Rule (r Expr) +removeDivision = makeRule "remove division" $ flip supply1 timesT $ \eq -> do + xs <- match sumView (leftHandSide eq) + ys <- match sumView (rightHandSide eq) -- also consider parts without variables - zs <- mapM (fmap snd . match productView) (xs ++ ys) - let f = fmap snd . match (divView >>> second integerView) + -- (but at least one participant should have a variable) + zs <- forM (xs ++ ys) $ \a -> do + (_, list) <- match productView a + return [ (hasVars a, e) | e <- list ] + let f (b, e) = do + (_, this) <- match (divView >>> second integerView) e + return (b, this) case mapMaybe f (concat zs) of [] -> Nothing - ns -> return (fromInteger (foldr1 lcm ns)) + ps -> let (bs, ns) = unzip ps + in if or bs then return (fromInteger (foldr1 lcm ns)) + else Nothing +-- Bug fix for distribution in -2*(x+1) (duplicate result) +-- This should be a temporary fix +distributeTimesSomewhere :: Rule Expr +distributeTimesSomewhere = makeSimpleRuleList (name distributeTimes) $ + nub . map cleanUpSimple . applyAll (ruleSomewhere distributeTimes) + distributeTimes :: Rule Expr distributeTimes = makeSimpleRuleList "distribution multiplication" $ \expr -> do new <- applyAll distributionT expr @@ -415,7 +560,7 @@ -- Temporary fix: here we don't care about the terms we apply it to. Only -- use for cleaning up distributionOldT :: Transformation Expr -distributionOldT = makeTrans "distributeT" f +distributionOldT = makeTrans f where f (a :*: b) = case (match sumView a, match sumView b) of diff --git a/src/Domain/Math/Polynomial/Strategies.hs b/src/Domain/Math/Polynomial/Strategies.hs --- a/src/Domain/Math/Polynomial/Strategies.hs +++ b/src/Domain/Math/Polynomial/Strategies.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,19 +10,23 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Strategies - ( linearStrategy, quadraticStrategy - , higherDegreeStrategy + ( linearStrategy, linearMixedStrategy, quadraticStrategy + , higherDegreeStrategy, findFactorsStrategy ) where -import Prelude hiding (repeat, replicate) +import Prelude hiding (repeat, replicate, fail) +import Common.Apply import Common.Strategy +import Common.Navigator import Common.Transformation +import Common.Uniplate (transform) import Common.View +import Common.Context import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.Views +import Domain.Math.Numeric.Views import Domain.Math.Data.OrList -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Polynomial.CleanUp @@ -30,17 +34,32 @@ -- Linear equations linearStrategy :: LabeledStrategy (Equation Expr) -linearStrategy = cleanUpStrategy (fmap cleanUpSimple) $ +linearStrategy = linearStrategyWith False + +linearMixedStrategy :: LabeledStrategy (Equation Expr) +linearMixedStrategy = linearStrategyWith True + +linearStrategyWith :: Bool -> LabeledStrategy (Equation Expr) +linearStrategyWith mixed = cleanUpStrategy (fmap clean) $ label "Linear Equation" $ label "Phase 1" (repeat ( - removeDivision - <|> ruleMulti (ruleSomewhere distributeTimes) + removeDivision + <|> ruleMulti distributeTimesSomewhere <|> ruleMulti merge)) - <*> label "Phase 2" ( - try varToLeft - <*> try (coverUpPlus id) - <*> try (coverUpTimes |> try coverUpNegate)) - + <*> label "Phase 2" (repeat ( + (flipEquation |> varToLeft) + <|> coverups)) + <*> try (ruleMulti final) + where + coverups = coverUpPlus id <|> coverUpTimes <|> coverUpNegate + (clean, final) + | mixed = + ( transform (simplify mixedFractionView) . cleanUpSimple + , ruleNormalizeMixedFraction + ) + | otherwise = + (cleanUpSimple, ruleNormalizeRational) + -- helper strategy coverUpPlus :: (Rule (Equation Expr) -> Rule a) -> Strategy a coverUpPlus f = alternatives $ map (f . ($ oneVar)) @@ -49,50 +68,114 @@ ------------------------------------------------------------ -- Quadratic equations -quadraticStrategy :: LabeledStrategy (OrList (Equation Expr)) -quadraticStrategy = cleanUpStrategy cleanUp $ +quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) +quadraticStrategy = cleanUpStrategy (change cleanUpRelation) $ label "Quadratic Equation Strategy" $ - repeat $ - -- general form - ( label "general form" $ - ( ruleOnce commonFactorVar <|> ruleOnce noLinFormula{- or coverup -} - <|> ruleOnce niceFactors <|> ruleOnce simplerA - <|> coverUpPower) -- to deal with special case x^2=0 - |> abcFormula - ) - |> -- zero form - ( label "zero form" - mulZero - ) - |> -- constant form - ( label "constant form" $ - coverUpPower <|> ruleOnce coverUpTimes <|> coverUpPlus ruleOnce - <|> ruleOnce coverUpNegate <|> ruleOnce coverUpNumerator - <|> squareBothSides - ) - |> -- simplification - ( label "square root simplification" $ - ruleMulti2 (ruleSomewhere simplerSquareRoot) - ) - |> -- top form - ( label "top form" $ - ( ruleOnce2 (ruleSomewhere merge) - <|> ruleOnce cancelTerms - <|> ruleMulti2 (ruleSomewhere distributionSquare) - <|> ruleMulti2 (ruleSomewhere distributeTimes) - <|> ruleMulti2 (ruleSomewhere distributeDivision) - <|> ruleOnce flipEquation) - |> ruleOnce moveToLeft - ) + repeat $ -- Relaxed strategy: even if there are "nice" factors, allow use of square formula + ( fromEquation generalForm + <|> mapRules (liftRule (contextView (switchView equationView))) generalABCForm + ) + |> fromEquation zeroForm + |> fromEquation constantForm + |> simplifyForm + |> fromEquation topForm + where + fromEquation = mapRules (liftToContext . liftRule (switchView equationView)) + + -- ax^2 + bx + c == 0, without square formula + generalForm = label "general form" $ + ruleOnce commonFactorVar + <|> ruleOnce noLinFormula{- or coverup -} + <|> ruleOnce simplerPoly <|> remove (ruleOnce bringAToOne) + <|> ruleOnce niceFactors + <|> coverUpPower -- to deal with special case x^2=0 + + generalABCForm = label "abc form" abcFormula + + zeroForm = label "zero form" $ + toStrategy mulZero + + -- expr == c + constantForm = label "constant form" $ + -- coverUpPower <|> -- never used, see coverUpPower rule in general form + ruleOnce coverUpTimes <|> coverUpPlus ruleOnce + <|> ruleOnce coverUpNegate <|> ruleOnce coverUpNumerator + <|> squareBothSides <|> ruleOnce factorLeftAsSquare + -- simplifies square roots, or do an approximation + simplifyForm = (fromEquation $ + label "square root simplification" $ + toStrategy (ruleMulti2 (ruleSomewhere simplerSquareRoot))) + <|> remove (label "approximate result" $ + toStrategy $ liftToContext (ruleMulti ruleApproximate)) + + topForm = label "top form" $ + ( ruleOnce2 (ruleSomewhere merge) + <|> ruleOnce cancelTerms + <|> sameFactor <|> ruleOnce sameConFactor + <|> ruleMulti2 (ruleSomewhere distributionSquare) + <|> ruleMulti2 distributeTimesSomewhere + <|> ruleMulti2 (ruleSomewhere distributeDivision) + <|> ruleOnce flipEquation) + |> (ruleOnce moveToLeft <|> remove (ruleOnce prepareSplitSquare)) + -- to do: find a better location in the strategy for splitting the square + ----------------------------------------------------------- -- Higher degree equations -higherDegreeStrategy :: LabeledStrategy (OrList (Equation Expr)) -higherDegreeStrategy = cleanUpStrategy cleanUp $ +higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) +higherDegreeStrategy = label "higher degree" $ - repeat (allPowerFactors |> (mulZero <|> ruleOnce2 powerFactor <|> sameFactor)) - <*> check isQ <*> quadraticStrategy - + higherForm <*> label "quadratic" ({-option (check isQ2 <*> -} quadraticStrategy) + <*> + cleanUpStrategy (change cleanUpRelation) (label "afterwards" (try (substBackVar <*> f (repeat coverUpPower)))) + where + higherForm = cleanUpStrategy (change cleanUpRelation) $ + label "higher degree form" $ + repeat (f (toStrategy allPowerFactors) |> + (f (alternatives list) <|> liftRule specialV (ruleOrCtxOnce higherSubst)) + |> f (toStrategy (ruleOnce moveToLeft))) + list = map toStrategy + [ coverUpPower, ruleOnce coverUpTimes + , mulZero, {-ruleOnce2 powerFactor,-} sameFactor + , ruleOnce exposeSameFactor + ] ++ [coverUpPlus ruleOnce] ++ [toStrategy (ruleOnce sameConFactor)] + f = mapRulesS (liftToContext . liftRule (switchView equationView)) + + specialV :: View (Context (OrList (Relation Expr))) (Context (OrList (Equation Expr))) + specialV = contextView (switchView equationView) + +{- +isQ2 :: Context (OrList (Relation Expr)) -> Bool +isQ2 = maybe False isQ . match (switchView equationView) . fromContext + isQ :: OrList (Equation Expr) -> Bool isQ = (`belongsTo` quadraticEquationsView) +-} + +-- like ruleOnce: TODO, replace! +ruleOrCtxOnce :: Rule (Context a) -> Rule (Context (OrList a)) +ruleOrCtxOnce r = makeSimpleRuleList (name r) $ \ctx -> do + let env = getEnvironment ctx + a <- fromContext ctx + case disjunctions a of + Just xs -> f [] env xs + Nothing -> [] + where + f _ _ [] = [] + f acc env (a:as) = + case applyAll r (newContext env (noNavigator a)) of + [] -> f (a:acc) env as + new -> concatMap (fmapC $ \na -> orList (reverse acc++na:as)) new + fmapC g c = + case fromContext c of + Just a -> [newContext (getEnvironment c) (noNavigator (g a))] + Nothing -> [] + +----------------------------------------------------------- +-- Finding factors in an expression + +findFactorsStrategy :: LabeledStrategy Expr +findFactorsStrategy = cleanUpStrategy cleanUpSimple $ + label "find factors" $ + repeat (niceFactorsNew <|> commonFactorVarNew) diff --git a/src/Domain/Math/Polynomial/Tests.hs b/src/Domain/Math/Polynomial/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Tests.hs @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Tests where + +import Control.Monad +import Common.Apply +import Common.Exercise +import Common.Context +import Common.Strategy +import Common.Derivation +import Common.View +import Domain.Math.Data.Relation +import Domain.Math.Data.OrList +import Domain.Math.Clipboard +import Domain.Math.Expr +import Domain.Math.Examples.DWO1 +import Domain.Math.Examples.DWO2 +import Domain.Math.Polynomial.Exercises +import Domain.Math.Polynomial.IneqExercises +import Domain.Math.Polynomial.Generators +import Domain.Math.Polynomial.Views +import Domain.Math.Numeric.Laws +import Domain.Math.Numeric.Views +import Domain.Logic.Formula +import Test.QuickCheck +import Data.Maybe + +------------------------------------------------------------ +-- Testing instances + +tests :: IO () +tests = do + let v = viewEquivalent (polyViewWith rationalView) + testNumLawsWith v "polynomial" (sized polynomialGen) + +-- see the derivations for the DWO exercise set +seeLE n = printDerivation linearExercise $ concat linearEquations !! (n-1) +seeQE n = printDerivation quadraticExercise $ orList $ return $ build equationView $ concat quadraticEquations !! (n-1) +seeHDE n = printDerivation higherDegreeExercise $ orList $ return $ build equationView $ higherDegreeEquations !! (n-1) + +-- test strategies with DWO exercise set +testLE = concat $ zipWith (f linearExercise) [1..] $ concat linearEquations +testQE = concat $ zipWith (f quadraticExercise) [1..] $ map (orList . return . build equationView) $ concat quadraticEquations +testHDE = concat $ zipWith (f higherDegreeExercise) [1..] $ map (orList . return . build equationView) higherDegreeEquations + +f s n e = map p (g (applyAll (strategy s) (inContext s e))) where + g xs | null xs = error $ show n ++ ": " ++ show e + | otherwise = xs + p a | maybe False (isReady s) (fromContext a) = n + | otherwise = error $ show n ++ ": " ++ show e ++ " => " ++ maybe "??" show (fromContext a) + +randomLE = quickCheck $ forAll (liftM2 (:==:) (sized linearGen) (sized linearGen)) $ \eq -> + (>0) (sum (take 10 $ f linearExercise 1 eq)) +randomQE = quickCheck $ forAll (liftM2 (:==:) (sized quadraticGen) (sized quadraticGen)) $ \eq -> + (>0) (sum (take 10 $ f quadraticExercise 1 (orList [build equationView eq]))) + +{- +eqLE = concat $ zipWith (g linearExercise) [1..] $ concat linearEquations +eqQE = concat $ zipWith (g quadraticExercise) [1..] $ map (orList . return) $ concat quadraticEquations +eqHDE = concat $ zipWith (g higherDegreeExercise) [1..] $ map (orList . return) higherDegreeEquations + +g s n e = map p (h (derivations (derivationTree (strategy s) (inContext e)))) where + h xs | null xs = error $ show n ++ ": " ++ show e + | otherwise = xs + p (a, xs) = case [ (x, y) | x <- ys, y <- ys, Prelude.not (equivalence s x y) ] of + [] -> let l = length xs in l*l + (x, y):_ -> error $ show n ++ ": " ++ show x ++ " is not " ++ show y + where ys = map fromContext (a : map snd xs) +-} + +-- e1 = match higherDegreeEquationsView $ OrList [(x :==: 2)] where x = Var "x" +-- e2 = simplify rationalView (Sqrt ()) + +-- goLE = eqTest ineqLinearExercise +goQE = eqTest ineqQuadraticExercise + +--eqTest :: Exercise a -> IO () +eqTest ex = do + forM_ (examples ex) $ \eq -> do + let tree = derivationTree (strategy ex) (inContext ex eq) + forM_ (derivations tree) $ \d -> do + let xs = terms d + pp = maybe "??" (prettyPrinter ex) . fromContext + forM ([ (a, b) | a <- xs, b <- xs ]) $ \(a, b) -> do + if equalityIneq a b -- equivalence ex (fromContext a) (fromContext b) + then putChar '.' + else error $ unlines ["", pp a, pp b] + +equalityIneq :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool +equalityIneq ca cb = fromMaybe False $ + liftM2 (equivalence ineqQuadraticExercise) (f ca) (f cb) + where + f = fmap g . fromContext + g | any clipboardHasIneq [ca,cb] = turnIntoEqualTo + | otherwise = id + +clipboardHasIneq :: Context a -> Bool +clipboardHasIneq = isJust . evalCM (\_ -> lookupClipboard "ineq") + +turnIntoEqualTo :: Logic (Relation a) -> Logic (Relation a) +turnIntoEqualTo = g . fmap (\rel -> + leftHandSide rel .==. rightHandSide rel) + where + -- temporary fix + g (p :&&: q) = g p :&&: g q + g (p :||: q) = g p :||: g q + g p = p diff --git a/src/Domain/Math/Polynomial/Views.hs b/src/Domain/Math/Polynomial/Views.hs --- a/src/Domain/Math/Polynomial/Views.hs +++ b/src/Domain/Math/Polynomial/Views.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -22,18 +22,20 @@ import Prelude hiding ((^)) import Control.Monad -import Data.List +import Common.Apply import Common.View import Common.Traversable +import Common.Uniplate (transform, uniplate, children) import Common.Utils (distinct) import Domain.Math.Data.Polynomial -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Expr import Domain.Math.Numeric.Views +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Polynomial.CleanUp import Data.Maybe import qualified Domain.Math.Data.SquareRoot as SQ -import Domain.Math.Expr.Symbols import Domain.Math.SquareRoot.Views import Domain.Math.Power.Views (powerFactorViewForWith) @@ -73,13 +75,18 @@ p <- f a return (fmap (/c) p) Sym s [a, n] | s == powerSymbol -> - liftM2 power (f a) (match integralView n) -- non-negative?? + liftM2 power (f a) (matchNat n) _ -> do guard (pv `notElem` collectVars expr) liftM con (match v expr) g = build sumView . map h . reverse . terms h (a, n) = build v a .*. (Var pv .^. fromIntegral n) + + matchNat expr = do + n <- match integralView expr + guard (n >= 0) + return n ------------------------------------------------------------------- -- Quadratic view @@ -243,15 +250,41 @@ higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr) higherDegreeEquationsView = makeView f (fmap g) where - f = let make (a :==: b) = orList (normHDE (a-b)) - in Just . normalize . join . fmap make + f = let make (a :==: b) = orList (filter (not . hasNegSqrt) $ map cleanUpExpr2 (normHDE (a-b))) + in Just . normalize . join . fmap make . cuRules g = (:==: 0) + cuRules :: OrList (Equation Expr) -> OrList (Equation Expr) + cuRules xs = + let new = fmap (fmap (cleanUpExpr2 . distr)) xs in + case msum (map (`apply` new) coverUpRulesOr) of + Just ys -> cuRules ys + Nothing -> new + +hasNegSqrt :: Expr -> Bool +hasNegSqrt (Sqrt a) = + case match rationalView a of + Just r | r < 0 -> True + _ -> hasNegSqrt a +hasNegSqrt (Sym s [a, b]) | s == rootSymbol = + case (match rationalView a, match integerView b) of + (Just r, Just n) | r < 0 && even n -> True + _ -> hasNegSqrt a || hasNegSqrt b +hasNegSqrt a = + any hasNegSqrt (children a) + +distr :: Expr -> Expr +distr = transform f + where + f ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c) + f ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c) + f a = a + normHDE :: Expr -> [Expr] normHDE e = case match (polyViewWith rationalView) e of - Just (x, p) -> concatMap (g x) $ factorize p + Just (x, p) -> g x p Nothing -> fromMaybe [e] $ do (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0) return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] @@ -269,5 +302,31 @@ [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr) , SQ.scale (1/(2*a)) (SQ.con b - sdiscr) ] - | otherwise = [build (polyViewWith rationalView) (x, p)] - where d = degree p + | otherwise = + case terms p of + [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> + let list = [(c, 0), (b, 1), (a, e2 `div` e1)] + newp = sum (map (\(x, y) -> scale x (power var y)) list) + sub = map (substitute (x, Var x^fromIntegral e1)) + in concatMap normHDE (sub (g x newp)) + [(c, 0), (a, n)] + | odd n -> if c/a >= 0 + then [Var x + root (fromRational (c/a)) (fromIntegral n)] + else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)] + | even n -> if c/a > 0 + then [] + else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n) + , Var x - root (fromRational (abs (c/a))) (fromIntegral n) + ] + _ -> + case factorize p of + ps | length ps > 1 -> concatMap (g x) ps + _ -> [build (polyViewWith rationalView) (x, p)] + where + d = degree p + +substitute :: (String, Expr) -> Expr -> Expr +substitute (s, a) (Var b) | s==b = a +substitute pair expr = f (map (substitute pair) cs) + where + (cs, f) = uniplate expr diff --git a/src/Domain/Math/Power/Exercises.hs b/src/Domain/Math/Power/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Exercises.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Exercises + ( simplifyPowerExercise + , powerOfExercise + , nonNegExpExercise + , calcPowerExercise + ) where + +import Common.Apply +import Common.Context +import Common.Exercise +import Common.Navigator +import Common.Strategy hiding (not, replicate) +import Common.Utils (distinct) +import Common.View +import Data.Maybe +import Domain.Math.Examples.DWO3 +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Rules +import Domain.Math.Power.Strategies +import Domain.Math.Power.Views +import Prelude hiding ( (^) ) + +------------------------------------------------------------ +-- Exercises + +powerExercise :: LabeledStrategy (Context Expr) -> Exercise Expr +powerExercise s = makeExercise + { status = Provisional + , parser = parseExpr + , navigation = navigator + , strategy = s + } + +simplifyPowerExercise :: Exercise Expr +simplifyPowerExercise = (powerExercise powerStrategy) + { description = "simplify expression (powers)" + , exerciseCode = makeCode "math" "simplifyPower" + , isReady = isPowerAdd + , isSuitable = (`belongsTo` normPowerView') + , equivalence = viewEquivalent normPowerView' + , examples = concat $ simplerPowers ++ powers1 ++ powers2 + ++ negExp1 ++ negExp2 + ++ normPower1 ++ normPower2 ++ normPower3 + } + +powerOfExercise :: Exercise Expr +powerOfExercise = (powerExercise powerOfStrategy) + { description = "write as a power of a" + , exerciseCode = makeCode "math" "powerOf" + , isReady = isSimplePower + , isSuitable = (`belongsTo` normPowerView) + , equivalence = viewEquivalent normPowerNonNegRatio + , examples = concat $ powersOfA ++ powersOfX ++ brokenExp1' + ++ brokenExp2 ++ brokenExp3 ++ normPower5' + ++ normPower6 + } + +nonNegExpExercise :: Exercise Expr +nonNegExpExercise = (powerExercise nonNegExpStrategy) + { description = "write with a non-negative exponent" + , exerciseCode = makeCode "math" "nonNegExp" + , isReady = isPower natView + , isSuitable = (`belongsTo` normPowerNonNegDouble) + , equivalence = viewEquivalent normPowerNonNegDouble + , examples = concat $ nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 + ++ brokenExp1 ++ normPower4' ++ normPower5 + } + +calcPowerExercise :: Exercise Expr +calcPowerExercise = (powerExercise calcPowerStrategy) + { description = "simplify expression (powers)" + , exerciseCode = makeCode "math" "calcPower" + , isReady = isPowerAdd + , isSuitable = (`belongsTo` normPowerView') + , equivalence = viewEquivalent normPowerView' + , examples = concat $ negExp3 ++ normPower3' ++ normPower4 + } + + +---------------------------------------------------------------------- +-- Ready checks + +isSimplePower :: Expr -> Bool +isSimplePower (Sym s [Var _,y]) | s==powerSymbol = y `belongsTo` rationalView +isSimplePower _ = False + +isPower :: View Expr a -> Expr -> Bool +isPower v expr = + let Just (_, xs) = match productView expr + f (Nat 1 :/: a) = g a + f a = g a + g (Sym s [Var _, a]) | s==powerSymbol = isJust (match v a) + g (Sym s [x, Nat _]) | s==rootSymbol = isPower v x + g (Sqrt x) = g x + g (Var _) = True + g a = a `belongsTo` rationalView + in distinct (concatMap collectVars xs) && all f xs + +isPowerAdd :: Expr -> Bool +isPowerAdd expr = + let Just xs = match sumView expr + in all (isPower rationalView) xs && not (applicable calcPowerPlus expr) + +-- test stuff +{- +showDerivations ex = mapM_ (putStrLn . showDerivation ex) + +showAllDerivations ex = + mapM_ (\es -> putStrLn (replicate 80 '-') >> showDerivations ex es) + +a = Var "a" +b = Var "b" +-} diff --git a/src/Domain/Math/Power/Rules.hs b/src/Domain/Math/Power/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Rules.hs @@ -0,0 +1,283 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Rules + ( -- * Power rules + calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents + , subExponents, distributePower, distributePowerDiv, zeroPower, reciprocal + , reciprocalInv + -- * Root rules + , power2root, root2power, distributeRoot, mulRoot, mulRootCom, divRoot + , simplifyRoot + -- * Common rules + , myFractionTimes, simplifyFraction, pushNegOut + -- * Help functions + , smartRule + ) where + +import Prelude hiding ( (^) ) +import qualified Prelude +import Common.Apply +import Control.Arrow ( (>>^) ) +import Common.Transformation +import Common.View +import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Views +import Domain.Math.Polynomial.CleanUp + + +-- | Power rules -------------------------------------------------------------- + +calcPower :: Rule Expr +calcPower = makeSimpleRule "calculate power" $ \ expr -> do + (e1, e2) <- match simplePowerView expr + a <- match rationalView e1 + x <- match integralView e2 + if x > 0 + then return $ fromRational $ a Prelude.^ x + else return $ 1 ./. (e1 .^. neg e2) + +calcPowerPlus :: Rule Expr +calcPowerPlus = + makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus + +calcPowerMinus :: Rule Expr +calcPowerMinus = + makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus + +-- | a*x^y * b*x^q = a*b * x^(y+q) +addExponents :: Rule Expr +addExponents = makeSimpleRuleList "add exponents" $ \ expr -> do + case match (powerFactorisationView unitPowerView) expr of + Just (s, fs) -> do + (e, es) <- split (*) fs + case apply addExponents' e of + Just e' -> return $ build productView (s, e' : es) + Nothing -> fail "" + Nothing -> fail "" + +-- | a*x^y * b*x^q = a*b * x^(y+q) +addExponents' :: Rule Expr +addExponents' = makeSimpleRule "add exponents" $ \ expr -> do + x <- selectVar expr + (e1, e2) <- match timesView expr + (a, y) <- match (unitPowerForView x) e1 + (b, q) <- match (unitPowerForView x) e2 + return $ build (unitPowerForView x) (a .*. b, y + q) + +-- | a*x^y / b*x^q = a/b * x^(y-q) +subExponents :: Rule Expr +subExponents = forallVars rule + where + rule x = makeSimpleRule "sub exponents" $ \ expr -> do + (e1, e2) <- match divView expr + (a, y) <- match (unitPowerForView x) e1 + (b, q) <- match (unitPowerForView x) e2 + return $ build (unitPowerForView x) (a ./. b, y - q) + +-- | (c*a^x)^y = c*a^(x*y) +mulExponents :: Rule Expr +mulExponents = makeSimpleRule "mul exponents" $ \ expr -> do + (cax, y) <- match simplePowerView expr + (c, (a, x)) <- match strictPowerView cax + guard (c == 1 || c == -1) + selectVar a + return $ build strictPowerView (c, (a, x .*. y)) + +-- | c*(a0..an)^y = c * a0^y * a1^y .. * an^y +distributePower :: Rule Expr +distributePower = makeSimpleRule "distribute power" $ \ expr -> do + (c, (as', y)) <- match strictPowerView expr + y' <- match integerView y + (sign, as) <- match productView as' + guard (length as > 1) + return $ build productView + (if sign then odd y' else False, c : map (\a -> a .^. y) as) + +-- | c * (a/b)^y = c * (a^y / b^y) +distributePowerDiv :: Rule Expr +distributePowerDiv = makeSimpleRule "distribute power" $ \ expr -> do + (c, (ab, y)) <- match strictPowerView expr + match integerView y + (a, b) <- match divView ab + return $ c .*. build divView (a .^. y, b .^. y) + +-- | c*a^0 = c +zeroPower :: Rule Expr +zeroPower = makeSimpleRule "zero power" $ \ expr -> do + (_, (c, y)) <- match strictPowerView expr + y' <- match integerView y + guard (y'==0) + return c + +-- | d/c*a^x = d*a^(-x)/c +reciprocal :: Rule Expr +reciprocal = makeSimpleRule "reciprocal" $ \ expr -> do + a <- selectVar expr + (d, cax) <- match divView expr + (c, x) <- match (unitPowerForView a) cax + return $ build (unitPowerForView a) (d ./. c, negate x) + +-- | c*a^x = c/a^(-x) +reciprocalInv :: (Expr -> Bool) -> Rule Expr +reciprocalInv p = makeSimpleRule "reciprocal" $ \ expr -> do + guard (p expr) +-- a <- selectVar expr + (c, (a, x)) <- match strictPowerView expr + return $ c ./. build strictPowerView (1, (a, neg x)) + + +-- | Root rules ---------------------------------------------------------------- + +-- | a^(p/q) = root (a^p) q +power2root :: Rule Expr +power2root = makeSimpleRule "write as root" $ \ expr -> do + (a, pq) <- match simplePowerView expr + (p, q) <- match (rationalView >>> ratioView) pq + guard (q /= 1) + return $ let n = Nat . fromIntegral in root (a .^. n p) $ n q + +-- | root (a^p) q = a^(p/q) +root2power :: Rule Expr +root2power = makeSimpleRule "write as power" $ \ expr -> do + (ap, q) <- match rootView expr + a <- selectVar ap + p <- match (powerViewFor' a) ap + return $ build (powerViewFor' a) (fromRational (p / q)) + +-- | root (a/b) x = root a x / root b x +distributeRoot :: Rule Expr +distributeRoot = makeSimpleRule "distribute root" $ \ expr -> do + (ab, x) <- match rootView expr + (a, b) <- match divView ab + return $ build divView (build rootView (a, x), build rootView (b, x)) + +-- | c1 root a x * c2 root b x = c1*c2 * root (a*b) x +mulRoot :: Rule Expr +mulRoot = makeSimpleRule "multipy base of root" $ \ expr -> do + (r1, r2) <- match timesView expr + (c1, (a, x)) <- match rootConsView r1 + (c2, (b, x')) <- match rootConsView r2 + guard (x == x') + return $ build rootConsView (c1 .*. c2, (a .*. b, x)) + +-- | commutative version of the mulRoot rule +mulRootCom :: Rule Expr +mulRootCom = makeCommutative (myProductView (powerFactorisationView rootView)) (.*.) mulRoot + where + myProductView :: View Expr (Bool, [Expr]) -> View Expr [Expr] + myProductView v = v >>> makeView f g + where + f (s, (x:xs)) = return $ if s then neg x : xs else x:xs + f _ = fail "" + g = (,) False + +-- | c1 * root a x / c2 * root b x = c1*c2 * root (a/b) x +divRoot :: Rule Expr +divRoot = makeSimpleRule "divide base of root" $ \ expr -> do + (r1, r2) <- match divView expr + (c1, (a, x)) <- match rootConsView r1 + (c2, (b, x')) <- match rootConsView r2 + guard (x == x' && b /= 0) + return $ build rootConsView (c1 .*. c2, (a ./. b, x)) + +-- | root 0 x = 0 ; root 1 x = 1 ; root a 1 = a +simplifyRoot :: Rule Expr +simplifyRoot = makeSimpleRule "simplify root" $ \e -> f e `mplus` g e + where + f expr = do + (e1, _) <- match rootView expr + x <- match integerView e1 + case x of + 0 -> Just 0 + 1 -> Just 1 + _ -> Nothing + g expr = do + (e1, e2) <- match rootView expr + if e2 == 1 then Just e1 else Nothing + + +-- | Common rules -------------------------------------------------------------- + +-- | a/b * c/d = a*c / b*d (b or else d may be one) +myFractionTimes :: Rule Expr +myFractionTimes = smartRule $ makeSimpleRule "fraction times" $ \ expr -> do + (e1, e2) <- match timesView expr + guard $ isJust $ match divView e1 `mplus` match divView e2 + (a, b) <- match (divView <&> (identity >>^ \e -> (e,1))) e1 + (c, d) <- match (divView <&> (identity >>^ \e -> (e,1))) e2 +-- (a, b) <- match divView e1 +-- (c, d) <- match divView e2 + return $ build divView (a .*. c, b .*. d) + +-- | simplify expression +simplifyFraction :: Rule Expr +simplifyFraction = makeSimpleRule "simplify fraction" $ \ expr -> do + let expr' = simplifyWith (second normalizeProduct) productView $ expr + guard (expr /= expr') + guard $ not $ applicable myFractionTimes expr' -- a hack, need to come up with a constructive solution + return expr' + +-- | (-a)^x = (-)a^x +pushNegOut :: Rule Expr +pushNegOut = makeSimpleRule "push negation out" $ \ expr -> do + (a, x) <- match simplePowerView expr + a' <- isNegate a + x' <- match integerView x + return $ (if odd x' then neg else id) $ build simplePowerView (a', x) + + +-- | Help functions ----------------------------------------------------------- + +smartRule :: Rule Expr -> Rule Expr +smartRule = doAfter f + where + f (a :*: b) = a .*. b + f (a :/: b) = a ./. b + f (Negate a) = neg a + f (a :+: b) = a .+. b + f (a :-: b) = a .-. b + f e = e + +calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr +calcBinPowerRule opName op m = + makeSimpleRule ("calculate power " ++ opName) $ \e -> do + (e1, e2) <- m e + (a, (c1, x)) <- match unitPowerView e1 + (b, (c2, y)) <- match unitPowerView e2 + guard (a == b && x == y) + return (build unitPowerView (a, ((op c1 c2), x))) + +makeCommutative :: View Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr +makeCommutative view op rule = + makeSimpleRuleList (name rule) $ \ expr -> do + case match view expr of + Just factors -> do + (e, es) <- split op factors + case apply rule e of + Just e' -> return $ build view (e' : es) + Nothing -> fail "" + Nothing -> fail "" + +split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])] +split op xs = f xs + where + f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys + | otherwise = [] + f [] = [] + +forallVars :: (String -> Rule Expr) -> Rule Expr +forallVars ruleFor = makeSimpleRuleList (name (ruleFor "")) $ \ expr -> + mapMaybe (\v -> apply (ruleFor v) expr) $ collectVars expr diff --git a/src/Domain/Math/Power/Strategies.hs b/src/Domain/Math/Power/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Strategies.hs @@ -0,0 +1,156 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Strategies + ( powerStrategy + , powerOfStrategy + , calcPowerStrategy + , nonNegExpStrategy + ) where + +import Common.Apply +import Common.Context +import Common.Strategy +import Common.Transformation +import Common.View +import Domain.Math.Expr +import Domain.Math.Power.Rules +import Domain.Math.Power.Views +import Domain.Math.Numeric.Rules +import Domain.Math.Numeric.Views +import Prelude hiding (repeat) + +------------------------------------------------------------ +-- Strategies + +powerStrategy :: LabeledStrategy (Context Expr) +powerStrategy = makeStrategy "simplify" rules cleanupRules + where + rules = powerRules + cleanupRules = calcPower : naturalRules ++ rationalRules + +powerOfStrategy :: LabeledStrategy (Context Expr) +powerOfStrategy = makeStrategy "write as power of" rules cleanupRules + where + rules = powerRules + cleanupRules = calcPower + : simplifyRoot + : simplifyFraction + : naturalRules + ++ rationalRules + +nonNegExpStrategy :: LabeledStrategy (Context Expr) +nonNegExpStrategy = makeStrategy "non negative exponent" rules cleanupRules + where + rules = [ addExponents + , subExponents + , mulExponents + , reciprocalInv hasNegExp + , distributePower + , distributePowerDiv + , power2root + , distributeRoot + , zeroPower + , calcPowerPlus + , calcPowerMinus + , myFractionTimes + ] ++ fractionRules + cleanupRules = calcPower : simplifyFraction : naturalRules + +calcPowerStrategy :: LabeledStrategy (Context Expr) +calcPowerStrategy = makeStrategy "calcPower" rules cleanupRules + where + rules = calcPower + : mulRootCom + : divRoot + : rationalRules + cleanupRules = rationalRules ++ naturalRules + +------------------------------------------------------------ +-- | Help functions + +makeStrategy :: String -> [Rule Expr] -> [Rule Expr] -> LabeledStrategy (Context Expr) +makeStrategy l rs cs = cleanUpStrategy f $ strategise l rs + where + f = applyD $ strategise l cs + strategise l = label l . repeat . alternatives . map (somewhere . liftToContext) + +powerRules = + [ addExponents + , subExponents + , mulExponents + , distributePower + , zeroPower + , reciprocal + , root2power + , distributeRoot + , calcPower + , calcPowerPlus + , calcPowerMinus + , myFractionTimes + , pushNegOut + ] + +hasNegExp expr = + case match strictPowerView expr of + Just (_, (_, x)) -> case match rationalView x of + Just x' -> x' < 0 + _ -> False + _ -> False + + +-- | Allowed numeric rules +naturalRules = + [ calcPlusWith "nat" natView + , calcMinusWith "nat" natView + , calcTimesWith "nat" natView + , calcDivisionWith "nat" natView + , doubleNegate + , negateZero + , plusNegateLeft + , plusNegateRight + , minusNegateLeft + , minusNegateRight + , timesNegateLeft + , timesNegateRight + , divisionNegateLeft + , divisionNegateRight + ] + where + natView = makeView f fromInteger + where + f (Nat n) = Just n + f _ = Nothing + +rationalRules = + [ calcPlusWith "rational" rationalRelaxedForm + , calcMinusWith "rational" rationalRelaxedForm + , calcTimesWith "rational" rationalRelaxedForm + , calcDivisionWith "int" integerNormalForm + , doubleNegate + , negateZero + , divisionDenominator + , divisionNumerator + , simplerFraction + ] + +fractionRules = + [ fractionPlus, fractionPlusScale, fractionTimes + , calcPlusWith "int" integerNormalForm + , calcMinusWith "int" integerNormalForm + , calcTimesWith "int" integerNormalForm -- not needed? + , calcDivisionWith "int" integerNormalForm + , doubleNegate + , negateZero + , smartRule divisionDenominator + , smartRule divisionNumerator + , simplerFraction + ] diff --git a/src/Domain/Math/Power/Views.hs b/src/Domain/Math/Power/Views.hs --- a/src/Domain/Math/Power/Views.hs +++ b/src/Domain/Math/Power/Views.hs @@ -1,51 +1,195 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | --- Maintainer : bastiaan.heeren@ou.nl +-- Maintainer : alex.gerdes@ou.nl -- Stability : provisional -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- For now, restricted to integers in exponent: --- no sqrt, or roots -module Domain.Math.Power.Views - ( powerView, powerViewFor - , powerFactorView, powerFactorViewWith, powerFactorViewForWith + +module Domain.Math.Power.Views + ( -- * Power views + strictPowerView, strictPowerViewFor, powerConsViewFor, powerConsView + , unitPowerView, unitPowerForView, simplePowerView, powerFactorisationView + , powerFactorViewWith, powerViewFor', powerFactorViewForWith + , powerViewFor, powerFactorView + -- * Root views + , rootView, rootConsView + -- * View combinator + , (<&>) + -- * Normalising views + , normPowerView, normPowerView', normPowerNonNegRatio + , normPowerNonNegDouble + -- * Other views + , ratioView, natView ) where -import qualified Prelude import Prelude hiding ((^), recip) +import qualified Prelude +import Control.Arrow ( (>>^) ) import Control.Monad import Common.View +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Ratio import Domain.Math.Expr +import Domain.Math.Numeric.Views ----------------------------------------------------------------------- --- Simplified views (no side-conditions to worry about) -powerView :: View Expr (String, Int) -powerView = makeView f g - where +-- | Combinator function +(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b +v <&> w = makeView f g + where + f x = match v x `mplus` match w x + g = build v +infixl <&> + + +-- | Power views -------------------------------------------------------------- +strictPowerView :: View Expr (Expr, (Expr, Expr)) +strictPowerView = strictPowerConsView + <&> (simplePowerView >>^ (,) 1) + <&> negPowerView + where + strictPowerConsView = timesView >>> second simplePowerView + negPowerView = makeView f g + where + f (Negate expr) = do + (c, ax) <- match (strictPowerConsView <&> (simplePowerView >>^ (,) 1)) expr + return (negate c, ax) + f _ = Nothing + g = build strictPowerView + +strictPowerViewFor :: String -> View Expr (Expr, Expr) +strictPowerViewFor pv = makeView f g + where + f expr = do + (c, (a, x)) <- match strictPowerView expr + guard (Var pv == a) + return (c, x) + g (c, x) = build strictPowerView (c, (Var pv, x)) + +powerConsViewFor :: String -> View Expr (Expr, Rational) +powerConsViewFor pv = timesView >>> second (powerViewFor' pv) + +powerConsView :: View Expr (String, (Expr, Rational)) +powerConsView = makeView f g + where + f expr = do + pv <- selectVar expr + cn <- match (powerConsViewFor pv) expr + return (pv, cn) + g (pv, cn) = build (powerConsViewFor pv) cn + +unitPowerForView :: String -> ViewM Maybe Expr (Expr, Rational) +unitPowerForView pv = powerConsViewFor pv <&> (powerViewFor' pv >>^ (,) 1) + +unitPowerView :: ViewM Maybe Expr (String, (Expr, Rational)) +unitPowerView = unitView <&> negUnitView + where + unitView = powerConsView <&> (powerView >>^ \(pv, n) -> (pv, (1, n))) + negUnitView = makeView f g + where + f (Negate expr) = do + (a, (c, x)) <- match unitView expr + return (a, (negate c, x)) + f _ = Nothing + g = build unitView + +simplePowerView :: View Expr (Expr, Expr) +simplePowerView = makeView f g + where + f expr = + case expr of + Sym s [a, b] | s == powerSymbol -> return (a, b) + _ -> Nothing + g (a, b) = a .^. b + +powerFactorisationView :: View Expr a -> View Expr (Bool, [Expr]) +powerFactorisationView v = productView >>> second (makeView f id) + where + f es = return $ map (\x -> build productView (False, x)) $ factorise es + factorise :: [Expr] -> [[Expr]] + factorise es = maybe [es] split $ findIndex isPower es + where + split i = let (xs, ys) = splitAt (i+1) es in xs : factorise ys + isPower = isJust . match v + +-- | Root views --------------------------------------------------------------- + +rootView :: View Expr (Expr, Rational) +rootView = makeView f g + where + f expr = case expr of + Sqrt e -> return (e, 2) + Sym s [a, Nat b] | s == rootSymbol -> return (a, toRational b) + _ -> Nothing + g (a, b) = if b==2 then Sqrt a else root a (fromRational b) + +rootConsView :: View Expr (Expr, (Expr, Rational)) +rootConsView = timesView >>> second rootView + <&> (rootView >>^ (,) 1) + + +-- | Bastiaan's power views --------------------------------------------------- + +-- | AG: todo: integrate these views with the views above + +natView :: View Expr Int +natView = makeView f fromIntegral + where + f (Nat n) = Just $ fromInteger n + f _ = Nothing + +ratioView :: View Rational (Int, Int) +ratioView = makeView f g + where + f x = return (fromIntegral (numerator x), fromIntegral (denominator x)) + g (n,d) = fromIntegral n % fromIntegral d + +powerView :: View Expr (String, Rational) +powerView = powerViewWith rationalView + +powerViewWith :: View Expr b -> View Expr (String, b) +powerViewWith v = makeView f g + where f expr = do pv <- selectVar expr - n <- match (powerViewFor pv) expr + n <- match (powerViewForWith' v pv) expr return (pv, n) - g (pv, n) = build (powerViewFor pv) n - + g (pv, n) = build (powerViewForWith' v pv) n + powerViewFor :: String -> View Expr Int -powerViewFor pv = makeView f g +powerViewFor = powerViewForWith natView +powerViewFor' = powerViewForWith' rationalView + +powerViewForWith :: Num a => View Expr a -> String -> View Expr a +powerViewForWith v pv = makeView f g where f expr = case expr of - Var s | pv == s -> Just 1 + Var s | pv == s -> match v 1 e1 :*: e2 -> liftM2 (+) (f e1) (f e2) - Sym s [e, Nat n] - | s == powerSymbol -> liftM (* fromInteger n) (f e) + Sym s [e, n] | s == powerSymbol -> do + n'<- match v n + liftM (* n') (f e) _ -> Nothing - g a = Var pv .^. fromIntegral a + g a = Var pv .^. build v a + +powerViewForWith' v pv = makeView f g + where + f expr = + case expr of + Var s | pv == s -> match v 1 + Sym s [Var s', n] | s' == pv && s == powerSymbol -> match v n + _ -> Nothing + + g a = Var pv .^. build v a powerFactorView :: View Expr (String, Expr, Int) powerFactorView = powerFactorViewWith identity @@ -84,94 +228,127 @@ g (a, b) = build v a .*. (Var pv .^. fromIntegral b) ----------------------------------------------------------------------- --- General views (that have to cope with side-conditions) -{- --- x^n -genPowerView :: Num a => String -> View Expr a -> View Expr a -genPowerView pv v = makeView f g - where - f expr = - case expr of - Var s | pv == s -> Just 1 - e1 :*: e2 -> liftM2 (+) (f e1) (f e2) - e1 :/: e2 -> liftM2 (-) (f e1) (f e2) -- introduces a condition (silently) - Sym s [e1, e2] -- e2 should not be negative - | s == powerSymbol -> - liftM2 (*) (f e1) (match v e2) - _ -> Nothing - - g a = Var pv .^. build v a --- a*x^n -genPowerFactorView :: (Fractional a, Num b) => - String -> View Expr a -> View Expr b -> View Expr (a, b) -genPowerFactorView pv v1 v2 = makeView f g +-- | Normalising views --------------------------------------------------------- + +normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational) +normPowerNonNegRatio = makeView (liftM swap . f) (g . swap) where - f expr = + swap (x,y) = (y,x) + f expr = + case expr of + Sym s [a,b] + | s==powerSymbol -> do + (r, m) <- f a + if r==1 + then do + r2 <- match rationalView b + return (1, M.map (*r2) m) + else do + n <- match integerView b + if n >=0 + then return (r Prelude.^ n, M.map (*fromIntegral n) m) + else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m) + | s==rootSymbol -> + f (Sym powerSymbol [a, 1/b]) + Sqrt a -> + f (Sym rootSymbol [a,2]) + a :*: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + return (r1*r2, M.unionWith (+) m1 m2) + a :/: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + guard (r2 /= 0) + return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) + Var s -> return (1, M.singleton s 1) + Nat n -> return (toRational n, M.empty) + Negate x -> do + (r, m) <- f x + return (negate r, m) + _ -> do + r <- match rationalView expr + return (fromRational r, M.empty) + g (r, m) = + let xs = map f (M.toList m) + f (s, r) = Var s .^. fromRational r + in build productView (False, fromRational r : xs) + +-- | AG: todo: change double to norm view for rationals +normPowerNonNegDouble :: View Expr (Double, M.Map String Rational) +normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g + where + roundof n (x, m) = (fromIntegral (round (x * 10.0 ** n)) / 10.0 ** n, m) + f expr = case expr of - Var s | pv == s -> Just (1, 1) - e1 :*: e2 -> do - (a1, b1) <- f e1 - (a2, b2) <- f e2 - return (a1*a2, b1+b2) - e1 :/: e2 -> do -- introduces a condition (silently) - (a1, b1) <- f e1 - (a2, b2) <- f e2 - return (a1/a2, b1-b2) - Sym s [e1, e2] -- e2 should not be negative - | s == powerSymbol -> do - (a1, b1) <- f e1 - n <- match v2 e2 - a <- match v1 (build v1 a1 ^ build v2 n) - return (a, b1*n) - _ -> do - guard (pv `notElem` collectVars expr) - a <- match v1 expr - return (a, 0) - - g (a, b) = build v1 a .*. (Var pv .^. build v2 b) --} + Sym s [a,b] + | s==powerSymbol -> do + (x, m) <- f a + y <- match rationalView b + return (x ** fromRational y, M.map (*y) m) + | s==rootSymbol -> f (Sym powerSymbol [a, 1/b]) + Sqrt a -> f (Sym rootSymbol [a,2]) + a :*: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + return (r1*r2, M.unionWith (+) m1 m2) + a :/: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + guard (r2 /= 0) + return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) + Var s -> return (1, M.singleton s 1) + Negate x -> do + (r, m) <- f x + return (negate r, m) + _ -> do + d <- match doubleView expr + return (d, M.empty) + g (r, m) = + let xs = map f (M.toList m) + f (s, r) = Var s .^. fromRational r + in build productView (False, fromDouble r : xs) -{- -powerView :: Integral a => String -> View Expr a -> View Expr a -powerView = undefined --- helper: also generalizes over number type in exponent (not just Int) -genPowerView :: (Num a, Num b) => String -> View Expr a -> View Expr b -> View Expr (a, b) -genPowerView = genPowerViewWith +type PowerMap = (M.Map String Rational, Rational) -genPowerViewWith :: (Num a, Num b) => String -> View Expr a -> View Expr b -> View Expr (a, b) -genPowerViewWith pv v1 v2 = makeView f g - where - f expr = - case expr of - Var s | pv == s -> Just (1, 1) - e1 :*: e2 -> do - (a1, b1) <- f e1 - (a2, b2) <- f e2 - return (a1*a2, b1+b2) - e1 :/: e2 -> do - (a1, b1) <- f e1 - (a2, b2) <- f e2 - a <- match v1 (build v1 a1 / build v1 a2) - return (a, b1-b2) - Sqrt e -> f (root e 2) - Sym s [e1, e2] - | s == rootSymbol -> do - (a1, b1) <- f e1 - n <- match v2 e2 - a <- match v1 (build v1 a1 ^ build v2 n) - b <- match v2 (build v2 b1 / build v2 n) - return (a, b) - | s == powerSymbol -> do - (a1, b1) <- f e1 - n <- match v2 e2 - a <- match v1 (build v1 a1 ^ build v2 n) - return (a, b1*n) - _ -> liftM (\a -> (a, 0)) (match v1 expr) - - g (a, b) = build v1 a .*. (Var pv .^. build v2 b) - +normPowerView' :: View Expr [PowerMap] +normPowerView' = makeView (liftM h . f) g + where + f = (mapM (match normPowerNonNegRatio) =<<) . match sumView + g = build sumView . map (build normPowerNonNegRatio) + h :: [PowerMap] -> [PowerMap] + h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy (\x y -> fst x == fst y) . sort -test = match (genPowerView "x" identity integralView) (sqrt (Var "x" ^ 4)) -} +normPowerView :: View Expr (String, Rational) +normPowerView = makeView f g + where + f expr = + case expr of + Sym s [x,y] + | s==powerSymbol -> do + (s, r) <- f x + r2 <- match rationalView y + return (s, r*r2) + | s==rootSymbol -> + f (x^(1/y)) + Sqrt x -> + f (Sym rootSymbol [x, 2]) + Var s -> return (s, 1) + x :*: y -> do + (s1, r1) <- f x + (s2, r2) <- f y + guard (s1==s2) + return (s1, r1+r2) + Nat 1 :/: y -> do + (s, r) <- f y + return (s, -r) + x :/: y -> do + (s1, r1) <- f x + (s2, r2) <- f y + guard (s1==s2) + return (s1, r1-r2) + _ -> Nothing + + g (s, r) = Var s .^. fromRational r diff --git a/src/Domain/Math/Simplification.hs b/src/Domain/Math/Simplification.hs --- a/src/Domain/Math/Simplification.hs +++ b/src/Domain/Math/Simplification.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -16,24 +16,26 @@ ) where import Common.Context +import Common.Navigator import Common.Transformation import Common.Uniplate import Common.View hiding (simplify) import Control.Monad import Data.List import Data.Maybe -import Domain.Math.Data.Equation +import Domain.Math.Data.Relation import Domain.Math.Expr hiding (recip) import Domain.Math.Numeric.Views import Domain.Math.SquareRoot.Views import Test.QuickCheck import qualified Common.View as View +import Common.Rewriting class Simplify a where simplify :: a -> a instance Simplify a => Simplify (Context a) where - simplify = fmap simplify + simplify = change simplify instance Simplify a => Simplify (Equation a) where simplify = fmap simplify @@ -93,12 +95,13 @@ instance Simplify (Simplified a) where simplify = id -instance (Simplify a, IsExpr a) => IsExpr (Simplified a) where - toExpr (S x) = toExpr x - fromExpr = liftM simplified . fromExpr +instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where + toTerm (S x) = toTerm x + fromTerm = liftM simplified . fromTerm instance (Arbitrary a, Simplify a) => Arbitrary (Simplified a) where arbitrary = liftM simplified arbitrary +instance (CoArbitrary a, Simplify a) => CoArbitrary (Simplified a) where coarbitrary (S x) = coarbitrary x simplified :: Simplify a => a -> Simplified a diff --git a/src/Domain/Math/SquareRoot/Tests.hs b/src/Domain/Math/SquareRoot/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/SquareRoot/Tests.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.SquareRoot.Tests (tests) where + +import Control.Monad +import Test.QuickCheck +import Domain.Math.Data.SquareRoot +import Domain.Math.Numeric.Laws +import Common.Utils () + +------------------------------------------------------------------- +-- Testing + +tests :: IO () +tests = + testNumLaws "square roots" squareRootGen + -- testFracLaws "square roots" squareRootGen + +squareRootGen :: Gen (SquareRoot Rational) +squareRootGen = do + n <- choose (0, 10) + let f r1 r2 = fromRational r1 * sqrtRational (abs r2) + ps <- replicateM n $ liftM2 f arbitrary arbitrary + return (sum ps) diff --git a/src/Domain/Math/SquareRoot/Views.hs b/src/Domain/Math/SquareRoot/Views.hs --- a/src/Domain/Math/SquareRoot/Views.hs +++ b/src/Domain/Math/SquareRoot/Views.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/Math/Strategy/BrokenEquations.hs b/src/Domain/Math/Strategy/BrokenEquations.hs deleted file mode 100644 --- a/src/Domain/Math/Strategy/BrokenEquations.hs +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Strategy.BrokenEquations where - -import Prelude hiding (repeat) -import Common.Apply -import Common.Strategy -import Common.Transformation -import Common.Traversable -import Control.Monad -import Data.Ratio -import Domain.Math.Expr -import Domain.Math.Data.Equation -import Domain.Math.Data.OrList -import Domain.Math.View.Basic -import Domain.Math.ExercisesDWO -import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) -import Domain.Math.Polynomial.QuadraticEquations (solvedList) -import Domain.Math.Polynomial.Views -import Domain.Math.Strategy.CoverUpEquations (rule1) -{- -Equations: - (a/b) = 0 = a=0 - (a/b) = 1 = a=b - (a/c) = (b/c) = a==b - (a/b) = (a/c) = b==c --} - -main = forM_ (concat brokenEquations) $ \eq -> - let res = applyD brokenStrategy (OrList [eq]) - in if solvedList res then print "ok" else print res - --- TODO: check results afterwards (possibility of division by zero) -brokenStrategy :: LabeledStrategy (OrList (Equation Expr)) -brokenStrategy = label "broken" $ notBroken <*> - try (check p <*> equationsStrategy <*> repeat inconsistencies) - where p (OrList xs) = all (`belongsTo` polyView) $ concat [[a,b] | a:==: b <- xs] - -notBroken :: LabeledStrategy (OrList (Equation Expr)) -notBroken = label "not broken" $ repeat $ - alternatives [brokenZero, brokenOne, brokenSameDenom, brokenSameNum] - |> alternatives [coverUpPlus, brokenCross] - -coverUpPlus = rule1 - ------------------------------------------------------------------------- --- Equation rules - -brokenZero :: Rule (OrList (Equation Expr)) -brokenZero = makeSimpleRule "brokenZero" $ onceJoinM $ \(a :==: b) -> do - n <- match rationalView b - guard (n==0) - (x, _) <- match divView a - return $ OrList [x :==: 0] - `mplus` do - n <- match rationalView a - guard (n==0) - (x, _) <- match divView b - return $ OrList [x :==: 0] - -brokenOne :: Rule (OrList (Equation Expr)) -brokenOne = makeSimpleRule "brokenOne" $ onceJoinM $ \(a :==: b) -> do - n <- match rationalView b - guard (n==1) - (x, y) <- match divView a - return $ OrList [x :==: y] - `mplus` do - n <- match rationalView a - guard (n==1) - (x, y) <- match divView b - return $ OrList [x :==: y] - -brokenSameDenom :: Rule (OrList (Equation Expr)) -brokenSameDenom = makeSimpleRule "brokenSameDenom" $ onceJoinM $ \(a :==: b) -> do - (x1, y1) <- match divView a - (x2, y2) <- match divView b - guard (y1==y2) - return $ OrList [x1 :==: x2] - -brokenSameNum :: Rule (OrList (Equation Expr)) -brokenSameNum = makeSimpleRule "brokenSameNum" $ onceJoinM $ \(a :==: b) -> do - (x1, y1) <- match divView a - (x2, y2) <- match divView b - guard (x1==x2) - return $ OrList [y1 :==: y2] - -brokenCross :: Rule (OrList (Equation Expr)) -brokenCross = makeSimpleRule "brokenCross" $ onceJoinM $ \(a :==: b) -> do - let matchDiv e = match divView e `mplus` fmap f (match rationalView e) - f r = (fromInteger (numerator r), fromInteger (denominator r)) - (x1, y1) <- matchDiv a - (x2, y2) <- matchDiv b - return $ OrList[x1 .*. y2 :==: x2 .*. y1] - --- remove inconsistent equations from the or-list, such as 0==1 --- TODO: move this to a different module (should not be here) -inconsistencies :: Rule (OrList (Equation Expr)) -inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do - r1 <- match rationalView a - r2 <- match rationalView b - guard (r1 /= r2) - return $ OrList [] diff --git a/src/Domain/Math/Strategy/Modulus.hs b/src/Domain/Math/Strategy/Modulus.hs deleted file mode 100644 --- a/src/Domain/Math/Strategy/Modulus.hs +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Strategy.Modulus where - -import Prelude hiding (repeat) -import Common.Apply -import Common.Strategy -import Common.Uniplate -import Common.Transformation -import Common.Traversable -import Control.Monad -import Domain.Math.Expr -import Domain.Math.Expr.Symbols -import Domain.Math.Data.Equation -import Domain.Math.Data.OrList -import Domain.Math.View.Basic -import Domain.Math.ExercisesDWO -import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) -import Domain.Math.Polynomial.QuadraticEquations (solvedList) -{- -Simplifications: - abs r = r if r>=0 - -r if r<0 - abs (abs e) = abs e - abs (-e) = abs e - abs (sqrt e) = sqrt e - abs (e^n) = e^n if even n - -Distribution: - abs (a*b) = abs a * abs b - abs (a/b) = abs a / abs b - -Equations: - abs a = b = a = b or a = -b - abs a = abs b = a = b or a = -b (special case) --} - --- For level-4 exercises, I need cube-roots (to solve x^3=9) -main = forM_ (take 12 $ concat modulusEquations) $ \eq -> - let res = applyD modulusStrategy (OrList [eq]) - in if solvedList res then print "ok" else print res - -modulusStrategy :: LabeledStrategy (OrList (Equation Expr)) -modulusStrategy = label "modulus" $ noAbs <*> try (check p <*> equationsStrategy <*> repeat inconsistencies) - where p (OrList xs) = all absFree $ concat [[a,b] | a:==: b <- xs] - absFree e = null [ () | Sym s [_] <- universe e, s == absSymbol ] - -noAbs :: LabeledStrategy (OrList (Equation Expr)) -noAbs = label "remove modulus" $ repeat absEquation - ------------------------------------------------------------------------- --- Equation rules - -absEquation :: Rule (OrList (Equation Expr)) -absEquation = makeSimpleRule "abs in equation" $ onceJoinM f - where - f (Sym s1 [a] :==: Sym s2 [b]) | all (==absSymbol) [s1, s2] = - Just $ OrList [a :==: b, a :==: -b] - f (Sym s1 [a] :==: b ) | s1 == absSymbol = - Just $ OrList [a :==: b, a :==: -b] - f (a :==: Sym s2 [b]) | s2 == absSymbol = - Just $ OrList [a :==: b, -a :==: b] - f _ = Nothing - --- remove inconsistent equations from the or-list, such as 0==1 --- TODO: move this to a different module (should not be here) -inconsistencies :: Rule (OrList (Equation Expr)) -inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do - r1 <- match rationalView a - r2 <- match rationalView b - guard (r1 /= r2) - return $ OrList [] diff --git a/src/Domain/Math/Strategy/SquareRootEquations.hs b/src/Domain/Math/Strategy/SquareRootEquations.hs deleted file mode 100644 --- a/src/Domain/Math/Strategy/SquareRootEquations.hs +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Strategy.SquareRootEquations where - -import Prelude hiding (repeat) -import Common.Apply -import Common.Strategy hiding (not) -import Common.Transformation -import Common.Traversable -import Common.Uniplate (universe) -import Control.Monad -import Domain.Math.Expr -import Domain.Math.Data.Equation -import Domain.Math.Data.OrList -import Domain.Math.View.Basic -import Domain.Math.ExercisesDWO -import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) -import Domain.Math.Polynomial.QuadraticEquations (solvedList) -{- -Strategie (p21. G&R deel 1): -1) Isoleer wortel -2) Kwadrateer -3) Controleer - -Equations: - sqrt a = b = a = b^2 (if a >= 0, and b>=0) --} - -main = forM_ (concat sqrtEquations) $ \eq -> - let res = applyD sqrtStrategy (OrList [eq]) - in if solvedList res then print "ok" else print res - --- TODO: check results afterwards (invalid results due to squaring both sides) -sqrtStrategy :: LabeledStrategy (OrList (Equation Expr)) -sqrtStrategy = label "squareroot equation" $ isolate <*> repeat squareBoth <*> - try (check p <*> equationsStrategy <*> repeat inconsistencies) - where p (OrList xs) = all (not . varUnderSqrt) $ concat [[a,b] | a:==: b <- xs] - -isolate :: LabeledStrategy (OrList (Equation Expr)) -isolate = label "isolate" $ repeat $ alternatives - [coverUpPlus, coverUpTimes, coverUpNegation] - -varUnderSqrt :: Expr -> Bool -varUnderSqrt e = not $ null [ () | Sqrt a <- universe e, hasVars a ] - ------------------------------------------------------------------------- --- Equation rules - --- Isolation -coverUpPlus :: Rule (OrList (Equation Expr)) -coverUpPlus = makeSimpleRule "coverup plus" $ onceJoinM $ \(a :==: b) -> do - guard (not $ varUnderSqrt b) - (x, y) <- match plusView a - case (varUnderSqrt x, varUnderSqrt y) of - (True, False) -> return $ OrList [x :==: b .-. y] - (False, True ) -> return $ OrList [y :==: b .-. x] - _ -> Nothing - -coverUpNegation :: Rule (OrList (Equation Expr)) -coverUpNegation = makeSimpleRule "coverup negation" $ onceJoinM f - where - f (Negate a :==: b) | varUnderSqrt a && not (varUnderSqrt b) = - return $ OrList [a :==: Negate b] - f _ = Nothing - -coverUpTimes :: Rule (OrList (Equation Expr)) -coverUpTimes = makeSimpleRule "coverup times" $ onceJoinM $ \(a :==: b) -> do - guard (not $ varUnderSqrt b) - (x, y) <- match timesView a - case (varUnderSqrt x, varUnderSqrt y) of - (True, False) -> return $ OrList [x :==: b ./. y] - (False, True ) -> return $ OrList [y :==: b ./. x] - _ -> Nothing - --------------------------------------------------------------- - -squareBoth :: Rule (OrList (Equation Expr)) -squareBoth = makeSimpleRule "inconsistencies" $ onceJoinM f - where - f (Sqrt a :==: Sqrt b) = return $ OrList [a :==: b] - f (a :==: Sqrt b) = return $ OrList [a .^. 2 :==: b] - f (Sqrt a :==: b ) = return $ OrList [a :==: b .^. 2] - f _ = Nothing - --- remove inconsistent equations from the or-list, such as 0==1 --- TODO: move this to a different module (should not be here) -inconsistencies :: Rule (OrList (Equation Expr)) -inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do - r1 <- match rationalView a - r2 <- match rationalView b - guard (r1 /= r2) - return $ OrList [] diff --git a/src/Domain/Math/Strategy/SquareRootSimplification.hs b/src/Domain/Math/Strategy/SquareRootSimplification.hs deleted file mode 100644 --- a/src/Domain/Math/Strategy/SquareRootSimplification.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Strategy.SquareRootSimplification where - -import Prelude hiding (repeat) -import Common.Apply -import Common.Strategy hiding (not) -import Common.Transformation -import Common.Uniplate (universe) -import Control.Monad -import Domain.Math.Expr -import Domain.Math.Data.Equation -import Domain.Math.Data.OrList -import Domain.Math.View.Basic -import Domain.Math.ExercisesDWO -import Domain.Math.View.SquareRoot -import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) -{- -Strategie (p21. G&R deel 1): -1) Isoleer wortel -2) Kwadrateer -3) Controleer - -Equations: - sqrt a = b = a = b^2 (if a >= 0, and b>=0) --} - -main = forM_ (concat simplerSqrt) $ \e -> - if e `belongsTo` squareRootView then print "ok" else print e - --- TODO: check results afterwards (invalid results due to squaring both sides) -{- -sqrtStrategy :: LabeledStrategy (OrList (Equation Expr)) -sqrtStrategy = label "squareroot equation" $ isolate <*> repeat squareBoth <*> - try (check p <*> equationsStrategy <*> repeat inconsistencies) - where p (OrList xs) = all (not . varUnderSqrt) $ concat [[a,b] | a:==: b <- xs] --} -isolate :: LabeledStrategy (OrList (Equation Expr)) -isolate = undefined - ------------------------------------------------------------------------- --- Equation rules -{- --- Isolation -coverUpPlus :: Rule (OrList (Equation Expr)) -coverUpPlus = makeSimpleRuleList "coverup plus" $ forOne $ \(a :==: b) -> do - guard (not $ varUnderSqrt b) - (x, y) <- match plusView a - case (varUnderSqrt x, varUnderSqrt y) of - (True, False) -> return [x :==: b .-. y] - (False, True ) -> return [y :==: b .-. x] - _ -> Nothing - -coverUpNegation :: Rule (OrList (Equation Expr)) -coverUpNegation = makeSimpleRuleList "coverup negation" $ forOne f - where - f (Negate a :==: b) | varUnderSqrt a && not (varUnderSqrt b) = - return [a :==: Negate b] - f _ = Nothing - -coverUpTimes :: Rule (OrList (Equation Expr)) -coverUpTimes = makeSimpleRuleList "coverup times" $ forOne $ \(a :==: b) -> do - guard (not $ varUnderSqrt b) - (x, y) <- match timesView a - case (varUnderSqrt x, varUnderSqrt y) of - (True, False) -> return [x :==: b ./. y] - (False, True ) -> return [y :==: b ./. x] - _ -> Nothing - --------------------------------------------------------------- - -squareBoth :: Rule (OrList (Equation Expr)) -squareBoth = makeSimpleRuleList "inconsistencies" $ forOne f - where - f (Sqrt a :==: Sqrt b) = return [a :==: b] - f (a :==: Sqrt b) = return [a .^. 2 :==: b] - f (Sqrt a :==: b ) = return [a :==: b .^. 2] - f _ = Nothing - --- remove inconsistent equations from the or-list, such as 0==1 --- TODO: move this to a different module (should not be here) -inconsistencies :: Rule (OrList (Equation Expr)) -inconsistencies = makeSimpleRuleList "inconsistencies" $ forOne $ \(a :==: b) -> do - r1 <- match rationalView a - r2 <- match rationalView b - guard (r1 /= r2) - return [] -} diff --git a/src/Domain/Programming.hs b/src/Domain/Programming.hs deleted file mode 100644 --- a/src/Domain/Programming.hs +++ /dev/null @@ -1,29 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Programming - ( module Domain.Programming.Expr - , module Domain.Programming.Prelude - , module Domain.Programming.Eval - , module Domain.Programming.Parser - , module Domain.Programming.Strategies - , module Domain.Programming.Rules - , module Domain.Programming.Exercises - ) where - -import Domain.Programming.Expr -import Domain.Programming.Prelude -import Domain.Programming.Eval -import Domain.Programming.Parser -import Domain.Programming.Strategies -import Domain.Programming.Rules -import Domain.Programming.Exercises - diff --git a/src/Domain/RegularExpr/Definitions.hs b/src/Domain/RegularExpr/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RegularExpr/Definitions.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RegularExpr.Definitions where + +import Domain.RegularExpr.Expr +import Common.Uniplate +import Common.Utils (distinct) + +deterministic :: (Show a, Eq a) => RE a -> Bool +deterministic r = deterministicSimple r {- + case (deterministicSimple r, det r) of + (b1, b2) | b1==b2 -> b1 + _ -> error $ show r -} + +deterministicSimple :: Eq a => RE a -> Bool +deterministicSimple regexp = + distinct (lookahead regexp) && all deterministicSimple (children regexp) + +det :: Eq a => RE a -> Bool +det regexp = + case regexp of + EmptySet -> True + Epsilon -> True + Atom _ -> True + Option r -> det (r :|: Epsilon) + Star r -> det r + Plus r -> det (r :*: Star r) + r :|: s -> lookahead r `disj` lookahead s && det r && det s + EmptySet :*: r -> det r + Epsilon :*: r -> det r + Atom _ :*: r -> det r + Option s :*: r -> det ((s :|: Epsilon) :*: r) + Star s :*: r -> lookahead s `disj` lookahead r && det s && det r + Plus s :*: r -> det ((s :*: Star s) :*: r) + (q :|: s) :*: r -> det ((q :*: r) :|: (s :*: r)) + (q :*: s) :*: r -> det (q :*: (s :*: r)) + + +disj xs ys = all (`notElem` xs) ys + +empty :: RE a -> Bool +empty = foldRE (False, True, const (False), const True, const True, id, (&&), (||)) + +lookahead :: RE a -> [a] +lookahead = map fst . firsts + +firsts :: RE a -> [(a, RE a)] +firsts regexp = + case regexp of + EmptySet -> [] + Epsilon -> [] + Atom a -> [(a, Epsilon)] + Option r -> firsts r + Star r -> firsts (nonempty r :*: Star r) + Plus r -> firsts (r :*: Star r) + r :*: s -> [ (a, q :*: s) | (a, q) <- firsts r ] ++ + (if empty r then firsts s else []) + r :|: s -> firsts r ++ firsts s + +nonempty :: RE a -> RE a +nonempty regexp = foldr (:|:) EmptySet [ Atom a :*: r | (a, r) <- firsts regexp ] diff --git a/src/Domain/RegularExpr/Exercises.hs b/src/Domain/RegularExpr/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RegularExpr/Exercises.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RegularExpr.Exercises (regexpExercise) where + +import Common.Exercise +import Common.Navigator +import Common.Traversable +import Common.Rewriting hiding (difference) +import Domain.RegularExpr.Expr +import Domain.RegularExpr.Parser +import Domain.RegularExpr.Strategy +import Domain.RegularExpr.Definitions +import Control.Monad +import System.Random +import Test.QuickCheck + +regexpExercise :: Exercise RegExp +regexpExercise = makeExercise + { description = "Rewrite a regular expression" + , exerciseCode = makeCode "regexp" "normalform" + , status = Experimental + , parser = parseRegExp + , prettyPrinter = ppRegExp +-- , equivalence = eqRE + , similarity = equalWith operators -- modulo associativity + , isReady = deterministic + , isSuitable = (>1) . length . crush + , difference = differenceMode eqRE + , strategy = deterministicStrategy + , navigation = navigator +-- , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy + , testGenerator = Just startFormGen -- arbitrary + , randomExercise = simpleGenerator startFormGen -- myGen + , examples = generate 5 (mkStdGen 2805) (replicateM 15 startFormGen) + } + +-- myGen :: Gen RegExp +-- myGen = restrictGenerator (isSuitable regexpExercise) arbitrary + +startFormGen :: Gen RegExp +startFormGen = do + i <- oneof $ map return [1..10] + xs <- replicateM i $ do + j <- oneof $ map return [1..5] + ys <- replicateM j $ oneof $ map (return . Atom . return) "abcd" + return $ foldr1 (:*:) ys + return $ foldr1 (:|:) xs + +-- equivalence of regular expressions +eqRE :: Eq a => RE a -> RE a -> Bool +eqRE = (==) + +{- +checkUntil :: Ord a => Int -> RE a -> RE a -> Bool +checkUntil n r s = empty r == empty s && (n==0 || next) + where + make = groupBy eqFst . sortBy cmpFst . firsts + eqFst (a, _) (b, _) = a==b + cmpFst (a, _) (b, _) = compare a b + + as = make r + bs = make s + next = and ((length as == length bs) : zipWith f as bs) + + -- f ((a, _): + f _ _ = False -} diff --git a/src/Domain/RegularExpr/Expr.hs b/src/Domain/RegularExpr/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RegularExpr/Expr.hs @@ -0,0 +1,175 @@ +{-# OPTIONS -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RegularExpr.Expr where + +import Common.Rewriting +import Common.Traversable +import Common.Uniplate +import Control.Monad +import Domain.Math.Expr.Symbolic +import Test.QuickCheck + +-------------------------------------------------------------------- +-- Data type declaration + +infixl 4 :|: +infixl 5 :*: + +type RegExp = RE String + +data RE a = EmptySet | Epsilon | Atom a | Option (RE a) | Star (RE a) + | Plus (RE a) | RE a :*: RE a | RE a :|: RE a + deriving (Show, Eq, Ord) + +-------------------------------------------------------------------- +-- Fold + +foldRE (es, eps, at, opt, st, pl, sq, ch) = rec + where + rec regexp = + case regexp of + EmptySet -> es + Epsilon -> eps + Atom a -> at a + Option r -> opt (rec r) + Star r -> st (rec r) + Plus r -> pl (rec r) + r :*: s -> sq (rec r) (rec s) + r :|: s -> ch (rec r) (rec s) + +-------------------------------------------------------------------- +-- General instances + +instance Functor RE where + fmap f = foldRE (EmptySet, Epsilon, Atom . f, Option, Star, Plus, (:*:), (:|:)) + +instance Crush RE where + crush (Atom a) = [a] + crush regexp = concatMap crush (children regexp) + +instance Arbitrary RegExp where + arbitrary = sized (arbRE $ oneof $ map return ["a", "b", "c", "d"]) +instance CoArbitrary RegExp where + coarbitrary = foldRE + ( variant 0 + , variant 1 + , \a -> variant 2 . coarbitrary a + , \a -> variant 3 . a + , \a -> variant 4 . a + , \a -> variant 5 . a + , \a b -> variant 6 . a . b + , \a b -> variant 7 . a . b + ) + +arbRE :: Gen a -> Int -> Gen (RE a) +arbRE g n + | n == 0 = frequency + [ (6, liftM Atom g) + , (3, return Epsilon) + , (1, return EmptySet) + ] + | otherwise = frequency + [ (3, arbRE g 0) + , (2, unop Star) -- (1, unop Option), (1, unop Plus) + , (3, binop (:*:)), (3, binop (:|:)) + ] + where + rec = arbRE g (n `div` 2) + unop f = liftM f rec + binop f = liftM2 f rec rec + +-------------------------------------------------------------------- +-- Pretty-printer + +ppRegExp :: RegExp -> String +ppRegExp = ppWith (const id) + +ppWith :: (Int -> a -> String) -> RE a -> String +ppWith f = ($ 0) . foldRE + (const "F", const "T", flip f, unop "?", unop "*", unop "+", binop 5 "", binop 4 "|") + where + unop s a _ = parIf False (a 6 ++ s) + binop i s a b n = parIf (n > i) (a i ++ s ++ b i) + parIf b s = if b then "(" ++ s ++ ")" else s + +--testje = ppWith (const id) (Star (Plus (Atom "P")) :*: (Option (Atom "Q" :*: Option (Atom "S")) :|: Atom "R")) + +-------------------------------------------------------------------- +-- Function for associative operators + +concatOp :: Operator (RE a) +concatOp = associativeOperator (:*:) isConcat + where + isConcat (r :*: s) = Just (r, s) + isConcat _ = Nothing + +choiceOp :: Operator (RE a) +choiceOp = associativeOperator (:|:) isChoice + where + isChoice (r :|: s) = Just (r, s) + isChoice _ = Nothing + +-------------------------------------------------------------------- +-- Instances for rewriting + +instance Uniplate (RE a) where + uniplate regexp = + case regexp of + EmptySet -> ([], \[] -> EmptySet) + Epsilon -> ([], \[] -> Epsilon) + Atom a -> ([], \[] -> Atom a) + Option r -> ([r], \[a] -> Option a) + Star r -> ([r], \[a] -> Star a) + Plus r -> ([r], \[a] -> Plus a) + r :*: s -> ([r, s], \[a, b] -> a :*: b) + r :|: s -> ([r, s], \[a, b] -> a :|: b) + +instance Eq a => ShallowEq (RE a) where + shallowEq re1 re2 = + case (re1, re2) of + (EmptySet, EmptySet) -> True + (Epsilon, Epsilon ) -> True + (Atom a, Atom b ) -> a==b + (Option _, Option _) -> True + (Star _, Star _ ) -> True + (Plus _, Plus _ ) -> True + (_ :*: _, _ :*: _ ) -> True + (_ :|: _, _ :|: _ ) -> True + _ -> False + +instance Different (RE a) where + different = (EmptySet, Epsilon) + +instance IsTerm RegExp where + toTerm = foldRE + ( nullary "EmptySet", nullary "Epsilon", variable, unary "Option" + , unary "Star", unary "Plus", binary ":*:", binary ":|:" + ) + + fromTerm a = fromTermWith f a `mplus` liftM Atom (getVariable a) + where + f s [] + | s == "EmptySet" = return EmptySet + | s == "Epsilon" = return Epsilon + f s [x] + | s == "Option" = return (Option x) + | s == "Star" = return (Star x) + | s == "Plus" = return (Plus x) + f s [x, y] + | s == ":*:" = return (x :*: y) + | s == ":|:" = return (x :|: y) + f _ _ = fail "fromExpr" + +instance Rewrite RegExp where + operators = [concatOp, choiceOp] + associativeOps = const $ map toSymbol [":*:", ":|:"] diff --git a/src/Domain/RegularExpr/Parser.hs b/src/Domain/RegularExpr/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RegularExpr/Parser.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RegularExpr.Parser (parseRegExp) where + +import Domain.RegularExpr.Expr +import Text.Parsing + +logicScanner :: Scanner +logicScanner = (specialSymbols "+*?|" defaultScanner) + { keywords = ["T", "F"] + , keywordOperators = ["+", "*", "?", "|"] + , isIdentifierCharacter = const False + } + +parseRegExp :: String -> Either String RegExp +parseRegExp = parseWithM logicScanner pRE + +pRE :: TokenParser RegExp +pRE = pOr + where + pOr = pChainl ((:|:) <$ pKey "|") pSeq + pSeq = foldl1 (:*:) <$> pList1 pPost + pPost = foldl (flip ($)) <$> pAtom <*> pList pUnop + pUnop = Star <$ pKey "*" <|> Plus <$ pKey "+" <|> Option <$ pKey "?" + pAtom = Atom <$> (pVarid <|> pConid) + <|> Epsilon <$ pKey "T" + <|> EmptySet <$ pKey "F" + <|> pSpec '(' *> pRE <* pSpec ')' + +-- testje = parseRegExp "P+*((QS?)?|R)" diff --git a/src/Domain/RegularExpr/Strategy.hs b/src/Domain/RegularExpr/Strategy.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RegularExpr/Strategy.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RegularExpr.Strategy (deterministicStrategy) where + +import Domain.RegularExpr.Expr +import Common.Context +import Common.Strategy +import Common.Rewriting +import Common.Transformation +import Prelude hiding (repeat, replicate) + +deterministicStrategy :: LabeledStrategy (Context RegExp) +deterministicStrategy = label "deterministic and precise" $ + repeat (somewhere + ((liftToContext ruleLeftFactor1 <|> + liftToContext ruleLeftFactor2 <|> + liftToContext ruleIdempOr <|> + -- liftToContext ruleEpsilonSeq <|> + -- liftToContext ruleEmptySeq <|> + -- liftToContext ruleEmptyChoice <|> + liftToContext ruleDefOption) |> + liftToContext ruleCommFactor)) + <*> + repeat (somewhere (liftToContext ruleIntroOption)) + +ruleLeftFactor1 :: Rule RegExp +ruleLeftFactor1 = rule "LeftFactor1" $ \a x y -> + (a :*: x) :|: (a :*: y) :~> a :*: (x :|: y) + +ruleLeftFactor2 :: Rule RegExp +ruleLeftFactor2 = ruleList "LeftFactor2" $ + [ \a x -> (a :*: x) :|: a :~> a :*: Option x + , \a x -> a :|: (a :*: x) :~> a :*: Option x + ] + +ruleIdempOr :: Rule RegExp +ruleIdempOr = rule "IdempOr" $ \a -> + a :|: a :~> a + +ruleCommFactor :: Rule RegExp +ruleCommFactor = ruleList "CommFactor" + [ \a b _ _ -> a :|: b :|: a :~> a :|: a :|: b + , \a b x _ -> (a :*: x) :|: b :|: a :~> (a :*: x) :|: a :|: b + , \a b y _ -> a :|: b :|: (a :*: y) :~> a :|: (a :*: y) :|: b + , \a b x y -> (a :*: x) :|: b :|: (a :*: y) :~> (a :*: x) :|: (a :*: y) :|: b + ] + + + +ruleDefOption :: Rule RegExp +ruleDefOption = rule "DefOption" $ \a -> + Option a :~> Epsilon :|: a + +ruleIntroOption :: Rule RegExp +ruleIntroOption = ruleList "IntroOption" + [ \a -> Epsilon :|: a :~> Option a + , \a -> a :|: Epsilon :~> Option a + ] + +--- +{- +ruleEpsilonSeq :: Rule RegExp +ruleEpsilonSeq = ruleList "EpsilonSeq" + [ \a -> Epsilon :*: a :~> a + , \a -> a :*: Epsilon :~> a + ] + +ruleEmptySeq :: Rule RegExp +ruleEmptySeq = ruleList "EmptySeq" + [ \a -> EmptySet :*: a :~> EmptySet + , \a -> a :*: EmptySet :~> EmptySet + ] + +ruleEmptyChoice :: Rule RegExp +ruleEmptyChoice = ruleList "EmptyChoice" + [ \a -> EmptySet :|: a :~> a + , \a -> a :|: EmptySet :~> a + ] +-} +----------------- +{- +ruleComm :: Rule RegExp +ruleComm = makeSimpleRuleList "Comm" $ \re -> do + let xs = collectWithOperator choiceOp re + i <- [0..length xs-1] + j <- [i+2..length xs-1] + let (as, b:bs) = splitAt i xs + (cs, d:ds) = splitAt (j-i-1) bs + guard (all (`notElem` (lookahead b)) (lookahead d)) + let new = as++[b,d]++cs++ds + return (buildWithOperator choiceOp new)-} diff --git a/src/Domain/RelationAlgebra.hs b/src/Domain/RelationAlgebra.hs --- a/src/Domain/RelationAlgebra.hs +++ b/src/Domain/RelationAlgebra.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/RelationAlgebra/Equivalence.hs b/src/Domain/RelationAlgebra/Equivalence.hs --- a/src/Domain/RelationAlgebra/Equivalence.hs +++ b/src/Domain/RelationAlgebra/Equivalence.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/RelationAlgebra/Exercises.hs b/src/Domain/RelationAlgebra/Exercises.hs --- a/src/Domain/RelationAlgebra/Exercises.hs +++ b/src/Domain/RelationAlgebra/Exercises.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -21,25 +21,26 @@ import Common.Exercise import Common.Context import Data.Maybe -import Text.Parsing (fromRanged) import Common.Derivation import Common.Rewriting (differenceMode) import Common.Strategy hiding (not) import Common.Transformation +import Common.Navigator cnfExercise :: Exercise RelAlg cnfExercise = testableExercise { description = "To conjunctive normal form" , exerciseCode = makeCode "relationalg" "cnf" - , status = Provisional - , parser = either Left (Right . fromRanged) . parseRelAlg + , status = Alpha + , parser = parseRelAlg , prettyPrinter = ppRelAlg , equivalence = probablyEqual -- isEquivalent , extraRules = map liftToContext (relAlgRules ++ buggyRelAlgRules) , strategy = toCNF + , navigation = navigator , difference = differenceMode probablyEqual , ordering = compare - , isReady = ready (ruleset cnfExercise) + , isReady = ready cnfExercise , randomExercise = let ok p = let n = fromMaybe maxBound (stepsRemaining 4 p) in n >= 2 && n <= 4 in useGenerator ok (\_ -> templateGenerator 1) @@ -47,7 +48,7 @@ stepsRemaining :: Int -> RelAlg -> Maybe Int stepsRemaining i = - lengthMax i . derivationTree toCNF . inContext + lengthMax i . derivationTree toCNF . inContext cnfExercise {- cnfExerciseSimple :: Exercise RelAlg cnfExerciseSimple = cnfExercise @@ -56,5 +57,6 @@ , strategy = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise } -} -ready :: [Rule (Context a)] -> a -> Bool -ready rs = null . applyAll (alternatives $ filter (not . isBuggyRule) rs) . inContext +ready :: Exercise a -> a -> Bool +ready ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex)) + . inContext ex diff --git a/src/Domain/RelationAlgebra/Formula.hs b/src/Domain/RelationAlgebra/Formula.hs --- a/src/Domain/RelationAlgebra/Formula.hs +++ b/src/Domain/RelationAlgebra/Formula.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,13 +11,13 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Formula where +import Domain.Math.Expr.Symbolic +import Common.Exercise (generate) import Common.Uniplate (Uniplate(..)) import Common.Rewriting import Common.Utils import Control.Monad -import Data.Char import Data.List -import Data.Maybe import qualified Data.Set as S import System.Random (StdGen, mkStdGen, split) import Test.QuickCheck @@ -47,7 +47,6 @@ ------------------------------------- - isAtom :: RelAlg -> Bool isAtom r = case r of @@ -170,11 +169,6 @@ Inv s -> ([s], \[a] -> Inv a) _ -> ([], \[] -> term) -instance MetaVar RelAlg where - isMetaVar (Var a) = isMetaVar a - isMetaVar _ = Nothing - metaVar = Var . metaVar - instance ShallowEq RelAlg where shallowEq expr1 expr2 = case (expr1, expr2) of @@ -187,4 +181,29 @@ (Inv _ , Inv _ ) -> True (V , V ) -> True (I , I ) -> True - _ -> False + _ -> False + +instance Different RelAlg where + different = (V, I) + +instance IsTerm RelAlg where + toTerm = foldRelAlg + ( variable, binary ".", binary "+", binary "&&", binary "||" + , unary "~", unary "-", nullary "V", nullary "I" + ) + + fromTerm a = + fromTermWith f a `mplus` liftM Var (getVariable a) + where + f s [] + | s == "V" = return V + | s == "I" = return I + f s [x] + | s == "~" = return (Not x) + | s == "-" = return (Inv x) + f s [x, y] + | s == "." = return (x :.: y) + | s == "+" = return (x :+: y) + | s == "&&" = return (x :&&: y) + | s == "||" = return (x :||: y) + f _ _ = fail "fromTerm" diff --git a/src/Domain/RelationAlgebra/Generator.hs b/src/Domain/RelationAlgebra/Generator.hs --- a/src/Domain/RelationAlgebra/Generator.hs +++ b/src/Domain/RelationAlgebra/Generator.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,12 +14,13 @@ import Domain.RelationAlgebra.Formula import Common.Rewriting import Control.Monad -import Test.QuickCheck +import Test.QuickCheck instance Rewrite RelAlg instance Arbitrary RelAlg where - arbitrary = sized arbRelAlg + arbitrary = sized (arbRelAlg . min 8) +instance CoArbitrary RelAlg where coarbitrary term = case term of Var x -> variant 0 . coarbitrary x diff --git a/src/Domain/RelationAlgebra/Parser.hs b/src/Domain/RelationAlgebra/Parser.hs --- a/src/Domain/RelationAlgebra/Parser.hs +++ b/src/Domain/RelationAlgebra/Parser.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,12 +13,12 @@ import Domain.RelationAlgebra.Formula import Text.Parsing -import Data.Char myScanner :: Scanner -myScanner = minusAsSpecial $ makeCharsSpecial "~" defaultScanner +myScanner = defaultScanner { keywords = ["V", "E", "I"] - , keywordOperators = concatMap (map fst . snd) operatorTable + , keywordOperators = invSym : notSym : concatMap (map fst . snd) operatorTable + , specialCharacters = "-~" ++ specialCharacters defaultScanner } operatorTable :: OperatorTable RelAlg @@ -38,37 +38,38 @@ ----------------------------------------------------------- --- Parser -parseRelAlg :: String -> Either SyntaxError (Ranged RelAlg) +parseRelAlg :: String -> Either String RelAlg parseRelAlg = analyseAndParse pRelAlg . scanWith myScanner -pRelAlg :: Parser Token (Ranged RelAlg) +pRelAlg :: Parser Token RelAlg pRelAlg = pOperators operatorTable pTerm -- Two postfix operators -pTerm :: Parser Token (Ranged RelAlg) +pTerm :: Parser Token RelAlg pTerm = foldl (flip ($)) <$> pAtom <*> pList pUnOp where - pUnOp = unaryOp Inv <$> pKey invSym - <|> unaryOp Not <$> pKey notSym + pUnOp = Inv <$ pKey invSym + <|> Not <$ pKey notSym -pAtom :: Parser Token (Ranged RelAlg) -pAtom = (\(s, r) -> toRanged (Var s) r) <$> pVarid +pAtom :: Parser Token RelAlg +pAtom = Var <$> pVarid <|> pParens pRelAlg - <|> toRanged V <$> pKey "V" - <|> toRanged empty <$> pKey "E" - <|> toRanged I <$> pKey "I" + <|> const V <$> pKey "V" + <|> const empty <$> pKey "E" + <|> const I <$> pKey "I" ----------------------------------------------------------- --- Helper-function for parentheses analyses -analyseAndParse :: Parser Token a -> [Token] -> Either SyntaxError a +analyseAndParse :: Parser Token a -> [Token] -> Either String a analyseAndParse p ts = case checkParentheses ts of - Just err -> Left err - Nothing -> case parse p ts of - (_, m:_) -> Left (fromMessage m) - (a, _) -> Right a - + Just err -> Left (show err) + Nothing -> either (Left . f) Right (parse p ts) + where + f (Just t) = show (tokenPosition t) ++ ": Unexpected " ++ show t + f Nothing = "Syntax error" + ----------------------------------------------------------- --- Pretty-Printer diff --git a/src/Domain/RelationAlgebra/Rules.hs b/src/Domain/RelationAlgebra/Rules.hs --- a/src/Domain/RelationAlgebra/Rules.hs +++ b/src/Domain/RelationAlgebra/Rules.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Domain/RelationAlgebra/Strategies.hs b/src/Domain/RelationAlgebra/Strategies.hs --- a/src/Domain/RelationAlgebra/Strategies.hs +++ b/src/Domain/RelationAlgebra/Strategies.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Main module for feedback services +-- +----------------------------------------------------------------------------- +module Main (main) where + +import Common.Utils (useFixedStdGen) +import Control.Monad +import Control.Monad.Trans +import Data.IORef +import Data.Time +import Documentation.Make +import Main.ExerciseList +import Main.LoggingDatabase +import Main.Options +import Network.CGI +import Service.ModeJSON (processJSON) +import Service.ModeXML (processXML) +import Service.Request + +main :: IO () +main = do + startTime <- getCurrentTime + flags <- serviceOptions + logRef <- newIORef (return ()) + + case withInputFile flags of + -- from file + Just file -> do + when (FixRNG `elem` flags) + useFixedStdGen -- use a predictable "random" number generator + input <- readFile file + (req, txt, _) <- process input + when (Logging True `elem` flags) $ + writeIORef logRef $ -- save logging action for later + logMessage req input txt "local" startTime + putStrLn txt + + -- documentation mode + _ | documentationMode flags -> + useIDEAS $ + mapM_ makeDocumentation (docItems flags) + + -- cgi binary + Nothing -> runCGI $ do + addr <- remoteAddr -- the IP address of the remote host making the request + raw <- getInput "input" -- read input + input <- case raw of + Nothing -> fail "Invalid request: environment variable \"input\" is empty" + Just s -> return s + (req, txt, ctp) <- lift $ process input + lift $ writeIORef logRef $ -- save logging action for later + logMessage req input txt addr startTime + setHeader "Content-type" ctp + output txt + + -- log request to database + when (withLogging flags) $ + join (readIORef logRef) + +process :: String -> IO (Request, String, String) +process input = useIDEAS $ + case discoverDataFormat input of + Just XML -> processXML input + Just JSON -> processJSON input + _ -> fail "Invalid input" diff --git a/src/Main/ExerciseList.hs b/src/Main/ExerciseList.hs new file mode 100644 --- /dev/null +++ b/src/Main/ExerciseList.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Main.ExerciseList (packages, useIDEAS) where + +import Common.Utils (Some(..), fromShowString) +import Common.Rewriting +import Domain.Math.Expr +import Service.ExercisePackage +import Service.FeedbackText +import Service.DomainReasoner +import qualified Domain.LinearAlgebra as LA +import qualified Domain.Logic as Logic +import qualified Domain.Logic.FeedbackText as Logic +import qualified Domain.RelationAlgebra as RA +import qualified Domain.Math.DerivativeExercise as Math +import qualified Domain.Math.Numeric.Exercises as Math +import qualified Domain.Math.Equation.CoverUpExercise as Math +import qualified Domain.Math.Polynomial.Exercises as Math +import qualified Domain.Math.Polynomial.IneqExercises as Math +import qualified Domain.RegularExpr.Exercises as RE +import qualified Domain.Math.Power.Exercises as Math +import Main.Options +import Service.ServiceList + +packages :: [Some ExercisePackage] +packages = + [ -- logic and relation-algebra + Some (package Logic.dnfExercise) + { withOpenMath = True + , toOpenMath = termToOMOBJ . toTerm . fmap (Var . fromShowString) + , fromOpenMath = (>>= fromTerm) . omobjToTerm + , getExerciseText = Just logicText + } + , Some (package Logic.dnfUnicodeExercise) + { withOpenMath = True + , toOpenMath = termToOMOBJ . toTerm . fmap (Var . fromShowString) + , fromOpenMath = (>>= fromTerm) . omobjToTerm + , getExerciseText = Just logicText + } + , somePackage RA.cnfExercise + -- basic math + , someTermPackage Math.naturalExercise + , someTermPackage Math.integerExercise + , someTermPackage Math.rationalExercise + , someTermPackage Math.fractionExercise + , someTermPackage Math.coverUpExercise + , someTermPackage Math.linearExercise + , someTermPackage Math.linearMixedExercise + , someTermPackage Math.quadraticExercise + , someTermPackage Math.higherDegreeExercise + , someTermPackage Math.findFactorsExercise + , someTermPackage Math.ineqLinearExercise + , someTermPackage Math.ineqQuadraticExercise + , someTermPackage Math.ineqHigherDegreeExercise + , someTermPackage Math.quadraticNoABCExercise + , someTermPackage Math.quadraticWithApproximation + , someTermPackage Math.derivativeExercise + , someTermPackage Math.simplifyPowerExercise + , someTermPackage Math.powerOfExercise + , someTermPackage Math.nonNegExpExercise + , someTermPackage Math.calcPowerExercise + -- linear algebra + , someTermPackage LA.gramSchmidtExercise + , someTermPackage LA.linearSystemExercise + , someTermPackage LA.gaussianElimExercise + , someTermPackage LA.systemWithMatrixExercise + -- regular expressions + , somePackage RE.regexpExercise + ] + +logicText :: ExerciseText Logic.SLogic +logicText = ExerciseText + { ruleText = Logic.ruleText + , appliedRule = Logic.appliedRule + , feedbackSyntaxError = Logic.feedbackSyntaxError + , feedbackSame = Logic.feedbackSame + , feedbackBuggy = Logic.feedbackBuggy + , feedbackNotEquivalent = Logic.feedbackNotEquivalent + , feedbackOk = Logic.feedbackOk + , feedbackDetour = Logic.feedbackDetour + , feedbackUnknown = Logic.feedbackUnknown + } + +useIDEAS :: DomainReasoner a -> IO a +useIDEAS action = runDomainReasoner $ do + setVersion shortVersion + setFullVersion fullVersion + addPackages packages + addServices serviceList + addPkgService exerciselistS + action diff --git a/src/Main/LoggingDatabase.hs b/src/Main/LoggingDatabase.hs new file mode 100644 --- /dev/null +++ b/src/Main/LoggingDatabase.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Facilities to create a log database +-- +----------------------------------------------------------------------------- +module Main.LoggingDatabase (logMessage, logEnabled) where + +import Data.Time +import Service.Request +#ifdef DB +import Data.Maybe +import Database.HDBC +import Database.HDBC.Sqlite3 (connectSqlite3) + +logEnabled :: Bool +logEnabled = True + +-- | Log a message to the database (a Sqlite database). +logMessage :: Request -> String -> String -> String -> UTCTime -> IO () +logMessage req input output ipaddress begin = do + -- make a connection with the database + conn <- connectSqlite3 "service.db" + + -- check if the database exists, if not make one + --tables <- getTables conn + --if not (elem "log" tables) then run conn createStmt [] else return 0 + + -- calculate duration + end <- getCurrentTime + let diff = diffUTCTime end begin + + -- insert data into database + run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" + [ toSql $ service req + , toSql $ maybe "unknown" show (exerciseID req) + , toSql $ fromMaybe "unknown" (source req) + , toSql $ show (dataformat req) + , toSql $ maybe "unknown" show (encoding req) + , toSql $ input + , toSql $ output + , toSql $ ipaddress + , toSql $ begin + , toSql $ diff + ] + commit conn + + -- close the connection to the database + disconnect conn + `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err + +{- +-- | Log table schema +createStmt = "CREATE TABLE log ( service VARCHAR(250)" + ++ ", exerciseID VARCHAR(250)" + ++ ", source VARCHAR(250)" + ++ ", dataformat VARCHAR(250)" + ++ ", encoding VARCHAR(250)" + ++ ", input VARCHAR(250)" + ++ ", output VARCHAR(250)" + ++ ", ipaddress VARCHAR(20)" + ++ ", time TIME" + ++ ", responsetime TIME)" +-} +#else +logMessage :: Request -> String -> String -> String -> UTCTime -> IO () +logMessage _ _ _ _ _ = return () + +logEnabled :: Bool +logEnabled = False +#endif + diff --git a/src/Main/Options.hs b/src/Main/Options.hs new file mode 100644 --- /dev/null +++ b/src/Main/Options.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Options and command-line flags for services +-- +----------------------------------------------------------------------------- +module Main.Options where + +import Data.Maybe +import Documentation.Make +import Main.LoggingDatabase (logEnabled) +import Main.Revision +import System.Console.GetOpt +import System.Environment +import System.Exit + +data Flag = Version | Help | Logging Bool | InputFile String + | FixRNG | DocItem DocItem + deriving Eq + +header :: String +header = + "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ + "Copyright 2010, Open Universiteit Nederland\n" ++ + versionText ++ + "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ + "\nOptions:" + +versionText :: String +versionText = + "version " ++ version ++ ", revision " ++ show revision ++ + ", logging " ++ (if logEnabled then "enabled" else "disabled") + +fullVersion :: String +fullVersion = "version " ++ version ++ " (revision " + ++ show revision ++ ", " ++ lastChanged ++ ")" + +shortVersion :: String +shortVersion = version ++ " (" ++ show revision ++ ")" + +options :: [OptDescr Flag] +options = + [ Option [] ["version"] (NoArg Version) "show version number" + , Option "?" ["help"] (NoArg Help) "show options" + , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" + , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" + , Option "f" ["file"] (ReqArg InputFile "FILE") "use input FILE as request" + , Option "" ["fixed-rng"] (NoArg FixRNG) "use a fixed random-number generator" + , Option "" ["make-pages"] (docItemDescr (Pages . fromMaybe "docs")) "generate pages for exercises and services" + , Option "" ["make-rules"] (docItemDescr (LatexRules . fromMaybe "docs")) "generate latex code for rewrite rules" + , Option "" ["self-check"] (docItemDescr (SelfCheck . fromMaybe "test")) "perform a self-check" + ] + +docItemDescr :: (Maybe String -> DocItem) -> ArgDescr Flag +docItemDescr f = OptArg (DocItem . f) "DIR" + +serviceOptions :: IO [Flag] +serviceOptions = do + args <- getArgs + case getOpt Permute options args of + (flags, [], []) + | flags == [Version] -> do + putStrLn ("IDEAS, " ++ versionText) + exitSuccess + | all (`notElem` flags) [Version, Help] -> + return flags + (_, _, errs) -> do + putStrLn (concat errs ++ usageInfo header options) + exitFailure + +docItems :: [Flag] -> [DocItem] +docItems flags = [ x | DocItem x <- flags ] + +documentationMode :: [Flag] -> Bool +documentationMode = not . null . docItems + +withLogging :: [Flag] -> Bool +withLogging flags = and [ b | Logging b <- flags ] + +withInputFile :: [Flag] -> Maybe String +withInputFile flags = + case [ file | InputFile file <- flags ] of + [hd] -> Just hd + _ -> Nothing diff --git a/src/Main/Revision.hs b/src/Main/Revision.hs new file mode 100644 --- /dev/null +++ b/src/Main/Revision.hs @@ -0,0 +1,5 @@ +-- Automatically generated by Makefile. Do not change. +module Main.Revision where +version = "0.6" +revision = 3065 +lastChanged = "ma, 19 apr 2010" diff --git a/src/Service/Diagnose.hs b/src/Service/Diagnose.hs new file mode 100644 --- /dev/null +++ b/src/Service/Diagnose.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Diagnose a term submitted by a student +-- +----------------------------------------------------------------------------- +module Service.Diagnose + ( Diagnosis(..), RuleID, diagnose, restartIfNeeded + ) where + +import Common.Apply +import Common.Context +import Common.Exercise +import Common.Strategy (emptyPrefix) +import Common.Transformation +import Common.Utils (safeHead) +import Data.Maybe +import Service.TypedAbstractService + +---------------------------------------------------------------- +-- Result types for diagnose service + +type RuleID a = Rule (Context a) + +data Diagnosis a + = Buggy (RuleID a) + | NotEquivalent + | Similar Bool (State a) + | Expected Bool (State a) (RuleID a) + | Detour Bool (State a) (RuleID a) + | Correct Bool (State a) + +---------------------------------------------------------------- +-- The diagnose service + +diagnose :: State a -> a -> Diagnosis a +diagnose state new + -- Is the submitted term equivalent? + | not (equivalence ex (term state) new) = + -- Is the rule used discoverable by trying all known buggy rules? + case discovered True of + Just r -> -- report the buggy rule + Buggy r + Nothing -> -- unknown mistake + NotEquivalent + + -- Is the submitted term (very) similar to the previous one? + | similarity ex (term state) new = + -- If yes, report this + Similar (ready state) state + + -- Was the submitted term expected by the strategy? + | isJust expected = + -- If yes, return new state and rule + let (r, _, ns) = fromJust expected + in Expected (ready ns) ns r + + -- Is the rule used discoverable by trying all known rules? + | otherwise = + let ns = restartIfNeeded (state { prefix=Nothing, context=inContext ex new }) + in case discovered False of + Just r -> -- If yes, report the found rule as a detour + Detour (ready ns) ns r + Nothing -> -- If not, we give up + Correct (ready ns) ns + where + ex = exercise state + + expected = do + xs <- allfirsts (restartIfNeeded state) + let p (_, _, ns) = similarity ex new (term ns) + safeHead (filter p xs) + + discovered searchForBuggy = safeHead + [ r + | r <- ruleset ex + , isBuggyRule r == searchForBuggy + , ca <- applyAll r (inContext ex sub1) + -- , let s = prettyPrinter (exercise state) (fromContext a) + --, if s=="2*x+2 == 5" then True else error s + , a <- fromContext ca + , similarity ex sub2 a + ] + where + mode = not searchForBuggy + diff = difference ex mode (term state) new + (sub1, sub2) = fromMaybe (term state, new) diff + +---------------------------------------------------------------- +-- Helpers + +-- If possible (and if needed), restart the strategy +-- Make sure that the new state has a prefix +-- When resetting the prefix, also make sure that the context is refreshed +restartIfNeeded :: State a -> State a +restartIfNeeded s + | isNothing (prefix s) && canBeRestarted ex = + case fromContext (context s) of + Just a -> s + { prefix = Just (emptyPrefix (strategy ex)) + , context = inContext ex a + } + Nothing -> s + | otherwise = s + where + ex = exercise s diff --git a/src/Service/DomainReasoner.hs b/src/Service/DomainReasoner.hs new file mode 100644 --- /dev/null +++ b/src/Service/DomainReasoner.hs @@ -0,0 +1,135 @@ +{-# OPTIONS -XMultiParamTypeClasses -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.DomainReasoner + ( -- * Domain Reasoner data type + DomainReasoner, runDomainReasoner + , liftEither, liftIO, catchError + -- * Update functions + , addPackages, addPackage, addPkgService + , addServices, addService + , setVersion, setFullVersion + -- * Accessor functions + , getPackages, getExercises, getServices + , getVersion, getFullVersion + , findPackage, findService + ) where + +import Common.Exercise +import Common.Utils (Some(..)) +import Control.Monad.Error +import Control.Monad.State +import Service.ServiceList +import Service.ExercisePackage + +----------------------------------------------------------------------- +-- Domain Reasoner data type + +newtype DomainReasoner a = DR { unDR :: ErrorT String (StateT Content IO) a } + +data Content = Content + { packages :: [Some ExercisePackage] + , services :: [Some ExercisePackage] -> [Service] + , version :: String + , fullVersion :: Maybe String + } + +noContent :: Content +noContent = Content [] (const []) [] Nothing + +runDomainReasoner :: DomainReasoner a -> IO a +runDomainReasoner m = do + result <- evalStateT (runErrorT (unDR m)) noContent + case result of + Left msg -> fail msg + Right a -> return a + +liftEither :: Either String a -> DomainReasoner a +liftEither = either fail return + +----------------------------------------------------------------------- +-- Instance declarations + +instance Monad DomainReasoner where + return a = DR (return a) + DR m >>= f = DR (m >>= unDR . f) + fail s = DR (fail s) + +instance MonadError String DomainReasoner where + throwError = fail + catchError m f = DR (unDR m `catchError` (unDR . f)) + +instance MonadState Content DomainReasoner where + get = DR get + put s = DR (put s) + +instance MonadIO DomainReasoner where + liftIO m = DR (liftIO m) + +----------------------------------------------------------------------- +-- Update functions + +addPackages :: [Some ExercisePackage] -> DomainReasoner () +addPackages xs = modify $ \c -> c { packages = xs ++ packages c } + +addPackage :: Some ExercisePackage -> DomainReasoner () +addPackage pkg = addPackages [pkg] + +addPkgService :: ([Some ExercisePackage] -> Service) -> DomainReasoner () +addPkgService f = modify $ \c -> + c { services = \xs -> f xs : services c xs } + +addServices :: [Service] -> DomainReasoner () +addServices = mapM_ addPkgService . map const + +addService :: Service -> DomainReasoner () +addService s = addServices [s] + +setVersion :: String -> DomainReasoner () +setVersion s = modify $ \c -> c { version = s } + +setFullVersion :: String -> DomainReasoner () +setFullVersion s = modify $ \c -> c { fullVersion = Just s } + +----------------------------------------------------------------------- +-- Accessor functions + +getPackages :: DomainReasoner [Some ExercisePackage] +getPackages = gets packages + +getExercises :: DomainReasoner [Some Exercise] +getExercises = gets (map (\(Some pkg) -> Some (exercise pkg)) . packages) + +getServices :: DomainReasoner [Service] +getServices = gets (\c -> services c (packages c)) + +getVersion :: DomainReasoner String +getVersion = gets version + +getFullVersion :: DomainReasoner String +getFullVersion = gets fullVersion >>= maybe getVersion return + +findPackage :: ExerciseCode -> DomainReasoner (Some ExercisePackage) +findPackage code = do + pkgs <- getPackages + let p (Some pkg) = exerciseCode (exercise pkg) == code + case filter p pkgs of + [this] -> return this + _ -> fail $ "Package " ++ show code ++ " not found" + +findService :: String -> DomainReasoner Service +findService txt = do + srvs <- getServices + case filter ((==txt) . serviceName) srvs of + [hd] -> return hd + [] -> fail $ "No service " ++ txt + _ -> fail $ "Ambiguous service " ++ txt diff --git a/src/Service/ExerciseList.hs b/src/Service/ExerciseList.hs deleted file mode 100644 --- a/src/Service/ExerciseList.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, Rank2Types #-} ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.ExerciseList - ( exerciseList, findExercises, getExercise - , openMathExercises, findOpenMathExercises, getOpenMathExercise - , OpenMathExercise(..) - , resolveExerciseCode - ) where - -import Common.Utils (Some(..)) -import Common.Exercise -import Data.Char -import Domain.Math.Expr -import qualified Domain.LinearAlgebra as LA -import qualified Domain.Logic as Logic -import qualified Domain.RelationAlgebra as RA -import qualified Domain.Math.DerivativeExercise as Math -import qualified Domain.Math.Numeric.Exercises as Math -import qualified Domain.Math.Equation.CoverUpExercise as Math -import qualified Domain.Math.Polynomial.Exercises as Math - --- List with all known exercises -exerciseList :: [Some Exercise] -exerciseList = - [ -- logic and relation-algebra - Some Logic.dnfExercise - , Some Logic.dnfUnicodeExercise - , Some RA.cnfExercise - ] ++ - [ Some e | OMEX e <- openMathExercises ] - ------------------------------------------------------------------------------ --- All mathematical exercises are supported by the OpenMath standard, and --- require an extra type constraint - -data OpenMathExercise = forall a . IsExpr a => OMEX (Exercise a) - -openMathExercises :: [OpenMathExercise] -openMathExercises = - [ -- basic math - OMEX Math.naturalExercise, OMEX Math.integerExercise - , OMEX Math.rationalExercise, OMEX Math.fractionExercise - , OMEX Math.coverUpExercise - , OMEX Math.linearExercise - , OMEX Math.quadraticExercise - , OMEX Math.higherDegreeExercise - , OMEX Math.derivativeExercise - -- linear algebra - , OMEX LA.gramSchmidtExercise - , OMEX LA.linearSystemExercise - , OMEX LA.gaussianElimExercise - , OMEX LA.systemWithMatrixExercise - ] - ------------------------------------------------------------------------------ --- Utility functions for finding an exercise - -resolveExerciseCode :: Monad m => String -> m ExerciseCode -resolveExerciseCode txt = - case findExercises (\ex -> show (exerciseCode ex) ~= txt) of - [Some ex] -> return (exerciseCode ex) - _ -> fail $ "Failed to resolve the exercise code " ++ show txt - where - s ~= t = f s == f t - f = map toLower . filter isAlphaNum - -findExercises :: (forall a . Exercise a -> Bool) -> [Some Exercise] -findExercises p = [ Some e | Some e <- exerciseList, p e ] - -getExercise :: Monad m => ExerciseCode -> m (Some Exercise) -getExercise code = - case findExercises ((==code) . exerciseCode) of - [hd] -> return hd - [] -> fail $ "No exercise with code " ++ show code - _ -> fail $ "Ambiguous exercise code " ++ show code - -findOpenMathExercises :: (forall a . Exercise a -> Bool) -> [OpenMathExercise] -findOpenMathExercises p = [ OMEX e | OMEX e <- openMathExercises, p e ] - -getOpenMathExercise :: Monad m => ExerciseCode -> m OpenMathExercise -getOpenMathExercise code = - case findOpenMathExercises ((==code) . exerciseCode) of - [hd] -> return hd - [] -> fail $ "No exercise with code " ++ show code - _ -> fail $ "Ambiguous exercise code " ++ show code diff --git a/src/Service/ExercisePackage.hs b/src/Service/ExercisePackage.hs new file mode 100644 --- /dev/null +++ b/src/Service/ExercisePackage.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.ExercisePackage + ( -- Type, and selectors + ExercisePackage, exercise, withOpenMath + , toOpenMath, fromOpenMath, getExerciseText + -- Constructors + , package, termPackage, somePackage, someTermPackage + -- Conversion functions to/from OpenMath + , termToOMOBJ, omobjToTerm + ) where + +import Common.Utils (Some(..)) +import Common.Exercise +import Control.Monad +import Common.Rewriting.Term +import Data.Char +import Data.List +import Service.FeedbackText (ExerciseText) +import Text.OpenMath.Object +import Text.OpenMath.Symbol +import Text.OpenMath.Dictionary.Fns1 + +----------------------------------------------------------------------------- +-- Package data type (and constructor functions) + +data ExercisePackage a = P + { exercise :: Exercise a + , withOpenMath :: Bool + , toOpenMath :: a -> OMOBJ + , fromOpenMath :: MonadPlus m => OMOBJ -> m a + , getExerciseText :: Maybe (ExerciseText a) + } + +package :: Exercise a -> ExercisePackage a +package ex = P + { exercise = ex + , withOpenMath = False + , toOpenMath = error "no OpenMath support" + , fromOpenMath = fail "no OpenMath support" + , getExerciseText = Nothing + } + +termPackage :: IsTerm a => Exercise a -> ExercisePackage a +termPackage ex = (package ex) + { withOpenMath = True + , toOpenMath = termToOMOBJ . toTerm + , fromOpenMath = (>>= fromTerm) . omobjToTerm + } + +somePackage :: Exercise a -> Some ExercisePackage +somePackage = Some . package + +someTermPackage :: IsTerm a => Exercise a -> Some ExercisePackage +someTermPackage = Some . termPackage + +----------------------------------------------------------------------------- +-- Utility functions for conversion to/from OpenMath + +termToOMOBJ :: Term -> OMOBJ +termToOMOBJ term = + case term of + Var s -> OMV s + Con s -> case s of + S (Just a) b -> OMS (makeSymbol a b) + S Nothing b -> OMS (extraSymbol b) + Meta i -> OMV ("$" ++ show i) + Num n -> OMI n + Float d -> OMF d + App _ _ -> let (f, xs) = getSpine term + in make (map termToOMOBJ (f:xs)) + where + make [OMS s, OMV x, body] | s == lambdaSymbol = + OMBIND (OMS s) [x] body + make xs = OMA xs + +omobjToTerm :: MonadPlus m => OMOBJ -> m Term +omobjToTerm omobj = + case omobj of + OMV x -> case isMeta x of + Just n -> return (Meta n) + Nothing -> return (Var x) + OMS s -> return (Con (S (dictionary s) (symbolName s))) + OMI n -> return (Num n) + OMF a -> return (Float a) + OMA (x:xs) -> liftM2 makeTerm (omobjToTerm x) (mapM omobjToTerm xs) + OMBIND binder xs body -> + omobjToTerm (OMA (binder:map OMV xs++[body])) + _ -> fail "Invalid OpenMath object" + where + isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' + isMeta _ = Nothing diff --git a/src/Service/FeedbackText.hs b/src/Service/FeedbackText.hs --- a/src/Service/FeedbackText.hs +++ b/src/Service/FeedbackText.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,112 +10,112 @@ -- ----------------------------------------------------------------------------- module Service.FeedbackText - ( feedbackLogic - , onefirsttext, submittext, derivationtext + ( ExerciseText(..) + , onefirsttext, submittext, derivationtext, submitHelper ) where import Control.Arrow -import Control.Monad +import Common.Context import Common.Exercise -import Common.Utils (safeHead, fst3, commaList) +import Common.Transformation +import Common.Utils import Data.Maybe -import Domain.Logic.Formula (SLogic) -import Domain.Logic.FeedbackText -import Domain.Logic.Exercises (dnfExercise, dnfUnicodeExercise) +import Service.Diagnose (restartIfNeeded) +import Service.Submit import Service.TypedAbstractService -import Common.Context -import Common.Transformation (name, Rule) -import Text.Parsing (errorToPositions) -import Data.Char --- Quick hack for determining subterms -coerceLogic :: Exercise a -> a -> Maybe SLogic -coerceLogic ex a - | exerciseCode ex == exerciseCode dnfExercise = - either (const Nothing) Just $ parser dnfExercise (prettyPrinter ex a) - | exerciseCode ex == exerciseCode dnfUnicodeExercise = - either (const Nothing) Just $ parser dnfUnicodeExercise (prettyPrinter ex a) - | otherwise = Nothing +------------------------------------------------------------ +-- Exercise Text data type -youRewroteInto :: State a -> a -> Maybe String -youRewroteInto = rewriteIntoText False "You rewrote " +-- Exercise extension for textual feedback +data ExerciseText a = ExerciseText + { ruleText :: Rule (Context a) -> Maybe String + , appliedRule :: Rule (Context a) -> String + , feedbackSyntaxError :: String -> String + , feedbackSame :: String + , feedbackBuggy :: Bool -> [Rule (Context a)] -> String + , feedbackNotEquivalent :: Bool -> String + , feedbackOk :: [Rule (Context a)] -> (String, Bool) + , feedbackDetour :: Bool -> Maybe (Rule (Context a)) -> [Rule (Context a)] -> (String, Bool) + , feedbackUnknown :: Bool -> String + } -useToRewrite :: Rule (Context a) -> State a -> a -> Maybe String -useToRewrite rule old = rewriteIntoText True txt old - where - txt = "Use " ++ showRule (exerciseCode $ exercise old) rule - ++ " to rewrite " +------------------------------------------------------------ +-- Services -rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String -rewriteIntoText mode txt old a = do - let ex | exerciseCode (exercise old) == exerciseCode dnfUnicodeExercise = - dnfUnicodeExercise - | otherwise = dnfExercise - p <- coerceLogic (exercise old) (fromContext $ context old) - q <- coerceLogic (exercise old) a - (p1, q1) <- difference ex mode p q - return $ txt ++ prettyPrinter ex p1 - ++ " into " ++ prettyPrinter ex q1 ++ ". " +derivationtext :: Monad m => ExerciseText a -> State a -> Maybe String -> m [(String, Context a)] +derivationtext exText st _event = do + xs <- derivation Nothing st + return (map (first (showRule exText)) xs) +onefirsttext :: ExerciseText a -> State a -> Maybe String -> (Bool, String, State a) +onefirsttext exText state event = + case allfirsts state of + Just ((r, _, s):_) -> + let msg = case fromContext (context s) >>= useToRewrite exText r state of + Just txt | event /= Just "hint button" -> txt + _ -> "Use " ++ showRule exText r + in (True, msg, s) + _ -> (False, "Sorry, no hint available", state) + +submittext :: ExerciseText a -> State a -> String -> Maybe String -> (Bool, String, State a) +submittext exText state txt _event = + case parser (exercise state) txt of + Left err -> + (False, feedbackSyntaxError exText err, state) + Right a -> + let result = submit state a + (txt, b) = submitHelper exText state a result + in case getResultState result of + Just new | b -> (True, txt, restartIfNeeded new) + _ -> (False, txt, state) + -- Feedback messages for submit service (free student input). The boolean -- indicates whether the student is allowed to continue (True), or forced -- to go back to the previous state (False) -feedbackLogic :: State a -> a -> Result a -> (String, Bool) -feedbackLogic old a result = +submitHelper :: ExerciseText a -> State a -> a -> Result a -> (String, Bool) +submitHelper exText old a result = case result of Buggy rs -> ( fromMaybe "" (youRewroteInto old a) ++ - feedbackBuggy (ready old) rs + feedbackBuggy exText (ready old) rs , False) NotEquivalent -> ( fromMaybe "" (youRewroteInto old a) ++ - feedbackNotEquivalent (ready old) + feedbackNotEquivalent exText (ready old) , False) Ok rs _ - | null rs -> (feedbackSame, False) - | otherwise -> feedbackOk rs - Detour rs _ -> feedbackDetour (ready old) (expected old) rs + | null rs -> (feedbackSame exText, False) + | otherwise -> feedbackOk exText rs + Detour rs _ -> feedbackDetour exText (ready old) (expected old) rs Unknown _ -> ( fromMaybe "" (youRewroteInto old a) ++ - feedbackUnknown (ready old) + feedbackUnknown exText (ready old) , False) where - expected = fmap fst3 . safeHead . allfirsts + expected s = do + xs <- allfirsts s + fmap fst3 (safeHead xs) -showRule :: ExerciseCode -> Rule a -> String -showRule code r - | code `elem` map exerciseCode [dnfExercise, dnfUnicodeExercise] = - fromMaybe txt (ruleText r) - | otherwise = txt - where - txt = "rule " ++ name r +------------------------------------------------------------ +-- Helper functions -getCode :: State a -> ExerciseCode -getCode = exerciseCode . exercise +showRule :: ExerciseText a -> Rule (Context a) -> String +showRule exText r = + case ruleText exText r of + Just s -> s + Nothing -> "rule " ++ name r -derivationtext :: State a -> Maybe String -> [(String, Context a)] -derivationtext st _event = - map (first (showRule (getCode st))) (derivation st) +useToRewrite :: ExerciseText a -> Rule (Context a) -> State a -> a -> Maybe String +useToRewrite exText rule old = rewriteIntoText True txt old + where + txt = "Use " ++ showRule exText rule + ++ " to rewrite " -onefirsttext :: State a -> Maybe String -> (Bool, String, State a) -onefirsttext state event = - case allfirsts state of - (r, _, s):_ -> - let msg = case useToRewrite r state (fromContext $ context s) of - Just txt | event /= Just "hint button" -> txt - _ -> "Use " ++ showRule (getCode state) r - in (True, msg, s) - _ -> (False, "Sorry, no hint available", state) +youRewroteInto :: State a -> a -> Maybe String +youRewroteInto = rewriteIntoText False "You rewrote " -submittext :: State a -> String -> Maybe String -> (Bool, String, State a) -submittext state txt _event = - case parser (exercise state) txt of - Left err -> - let msg = "Syntax error" ++ pos ++ ": " ++ show err - pos = case map show (errorToPositions err) of - [] -> "" - xs -> " at " ++ commaList xs - in (False, msg, state) - Right a -> - let result = submit state a - (txt, b) = feedbackLogic state a result - in case getResultState result of - Just new | b -> (True, txt, resetStateIfNeeded new) - _ -> (False, txt, state) +rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String +rewriteIntoText mode txt old a = do + let ex = exercise old + p <- fromContext (context old) + (p1, a1) <- difference ex mode p a + return $ txt ++ prettyPrinter ex p1 + ++ " into " ++ prettyPrinter ex a1 ++ ". " diff --git a/src/Service/LoggingDatabase.hs b/src/Service/LoggingDatabase.hs deleted file mode 100644 --- a/src/Service/LoggingDatabase.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Facilities to create a log database --- ------------------------------------------------------------------------------ -module Service.LoggingDatabase (logMessage, logEnabled) where - -import Data.Time -import Service.Request -#ifdef DB -import Data.Maybe -import Database.HDBC -import Database.HDBC.Sqlite3 (connectSqlite3) - -logEnabled :: Bool -logEnabled = True - --- | Log a message to the database (a Sqlite database). -logMessage :: Request -> String -> String -> String -> UTCTime -> IO () -logMessage req input output ipaddress begin = do - -- make a connection with the database - conn <- connectSqlite3 "service.db" - - -- check if the database exists, if not make one - --tables <- getTables conn - --if not (elem "log" tables) then run conn createStmt [] else return 0 - - -- calculate duration - end <- getCurrentTime - let diff = diffUTCTime end begin - - -- insert data into database - run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" - [ toSql $ service req - , toSql $ maybe "unknown" show (exerciseID req) - , toSql $ fromMaybe "unknown" (source req) - , toSql $ show (dataformat req) - , toSql $ maybe "unknown" show (encoding req) - , toSql $ input - , toSql $ output - , toSql $ ipaddress - , toSql $ begin - , toSql $ diff - ] - commit conn - - -- close the connection to the database - disconnect conn - `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err - -{- --- | Log table schema -createStmt = "CREATE TABLE log ( service VARCHAR(250)" - ++ ", exerciseID VARCHAR(250)" - ++ ", source VARCHAR(250)" - ++ ", dataformat VARCHAR(250)" - ++ ", encoding VARCHAR(250)" - ++ ", input VARCHAR(250)" - ++ ", output VARCHAR(250)" - ++ ", ipaddress VARCHAR(20)" - ++ ", time TIME" - ++ ", responsetime TIME)" --} -#else -logMessage :: Request -> String -> String -> String -> UTCTime -> IO () -logMessage _ _ _ _ _ = return () - -logEnabled :: Bool -logEnabled = False -#endif - diff --git a/src/Service/Main.hs b/src/Service/Main.hs deleted file mode 100644 --- a/src/Service/Main.hs +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Main module for feedback services --- ------------------------------------------------------------------------------ -module Main (main) where - --- import Common.Logging -import Common.Utils (useFixedStdGen) -import Service.Options -import Service.ModeXML (processXML) -import Service.ModeJSON (processJSON) -import Service.Request -import Service.LoggingDatabase -import Network.CGI -import Control.Monad.Trans -import Control.Monad -import Data.Maybe -import Data.Char -import Data.IORef -import Data.Time - -main :: IO () -main = do - startTime <- getCurrentTime - flags <- serviceOptions - logRef <- newIORef (return ()) - - case withInputFile flags of - -- from file - Just file -> do - useFixedStdGen -- use a predictable "random" number generator - input <- readFile file - (req, txt, _) <- process input - when (Logging True `elem` flags) $ - writeIORef logRef $ -- save logging action for later - logMessage req input txt "local" startTime - putStrLn txt - - - -- cgi binary - Nothing -> runCGI $ do - addr <- remoteAddr -- the IP address of the remote host making the request - raw <- getInput "input" -- read input - input <- case raw of - Nothing -> fail "Invalid request: environment variable \"input\" is empty" - Just s -> return s - (req, txt, ctp) <- lift $ process input - lift $ writeIORef logRef $ -- save logging action for later - logMessage req input txt addr startTime - setHeader "Content-type" ctp - output txt - - -- log request to database - when (withLogging flags) $ - join (readIORef logRef) - -process :: String -> IO (Request, String, String) -process input = - case discoverDataFormat input of - Just XML -> processXML input - Just JSON -> processJSON input - _ -> fail "Invalid input" - --- Convert escaped characters ('%') -{- -convert :: String -> String -convert [] = [] -convert ('%':c1:c2:cs) = - case stringToHex [c1, c2] of - Just i -> chr i : convert cs - Nothing -> '%' : convert (c1:c2:cs) -convert (c:cs) = c : convert cs -} diff --git a/src/Service/ModeJSON.hs b/src/Service/ModeJSON.hs --- a/src/Service/ModeJSON.hs +++ b/src/Service/ModeJSON.hs @@ -1,5 +1,6 @@ +{-# OPTIONS -XGADTs #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,40 +15,51 @@ module Service.ModeJSON (processJSON, jsonTuple) where import Common.Context -import Common.Utils (Some(..), distinct) +import Common.Utils (Some(..), distinct, readM) import Common.Exercise import Common.Strategy (makePrefix) import Common.Transformation hiding (ruleList, defaultArgument) import Text.JSON import Service.Request -import Service.Types (Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..)) +import Service.Types (TypedValue(..), Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..), decoderExercise) import qualified Service.Types as Tp import qualified Service.TypedAbstractService as TAS +import Service.Submit import Service.ServiceList hiding (Service) -import qualified Service.ExerciseList as List +import Service.ExercisePackage +import Service.DomainReasoner import Control.Monad import Data.Maybe import Data.Char -- TODO: Clean-up code extractCode :: JSON -> ExerciseCode -extractCode = fromMaybe noCode . List.resolveExerciseCode . f +extractCode = fromMaybe noCode . readCode . f where f (String s) = s f (Array [String _, String _, a@(Array _)]) = f a f (Array (String s:tl)) | any (\c -> not (isAlphaNum c || isSpace c || c `elem` ".-")) s = f (Array tl) f (Array (hd:_)) = f hd f _ = "" - -processJSON :: String -> IO (Request, String, String) + +processJSON :: String -> DomainReasoner (Request, String, String) processJSON input = do - txt <- jsonRPC input myHandler - case fmap jsonRequest (parseJSON input) of - Just (Right req) -> return (req, txt, "application/json") - Just (Left err) -> fail err - _ -> fail "no parse" + json <- parseJSON input + req <- jsonRequest json + vers <- getVersion + resp <- jsonRPC json myHandler + let out = show $ (if null vers then id else addVersion vers) (toJSON resp) + return (req, out, "application/json") -jsonRequest :: JSON -> Either String Request +addVersion :: String -> JSON -> JSON +addVersion version json = + case json of + Object xs -> Object (xs ++ [info]) + _ -> json + where + info = ("version", String version) + +jsonRequest :: Monad m => JSON -> m Request jsonRequest json = do srv <- case lookupM "method" json of Just (String s) -> return s @@ -69,24 +81,19 @@ , encoding = enc } -myHandler :: JSON_RPC_Handler -myHandler fun arg - | code == noCode && fun /= "exerciselist" = - fail "invalid exercise code" - | otherwise = - case jsonConverter code of - Some conv -> do - service <- getService fun - either fail return (evalService conv service arg) - where - code = extractCode arg +myHandler :: JSON_RPC_Handler DomainReasoner +myHandler fun arg = do + pkg <- if fun == "exerciselist" + then return (Some (package emptyExercise)) + else findPackage (extractCode arg) + srv <- findService fun + case jsonConverter pkg of + Some conv -> do + either fail return (evalService conv srv arg) -jsonConverter :: ExerciseCode -> Some (Evaluator (Either String) JSON JSON) -jsonConverter code = - let f a = Some (Evaluator (jsonEncoder a) (jsonDecoder a)) - in case List.getExercise code of - Just (Some a) -> f a - Nothing -> f emptyExercise +jsonConverter :: Some ExercisePackage -> Some (Evaluator (Either String) JSON JSON) +jsonConverter (Some pkg) = + Some (Evaluator (jsonEncoder (exercise pkg)) (jsonDecoder pkg)) jsonEncoder :: Monad m => Exercise a -> Encoder m JSON a jsonEncoder ex = Encoder @@ -96,33 +103,33 @@ } where encode :: Monad m => Encoder m JSON a -> Type a t -> t -> m JSON - encode enc serviceType = - case serviceType of - Tp.List t -> liftM Array . mapM (encode enc t) - Tp.Tag s t -> liftM (\a -> Object [(s, a)]) . encode enc t - Tp.Int -> return . toJSON - Tp.Bool -> return . toJSON - Tp.String -> return . toJSON - Tp.State -> encode enc stateType . fromState - Tp.Result -> encodeResult enc - _ -> encodeDefault enc serviceType - -fromState :: TAS.State a -> (String, String, Context a, String) -fromState st = - ( show (exerciseCode (TAS.exercise st)) - , maybe "NoPrefix" show (TAS.prefix st) - , inContext (TAS.term st) - , showContext (TAS.context st) - ) - -stateType :: Type a (String, String, Context a, String) -stateType = Tp.Quadruple Tp.String Tp.String Tp.Term Tp.String - -jsonDecoder :: MonadPlus m => Exercise a -> Decoder m JSON a -jsonDecoder ex = Decoder - { decodeType = decode (jsonDecoder ex) - , decodeTerm = reader ex - , decoderExercise = ex + encode enc serviceType a + | length xs > 1 = + liftM jsonTuple (mapM (\(b ::: t) -> encode enc t b) xs) + | otherwise = + case serviceType of + Tp.List t -> liftM Array (mapM (encode enc t) a) + Tp.Tag s t -> liftM (\b -> Object [(s, b)]) (encode enc t a) + Tp.Int -> return (toJSON a) + Tp.Bool -> return (toJSON a) + Tp.String -> return (toJSON a) + Tp.State -> encodeState (encodeTerm enc) a + Tp.Result -> encodeResult enc a + _ -> encodeDefault enc serviceType a + where + xs = tupleList (a ::: serviceType) + + tupleList :: TypedValue a -> [TypedValue a] + tupleList (a ::: Tp.Iso _ f t) = tupleList (f a ::: t) + tupleList (p ::: Tp.Pair t1 t2) = + tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2) + tupleList tv = [tv] + +jsonDecoder :: MonadPlus m => ExercisePackage a -> Decoder m JSON a +jsonDecoder pkg = Decoder + { decodeType = decode (jsonDecoder pkg) + , decodeTerm = reader (exercise pkg) + , decoderPackage = pkg } where reader :: Monad m => Exercise a -> JSON -> m a @@ -133,11 +140,11 @@ decode dec serviceType = case serviceType of Tp.State -> useFirst $ decodeState (decoderExercise dec) (decodeTerm dec) - Tp.Location -> useFirst fromJSON - Tp.Term -> useFirst $ liftM inContext . decodeTerm dec + Tp.Location -> useFirst decodeLocation + Tp.Term -> useFirst $ decodeTerm dec Tp.Rule -> useFirst $ \x -> fromJSON x >>= getRule (decoderExercise dec) Tp.Exercise -> \json -> case json of - (Array (String s:rest)) -> return (decoderExercise dec, Array rest) + (Array (String _:rest)) -> return (decoderExercise dec, Array rest) _ -> return (decoderExercise dec, json) Tp.Int -> useFirst $ \json -> case json of Number (I n) -> return (fromIntegral n) @@ -152,47 +159,61 @@ a <- f x return (a, Array xs) useFirst _ _ = fail "expecting an argument" - -instance InJSON Location where - toJSON = toJSON . show - fromJSON (String s) = case reads s of - [(loc, rest)] | all isSpace rest -> return loc - _ -> fail "invalid string" - fromJSON _ = fail "expecting a string" +decodeLocation :: Monad m => JSON -> m [Int] +decodeLocation (String s) = readM s +decodeLocation _ = fail "expecting a string for a location" + -------------------------- +encodeState :: Monad m => (a -> m JSON) -> TAS.State a -> m JSON +encodeState f st = do + theTerm <- f (TAS.term st) + return $ Array + [ String (show (exerciseCode (TAS.exercise st))) + , String (maybe "NoPrefix" show (TAS.prefix st)) + , theTerm + , encodeContext (getEnvironment (TAS.context st)) + ] + +encodeContext :: Environment -> JSON +encodeContext env = Object (map f (keysEnv env)) + where + f k = (k, String $ fromMaybe "" $ lookupEnv k env) + decodeState :: Monad m => Exercise a -> (JSON -> m a) -> JSON -> m (TAS.State a) decodeState ex f (Array [a]) = decodeState ex f a -decodeState ex f (Array [String code, String p, ce, String ctx]) = do +decodeState ex f (Array [String _code, String p, ce, jsonContext]) = do a <- f ce - unit <- maybe (fail "invalid context") return (parseContext ctx) + env <- decodeContext jsonContext return TAS.State { TAS.exercise = ex - , TAS.prefix = fmap (`makePrefix` strategy ex) (readPrefix p) - , TAS.context = fmap (const a) unit + , TAS.prefix = readM p >>= (`makePrefix` strategy ex) + , TAS.context = makeContext ex env a } decodeState _ _ s = fail $ "invalid state" ++ show s -readPrefix :: String -> Maybe [Int] -readPrefix input = - case reads input of - [(is, rest)] | all isSpace rest -> return is - _ -> Nothing +decodeContext :: Monad m => JSON -> m Environment +decodeContext (String "") = decodeContext (Object []) -- Being backwards compatible (for now) +decodeContext (Object xs) = foldM add emptyEnv xs + where + add env (k, String s) = return (storeEnv k s env) + add _ _ = fail "invalid item in context" +decodeContext json = fail $ "invalid context: " ++ show json -encodeResult :: Monad m => Encoder m JSON a -> TAS.Result a -> m JSON +encodeResult :: Monad m => Encoder m JSON a -> Result a -> m JSON encodeResult enc result = case result of -- TAS.SyntaxError _ -> [("result", String "SyntaxError")] - TAS.Buggy rs -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)] - TAS.NotEquivalent -> return $ Object [("result", String "NotEquivalent")] - TAS.Ok rs st -> do + Buggy rs -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)] + NotEquivalent -> return $ Object [("result", String "NotEquivalent")] + Ok rs st -> do json <- encodeType enc Tp.State st return $ Object [("result", String "Ok"), ("rules", Array $ map (String . name) rs), ("state", json)] - TAS.Detour rs st -> do + Detour rs st -> do json <- encodeType enc Tp.State st return $ Object [("result", String "Detour"), ("rules", Array $ map (String . name) rs), ("state", json)] - TAS.Unknown st -> do + Unknown st -> do json <- encodeType enc Tp.State st return $ Object [("result", String "Unknown"), ("state", json)] diff --git a/src/Service/ModeXML.hs b/src/Service/ModeXML.hs --- a/src/Service/ModeXML.hs +++ b/src/Service/ModeXML.hs @@ -1,5 +1,6 @@ +{-# OPTIONS -XGADTs #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,39 +12,49 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- -module Service.ModeXML (processXML) where +module Service.ModeXML + ( processXML, xmlRequest, openMathConverterTp, stringFormatConverterTp + , resultOk, resultError, addVersion + ) where +import Common.Navigator import Common.Context import Common.Exercise import Common.Strategy hiding (not, fail) -import Common.Transformation hiding (name, defaultArgument) -import Common.Utils (Some(..)) +import Common.Utils (Some(..), readM) import Control.Monad import Data.Char +import Data.List import Data.Maybe -import Service.ExerciseList +import Service.ExercisePackage import Service.ProblemDecomposition import Service.Request -import Service.Revision (version) +import Service.RulesInfo (rulesInfoXML) import Service.ServiceList +import Service.StrategyInfo import Service.TypedAbstractService hiding (exercise) -import Service.Types (Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..)) -import Domain.Math.Expr +import Service.Diagnose +import Service.Types hiding (State) import Text.OpenMath.Object -import Text.OpenMath.Reply (replyToXML) -import Text.OpenMath.Request (xmlToRequest) import Text.XML import qualified Common.Transformation as Rule import qualified Service.Types as Tp +import Service.DomainReasoner +processXML :: String -> DomainReasoner (Request, String, String) +processXML input = do + xml <- liftEither (parseXML input) + req <- liftEither (xmlRequest xml) + resp <- xmlReply req xml + `catchError` \msg -> return (resultError msg) + vers <- getVersion + let out = showXML (if null vers then resp else addVersion vers resp) + return (req, out, "application/xml") -processXML :: String -> IO (Request, String, String) -processXML input = - either fail return $ do - xml <- parseXML input - req <- xmlRequest xml - out <- xmlRequestHandler xml - return (req, showXML out, "application/xml") +addVersion :: String -> XML -> XML +addVersion s xml = + let info = [ "version" := s ] + in xml { attributes = attributes xml ++ info } xmlRequest :: XML -> Either String Request xmlRequest xml = do @@ -62,157 +73,259 @@ , encoding = enc } -xmlReply :: Request -> XML -> Either String XML +xmlReply :: Request -> XML -> DomainReasoner XML xmlReply request xml | service request == "mathdox" = do code <- maybe (fail "unknown exercise code") return (exerciseID request) - OMEX ex <- getOpenMathExercise code - (st, sloc, answer) <- xmlToRequest xml ex - return (replyToXML (problemDecomposition st sloc answer)) - | otherwise = - case encoding request of - Just StringEncoding -> do - code <- maybe (fail "unknown exercise code") return (exerciseID request) - ex <- getExercise code - case stringFormatConverter ex of - Some conv -> do - srv <- getService (service request) - res <- evalService conv srv xml - return (resultOk res) - _ -> do - code <- maybe (fail "unknown exercise code") return (exerciseID request) - ex <- getOpenMathExercise code - case openMathConverter ex of - Some conv -> do - srv <- getService (service request) - res <- evalService conv srv xml - return (resultOk res) + Some pkg <- findPackage code + (st, sloc, answer) <- liftEither $ xmlToRequest xml (fromOpenMath pkg) (exercise pkg) + return (replyToXML (toOpenMath pkg) (problemDecomposition st sloc answer)) -xmlRequestHandler :: Monad m => XML -> m XML -xmlRequestHandler xml = - case xmlRequest xml of - Left err -> return (resultError err) - Right request -> - case xmlReply request xml of - Left err -> return (resultError err) - Right result -> return result +xmlReply request xml = do + srv <- findService (service request) + pkg <- + case exerciseID request of + Just code -> findPackage code + Nothing + | service request == "exerciselist" -> + return (Some (package emptyExercise)) + | otherwise -> + fail "unknown exercise code" + Some conv <- return $ + case encoding request of + Just StringEncoding -> stringFormatConverter pkg + _ -> openMathConverter pkg + res <- liftEither $ evalService conv srv xml + return (resultOk res) extractExerciseCode :: Monad m => XML -> m ExerciseCode extractExerciseCode xml = case liftM (break (== '.')) (findAttribute "exerciseid" xml) of Just (as, _:bs) -> return (makeCode as bs) - Just (as, _) -> resolveExerciseCode as + Just (as, _) -> maybe (fail "invalid code") return (readCode as) -- being backwards compatible with early MathDox - Nothing -> - case fmap getData (findChild "strategy" xml) of - Just name -> - let s ~= t = f s == f t - f = map toLower . filter isAlphaNum - in case findOpenMathExercises (\ex -> name ~= description ex) of - [OMEX a] -> return (exerciseCode a) - _ -> fail $ "Unknown strategy name " ++ show name + Nothing -> do + let getName = map toLower . filter isAlphaNum . getData + linalg = return . makeCode "linalg" + case fmap getName (findChild "strategy" xml) of + Just name + | name == "gaussianelimination" -> linalg "gaussianelim" + | name == "gramschmidt" -> linalg "gramschmidt" + | name == "solvelinearsystem" -> linalg "linsystem" + | name == "solvelinearsystemwithmatrix" -> linalg "systemwithmatrix" _ -> fail "no exerciseid attribute, nor a known strategy element" resultOk :: XMLBuilder -> XML resultOk body = makeXML "reply" $ do - "result" .=. "ok" - "version" .=. version + "result" .=. "ok" body resultError :: String -> XML resultError txt = makeXML "reply" $ do - "result" .=. "error" - "version" .=. version + "result" .=. "error" element "message" (text txt) ------------------------------------------------------------ -- Mixing abstract syntax (OpenMath format) and concrete syntax (string) -stringFormatConverter :: Some Exercise -> Some (Evaluator (Either String) XML XMLBuilder) -stringFormatConverter (Some ex) = - Some $ Evaluator (xmlEncoder f ex) (xmlDecoder g ex) +stringFormatConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder) +stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg) + +stringFormatConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a +stringFormatConverterTp pkg = + Evaluator (xmlEncoder False f ex) (xmlDecoder False g pkg) where - f = return . element "expr" . text . prettyPrinter ex + ex = exercise pkg + f = return . element "expr" . text . prettyPrinter ex g xml = do xml <- findChild "expr" xml -- quick fix -- guard (name xml == "expr") let input = getData xml either (fail . show) return (parser ex input) + +openMathConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder) +openMathConverter (Some pkg) = Some (openMathConverterTp pkg) -openMathConverter :: OpenMathExercise -> Some (Evaluator (Either String) XML XMLBuilder) -openMathConverter (OMEX ex) = - Some $ Evaluator (xmlEncoder f ex) (xmlDecoder g ex) +openMathConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a +openMathConverterTp pkg = + Evaluator (xmlEncoder True f ex) (xmlDecoder True g pkg) where - f = return . builder . toXML . toOMOBJ . toExpr - g xml = do + ex = exercise pkg + f = return . builder . toXML . toOpenMath pkg + g xml = do xob <- findChild "OMOBJ" xml omobj <- xml2omobj xob - case fromExpr (fromOMOBJ omobj) of + case fromOpenMath pkg omobj of Just a -> return a Nothing -> fail "Unknown OpenMath object" - -xmlEncoder :: Monad m => (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a -xmlEncoder f ex = Encoder - { encodeType = encode (xmlEncoder f ex) + +xmlEncoder :: Monad m => Bool -> (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a +xmlEncoder b f ex = Encoder + { encodeType = encode (xmlEncoder b f ex) ex , encodeTerm = f , encodeTuple = sequence_ } where - encode :: Monad m => Encoder m XMLBuilder a -> Type a t -> t -> m XMLBuilder - encode enc serviceType = + encode :: Monad m => Encoder m XMLBuilder a -> Exercise a -> Type a t -> t -> m XMLBuilder + encode enc ex serviceType = case serviceType of - Tp.List t1 -> \xs -> do - bs <- mapM (encode enc t1) xs - let b = mapM_ (element "elem") bs - return (element "list" b) - Tp.Elem t1 -> liftM (element "elem") . encode enc t1 - Tp.Tag s t1 -> liftM (element s) . encode enc t1 -- quick fix - Tp.Rule -> return . ("ruleid" .=.) . Rule.name - Tp.Term -> encodeTerm enc . fromContext - Tp.Location -> return . text . show - Tp.Bool -> return . text . show - Tp.Int -> return . text . show - Tp.State -> encodeState (encodeTerm enc) - _ -> encodeDefault enc serviceType + Tp.List t1 -> \xs -> + case allAreTagged t1 of + Just f -> do + let make = element "elem" . mapM_ (uncurry (.=.)) . f + let elems = mapM_ make xs + return (element "list" elems) + _ -> do + bs <- mapM (encode enc ex t1) xs + let elems = mapM_ (element "elem") bs + return (element "list" elems) + Tp.Elem t1 -> liftM (element "elem") . encode enc ex t1 + Tp.Tag s t1 -> liftM (element s) . encode enc ex t1 -- quick fix + Tp.Strategy -> return . builder . strategyToXML + Tp.Rule -> return . ("ruleid" .=.) . Rule.name + Tp.RulesInfo -> \_ -> rulesInfoXML ex (encodeTerm enc) + Tp.Term -> encodeTerm enc + Tp.Diagnosis -> encodeDiagnosis b (encodeTerm enc) + Tp.Context -> encodeContext b (encodeTerm enc) + Tp.Location -> return . {-element "location" .-} text . show + Tp.Bool -> return . text . map toLower . show + Tp.String -> return . text + Tp.Int -> return . text . show + Tp.State -> encodeState b (encodeTerm enc) + _ -> encodeDefault enc serviceType -xmlDecoder :: MonadPlus m => (XML -> m a) -> Exercise a -> Decoder m XML a -xmlDecoder f ex = Decoder - { decodeType = decode (xmlDecoder f ex) - , decodeTerm = f - , decoderExercise = ex +xmlDecoder :: MonadPlus m => Bool -> (XML -> m a) -> ExercisePackage a -> Decoder m XML a +xmlDecoder b f pkg = Decoder + { decodeType = decode (xmlDecoder b f pkg) + , decodeTerm = f + , decoderPackage = pkg } where decode :: MonadPlus m => Decoder m XML a -> Type a t -> XML -> m (t, XML) decode dec serviceType = case serviceType of - Tp.State -> decodeState (decoderExercise dec) (decodeTerm dec) - Tp.Location -> leave $ liftM (read . getData) . findChild "location" - Tp.Rule -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid" - Tp.Exercise -> leave $ const (return (decoderExercise dec)) - Tp.Term -> \xml -> decodeTerm dec xml >>= \a -> return (inContext a, xml) - _ -> decodeDefault dec serviceType + Tp.State -> decodeState b (decoderExercise dec) (decodeTerm dec) + Tp.Location -> leave $ liftM (read . getData) . findChild "location" + Tp.Rule -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid" + Tp.Term -> \xml -> decodeTerm dec xml >>= \a -> return (a, xml) + Tp.StrategyCfg -> decodeConfiguration + _ -> decodeDefault dec serviceType leave :: Monad m => (XML -> m a) -> XML -> m (a, XML) leave f xml = liftM (\a -> (a, xml)) (f xml) -decodeState :: Monad m => Exercise a -> (XML -> m a) -> XML -> m (State a, XML) -decodeState ex f top = do +allAreTagged :: Type a t -> Maybe (t -> [(String, String)]) +allAreTagged (Iso _ f t) = fmap (. f) (allAreTagged t) +allAreTagged (Pair t1 t2) = do + f1 <- allAreTagged t1 + f2 <- allAreTagged t2 + return $ \(a,b) -> f1 a ++ f2 b +allAreTagged (Tag tag Bool) = Just $ \b -> [(tag, map toLower (show b))] +allAreTagged (Tag tag String) = Just $ \s -> [(tag, s)] +allAreTagged _ = Nothing + +decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a, XML) +decodeState b ex f top = do xml <- findChild "state" top unless (name xml == "state") (fail "expected a state tag") - let sp = maybe "[]" getData (findChild "prefix" xml) - sc = maybe "" getData (findChild "context" xml) - --x <- findChild "OMOBJ" xml + mpr <- case maybe "" getData (findChild "prefix" xml) of + prefixText + | all isSpace prefixText -> + return (Just (emptyPrefix (strategy ex))) + | prefixText ~= "no prefix" -> + return Nothing + | otherwise -> do + a <- readM prefixText + pr <- makePrefix a (strategy ex) + return (Just pr) expr <- f xml - contxt <- maybe (fail $ "invalid context" ++ show sc) return (parseContext sc) - let state = State ex (Just (makePrefix (read sp) $ strategy ex)) term - term = fmap (const expr) contxt + env <- decodeEnvironment b xml + let state = State ex mpr term + term = makeContext ex env expr return (state, top) + where + a ~= b = g a == g b + g = map toLower . filter (not . isSpace) -encodeState :: Monad m => (a -> m XMLBuilder) -> State a -> m XMLBuilder -encodeState f state = do - b <- f (term state) - return $ element "state" $ do - element "prefix" (text $ maybe "[]" show (prefix state)) - element "context" (text $ showContext (context state)) - b - +decodeEnvironment :: Monad m => Bool -> XML -> m Environment +decodeEnvironment b xml = + case findChild "context" xml of + Just this -> foldM add emptyEnv (children this) + Nothing -> return emptyEnv + where + add env item = do + unless (name item == "item") $ + fail $ "expecting item tag, found " ++ name item + name <- findAttribute "name" item + case findChild "OMOBJ" item of + -- OpenMath object found inside item tag + Just this | b -> do + case xml2omobj this >>= omobjToTerm of + Left err -> fail err + Right term -> + return (storeEnv name term env) + -- Simple value in attribute + _ -> do + value <- findAttribute "value" item + return (storeEnv name value env) + +decodeConfiguration :: MonadPlus m => XML -> m (StrategyConfiguration, XML) +decodeConfiguration xml = + case findChild "configuration" xml of + Just this -> mapM decodeAction (children this) >>= \xs -> return (xs, xml) + Nothing -> fail "no strategy configuration" + where + decodeAction item = do + guard (null (children item)) + action <- + case find (\a -> map toLower (show a) == name item) configActions of + Just a -> return a + Nothing -> fail $ "unknown action " ++ show (name item) + cfgloc <- findAttribute "name" item + return $ (ByName cfgloc, action) + + +encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder +encodeState b f state = f (term state) >>= \body -> return $ + element "state" $ do + element "prefix" (text $ maybe "no prefix" show (prefix state)) + let env = getEnvironment (context state) + encodeEnvironment b (location (context state)) env + body + +encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder +encodeEnvironment b loc env0 + | nullEnv env = return () + | otherwise = element "context" $ do + forM_ (keysEnv env) $ \k -> do + element "item" $ do + "name" .=. k + case lookupEnv k env of + Just term | b -> builder (omobj2xml (termToOMOBJ term)) + _ -> "value" .=. fromMaybe "" (lookupEnv k env) + where + env | null loc = env0 + | otherwise = storeEnv "location" loc env0 + +encodeDiagnosis :: Monad m => Bool -> (a -> m XMLBuilder) -> Diagnosis a -> m XMLBuilder +encodeDiagnosis mode f diagnosis = + case diagnosis of + Buggy r -> return $ element "buggy" $ "ruleid" .=. Rule.name r + NotEquivalent -> return $ tag "notequiv" + Similar b s -> ok "similar" b s Nothing + Expected b s r -> ok "expected" b s (Just r) + Detour b s r -> ok "detour" b s (Just r) + Correct b s -> ok "correct" b s Nothing + where + ok t b s mr = do + body <- encodeState mode f s + return $ element t $ do + "ready" .=. map toLower (show b) + maybe (return ()) (("ruleid" .=.) . Rule.name) mr + body + +encodeContext :: Monad m => Bool -> (a -> m XMLBuilder) -> Context a -> m XMLBuilder +encodeContext b f ctx = do + a <- fromContext ctx + xml <- f a + return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx)) diff --git a/src/Service/Options.hs b/src/Service/Options.hs deleted file mode 100644 --- a/src/Service/Options.hs +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Options and command-line flags for services --- ------------------------------------------------------------------------------ -module Service.Options where - -import System.Environment -import System.Exit -import System.Console.GetOpt -import Service.Revision (version, revision) -import Service.LoggingDatabase (logEnabled) - -data Flag = Verbose | Version | Logging Bool | InputFile String - deriving (Show, Eq) - -options :: [OptDescr Flag] -options = - [ Option "?" ["version"] (NoArg Version) "show version number" - , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" - , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" - , Option "f" ["file"] (ReqArg InputFile "FILE") "input FILE" - ] - -header :: String -header = "Usage: service [OPTION] (" ++ versionText ++ ", logging " ++ - (if logEnabled then "enabled" else "disabled") ++ ")" - -versionText :: String -versionText = "version " ++ version ++ ", revision " ++ show revision - -serviceOptions :: IO [Flag] -serviceOptions = do - args <- getArgs - case getOpt Permute options args of - (flags, [], []) | Version `notElem` flags -> - return flags - (_, _, errs) -> do - putStrLn (concat errs ++ usageInfo header options) - exitFailure - -withLogging :: [Flag] -> Bool -withLogging flags = and [ b | Logging b <- flags ] - -withInputFile :: [Flag] -> Maybe String -withInputFile flags = - case [ file | InputFile file <- flags ] of - [hd] -> Just hd - _ -> Nothing diff --git a/src/Service/ProblemDecomposition.hs b/src/Service/ProblemDecomposition.hs --- a/src/Service/ProblemDecomposition.hs +++ b/src/Service/ProblemDecomposition.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,63 +9,71 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Service.ProblemDecomposition (problemDecomposition) where +module Service.ProblemDecomposition + ( problemDecomposition + , Reply, replyToXML, xmlToRequest + ) where import Common.Apply import Common.Context import Common.Exercise import Common.Derivation -import Common.Strategy hiding (not, repeat) -import Common.Transformation +import Common.Strategy hiding (not, repeat, fail) +import Common.Transformation import Common.Utils import Data.Char -import Data.List import Data.Maybe -import Text.OpenMath.Reply import Service.TypedAbstractService (State(..), stepsremaining) +import Text.XML hiding (name) +import qualified Text.XML as XML +import Control.Monad +import Text.OpenMath.Object replyError :: String -> String -> Reply a replyError kind = Error . ReplyError kind problemDecomposition :: State a -> StrategyLocation -> Maybe a -> Reply a -problemDecomposition st@(State ex mpr requestedTerm) sloc answer +problemDecomposition (State ex mpr requestedTerm) sloc answer | isNothing $ subStrategy sloc (strategy ex) = replyError "request error" "invalid location for strategy" | otherwise = let pr = fromMaybe (emptyPrefix $ strategy ex) mpr in - case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext) answer) of + case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of ([], _) -> replyError "strategy error" "not able to compute an expected answer" (answers, Just answeredTerm) | not (null witnesses) -> Ok ReplyOk { repOk_Code = ex - , repOk_Location = nextTask sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses) + , repOk_Location = nextTaskLocation sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses) , repOk_Context = show newPrefix ++ ";" ++ - showContext (fst $ head witnesses) - , repOk_Steps = stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses) + show (getEnvironment $ fst $ head witnesses) + , repOk_Steps = fromMaybe 0 $ stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses) } where - witnesses = filter (similarity ex (fromContext answeredTerm) . fromContext . fst) $ take 1 answers - newPrefix = snd (head witnesses) - + witnesses = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers + newPrefix = snd (head witnesses) ((expected, prefix):_, maybeAnswer) -> Incorrect ReplyIncorrect { repInc_Code = ex - , repInc_Location = subTask sloc loc - , repInc_Expected = fromContext expected + , repInc_Location = subTaskLocation sloc loc + , repInc_Expected = fromJust (fromContext expected) , repInc_Derivation = derivation , repInc_Arguments = args - , repInc_Steps = stepsremaining $ State ex (Just pr) requestedTerm - , repInc_Equivalent = maybe False (equivalence ex (fromContext expected) . fromContext) maybeAnswer - } + , repInc_Steps = fromMaybe 0 $ stepsremaining $ State ex (Just pr) requestedTerm + , repInc_Equivalent = maybe False (equivalenceContext ex expected) maybeAnswer + } where (loc, args) = firstMajorInPrefix pr prefix requestedTerm derivation = let len = length $ prefixToSteps pr rules = stepsToRules $ drop len $ prefixToSteps prefix - f (s, a) = (s, fromContext a) + f (s, a) = (s, fromJust (fromContext a)) in map f (makeDerivation requestedTerm rules) +similarityCtx :: Exercise a -> Context a -> Context a -> Bool +similarityCtx ex a b = fromMaybe False $ + liftM2 (similarity ex) (fromContext a) (fromContext b) + -- | Continue with a prefix until a certain strategy location is reached. At least one -- major rule should have been executed runPrefixLocation :: StrategyLocation -> Prefix a -> a -> [(a, Prefix a)] @@ -74,8 +82,7 @@ cutOnStep (stop . lastStepInPrefix) . prefixTree p0 where f d = (last (terms d), if isEmpty d then p0 else last (steps d)) - stop (Just (End is)) = is==loc - stop (Just (Step is _)) = is==loc + stop (Just (End is _)) = is==loc stop _ = False check result@(a, p) @@ -85,26 +92,17 @@ where rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p --- old (current) and actual (next major rule) location -subTask :: [Int] -> [Int] -> [Int] -subTask (i:is) (j:js) - | i == j = i : subTask is js - | otherwise = [] -subTask _ js = take 1 js - --- old (current) and actual (next major rule) location -nextTask :: [Int] -> [Int] -> [Int] -nextTask (i:is) (j:js) - | i == j = i : nextTask is js - | otherwise = [j] -nextTask _ _ = [] - -firstMajorInPrefix :: Prefix a -> Prefix a -> a -> ([Int], Args) -firstMajorInPrefix p0 prefix a = fromMaybe ([], []) $ do +firstMajorInPrefix :: Prefix a -> Prefix a -> a -> (StrategyLocation, Args) +firstMajorInPrefix p0 prefix a = fromMaybe (topLocation, []) $ do let steps = prefixToSteps prefix newSteps = drop (length $ prefixToSteps p0) steps - is <- safeHead [ is | Step is r <- newSteps, isMajorRule r ] + is <- firstLocation newSteps return (is, argumentsForSteps a newSteps) + where + firstLocation :: [Step a] -> Maybe StrategyLocation + firstLocation [] = Nothing + firstLocation (Begin is _:Step r:_) | isMajorRule r = Just is + firstLocation (_:rest) = firstLocation rest argumentsForSteps :: a -> [Step a] -> Args argumentsForSteps a = flip rec a . stepsToRules @@ -116,15 +114,17 @@ in maybe [] (zip ds) (expectedArguments r a) | otherwise = [] -nextMajorForPrefix :: Prefix a -> a -> [Int] -nextMajorForPrefix p0 a = fromMaybe [] $ do +nextMajorForPrefix :: Prefix a -> a -> StrategyLocation +nextMajorForPrefix p0 a = fromMaybe topLocation $ do (_, p1) <- safeHead $ runPrefixMajor p0 a let steps = prefixToSteps p1 - lastStep <- safeHead (reverse steps) - case lastStep of - Step is r | not (isMinorRule r) -> return is - _ -> Nothing - + rec (reverse steps) + where + rec [] = Nothing + rec (Begin is _:_) = Just is + rec (End is _:_) = Just is + rec (_:rest) = rec rest + makeDerivation :: a -> [Rule a] -> [(String, a)] makeDerivation _ [] = [] makeDerivation a (r:rs) = @@ -137,5 +137,154 @@ map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0 where f d = (last (terms d), if isEmpty d then p0 else last (steps d)) - stop (Just (Step _ r)) = isMajorRule r - stop _ = False + stop (Just (Step r)) = isMajorRule r + stop _ = False + +------------------------------------------------------------------------ +-- Requests + +extractString :: String -> XML -> Either String String +extractString s = liftM getData . findChild s + +xmlToRequest :: XML -> (OMOBJ -> Maybe a) -> Exercise a -> Either String (State a, StrategyLocation, Maybe a) +xmlToRequest xml fromOpenMath ex = do + unless (XML.name xml == "request") $ + fail "XML document is not a request" + loc <- optional (extractLocation "location" xml) + term <- extractExpr "term" xml + context <- optional (extractString "context" xml) + answer <- optional (extractExpr "answer" xml) + t <- maybe (fail "invalid omobj") return (fromOpenMath term) + mt <- case answer of + Nothing -> return Nothing + Just o -> return $ fromOpenMath o + return + ( State + { exercise = ex + , prefix = case context of + Just s -> Just $ getPrefix2 s (strategy ex) + Nothing -> Just $ emptyPrefix (strategy ex) + , context = case context of + Just s -> putInContext2 ex s t + Nothing -> inContext ex t + } + , fromMaybe topLocation loc + , mt + ) + +----------------------------------------------------------- +putInContext2 :: Exercise a -> String -> a -> Context a +putInContext2 ex s = fromMaybe (inContext ex) $ do + (_, s2) <- splitAtElem ';' s + env <- parseContext s2 + return (makeContext ex env) + +getPrefix2 :: String -> LabeledStrategy (Context a) -> Prefix (Context a) +getPrefix2 s ls = fromMaybe (emptyPrefix ls) $ do + (s1, _) <- splitAtElem ';' s + is <- readM s1 + makePrefix is ls + +optional :: Either String a -> Either String (Maybe a) +optional = Right . either (const Nothing) Just + +extractLocation :: String -> XML -> Either String StrategyLocation +extractLocation s xml = do + c <- findChild s xml + case parseStrategyLocation (getData c) of + Just loc -> return loc + _ -> fail "invalid location" + +extractExpr :: String -> XML -> Either String OMOBJ +extractExpr n xml = + case findChild n xml of + Just expr -> + case children expr of + [this] -> xml2omobj this + _ -> fail $ "error in " ++ show (n, xml) + _ -> fail $ "error in " ++ show (n, xml) + +-- Legacy code: remove! +parseContext :: String -> Maybe Environment +parseContext s + | all isSpace s = + return emptyEnv + | otherwise = do + pairs <- mapM (splitAtElem '=') (splitsWithElem ',' s) + let env = foldr (uncurry storeEnv) emptyEnv pairs + return env + +------------------------------------------------------------------------ +-- Data types for replies + +-- There are three possible replies: ok, incorrect, or an error in the protocol (e.g., a parse error) +data Reply a = Ok (ReplyOk a) | Incorrect (ReplyIncorrect a) | Error ReplyError + +data ReplyOk a = ReplyOk + { repOk_Code :: Exercise a + , repOk_Location :: StrategyLocation + , repOk_Context :: String + , repOk_Steps :: Int + } + +data ReplyIncorrect a = ReplyIncorrect + { repInc_Code :: Exercise a + , repInc_Location :: StrategyLocation + , repInc_Expected :: a + , repInc_Derivation :: [(String, a)] + , repInc_Arguments :: Args + , repInc_Steps :: Int + , repInc_Equivalent :: Bool + } + +data ReplyError = ReplyError + { repErr_Kind :: String + , repErr_Message :: String + } + +type Args = [(String, String)] + +------------------------------------------------------------------------ +-- Conversion functions to XML + +replyToXML :: (a -> OMOBJ) -> Reply a -> XML +replyToXML toOpenMath reply = + case reply of + Ok r -> replyOkToXML r + Incorrect r -> replyIncorrectToXML toOpenMath r + Error r -> replyErrorToXML r + +replyOkToXML :: ReplyOk a -> XML +replyOkToXML r = makeReply "ok" $ do + element "strategy" (text $ show $ exerciseCode $ repOk_Code r) + element "location" (text $ show $ repOk_Location r) + element "context" (text $ repOk_Context r) + element "steps" (text $ show $ repOk_Steps r) + +replyIncorrectToXML :: (a -> OMOBJ) -> ReplyIncorrect a -> XML +replyIncorrectToXML toOpenMath r = makeReply "incorrect" $ do + element "strategy" (text $ show $ exerciseCode $ repInc_Code r) + element "location" (text $ show $ repInc_Location r) + element "expected" (builder $ omobj2xml $ toOpenMath $ repInc_Expected r) + element "steps" (text $ show $ repInc_Steps r) + element "equivalent" (text $ show $ repInc_Equivalent r) + + unless (null $ repInc_Arguments r) $ + let f (x, y) = element "elem" $ do + "descr" .=. x + text y + in element "arguments" $ mapM_ f (repInc_Arguments r) + + unless (null $ repInc_Derivation r) $ + let f (x,y) = element "elem" $ do + "ruleid" .=. x + builder (omobj2xml (toOpenMath y)) + in element "derivation" $ mapM_ f (repInc_Derivation r) + +replyErrorToXML :: ReplyError -> XML +replyErrorToXML r = makeReply (repErr_Kind r) (text $ repErr_Message r) + +makeReply :: String -> XMLBuilder -> XML +makeReply kind body = makeXML "reply" $ do + "result" .=. kind + body diff --git a/src/Service/Request.hs b/src/Service/Request.hs --- a/src/Service/Request.hs +++ b/src/Service/Request.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Service/Revision.hs b/src/Service/Revision.hs deleted file mode 100644 --- a/src/Service/Revision.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Service.Revision where -version = "0.5.8" -revision = 2376 -lastChanged = "Fri, 23 Oct 2009" diff --git a/src/Service/RulesInfo.hs b/src/Service/RulesInfo.hs new file mode 100644 --- /dev/null +++ b/src/Service/RulesInfo.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.RulesInfo + ( RulesInfo, mkRulesInfo, rulesInfoXML + , rewriteRuleToFMP, collectExamples + ) where + +import Common.Utils (Some(..)) +import Common.Context +import Common.Derivation +import Common.Exercise hiding (getRule) +import Common.Rewriting +import Common.Strategy (derivationTree) +import Common.Transformation +import Data.Char +import Control.Monad +import Text.OpenMath.Object +import Text.OpenMath.FMP +import Text.XML hiding (name) +import Service.ExercisePackage (termToOMOBJ) +import qualified Data.Map as M + +data RulesInfo a = I + +mkRulesInfo :: RulesInfo a +mkRulesInfo = I + +rulesInfoXML :: Monad m => Exercise a -> (a -> m XMLBuilder) -> m XMLBuilder +rulesInfoXML ex enc = combine $ forM (ruleset ex) $ \r -> do + + let pairs = M.findWithDefault [] (name r) exampleMap + examples <- forM (take 3 pairs) $ \(a, b) -> + liftM2 (,) (enc a) (enc b) + + return $ element "rule" $ do + "name" .=. name r + "buggy" .=. f (isBuggyRule r) + "rewriterule" .=. f (isRewriteRule r) + -- More information + let descr = ruleDescription r + -- to do: rules should carry descriptions + txt = if null descr then (name r) else descr + unless (null txt) $ + element "description" $ text txt + forM_ (ruleGroups r) $ \s -> + element "group" $ text s + forM_ (ruleSiblings r) $ \s -> + element "sibling" $ text s + -- FMPs and CMPs + forM_ (getRewriteRules r) $ \(Some rr, b) -> do + let fmp = rewriteRuleToFMP b rr + case showRewriteRule b rr of + Nothing -> return () + Just s -> element "CMP" (text s) + element "FMP" $ + builder (omobj2xml (toObject fmp)) + -- Examples + forM_ examples $ \(a, b) -> + element "example" (a >> b) + where + f = map toLower . show + exampleMap = collectExamples ex + combine = liftM sequence_ + +rewriteRuleToFMP :: Bool -> RewriteRule a -> FMP +rewriteRuleToFMP sound r + | sound = eqFMP a b + | otherwise = buggyFMP a b + where + a :~> b = fmap termToOMOBJ (rulePair r 0) + +collectExamples :: Exercise a -> M.Map String [(a, a)] +collectExamples ex = foldr add M.empty (examples ex) + where + add a m = let tree = derivationTree (strategy ex) (inContext ex a) + f Nothing = m + f (Just d) = foldr g m (zip3 (terms d) (steps d) (drop 1 (terms d))) + g (a, r, b) = M.insertWith (++) (name r) (liftM2 (,) (fromContext a) (fromContext b)) + in f (derivation tree) diff --git a/src/Service/SearchSpace.hs b/src/Service/SearchSpace.hs deleted file mode 100644 --- a/src/Service/SearchSpace.hs +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.SearchSpace - ( searchSpace, searchSpaceWith, SearchSpaceConfig(..), defaultConfig - ) where - -import Common.Apply -import Common.Rewriting.TreeDiff -import Common.Transformation -import Common.Strategy hiding ((<||>), (<|>)) -import Service.Progress -import qualified Data.Set as S - -data SearchSpaceConfig = SSC - { costStrategy :: Rational - , costRule :: String -> Rational - } - -defaultConfig :: SearchSpaceConfig -defaultConfig = SSC - { costStrategy = 1 - , costRule = const 1 - } - -type Diffs a = a -> [(a, TreeDiff)] - -searchSpace :: (a -> a -> Ordering) -> Diffs a -> Maybe (Prefix a) -> [Rule a] -> a -> Progress Rational (a, Maybe (Prefix a), [Rule a]) -searchSpace = searchSpaceWith defaultConfig - -searchSpaceWith :: SearchSpaceConfig -> (a -> a -> Ordering) -> Diffs a -> Maybe (Prefix a) -> [Rule a] -> a -> Progress Rational (a, Maybe (Prefix a), [Rule a]) -searchSpaceWith config ordering diffs mp rules q = rec (empty ordering) (success (q, [], mp)) - where - rec history worklist = - case extractFirst worklist of - Nothing -> - emptyProgress - Just (cost, (p, rs, mStrat), _, rest) - | member p history -> - addScore cost failure <||> rec history rest - | otherwise -> - let new = newStrategy <|> newRule - newRule = mapProgress (\(a, r) -> (a, r:rs, Nothing)) (stepP p) - newStrategy = - case mStrat of - Nothing -> emptyProgress - Just p1 -> addScore (costStrategy config) $ fromMaybeList $ - flip map (runPrefixMajor p1 p) $ \(x, y) -> - case lastRuleInPrefix y of - Just r | isMajorRule r && stepsToRules (prefixToSteps p1) /= stepsToRules (prefixToSteps y) -> - Just (x, r:rs, Just y) - _ -> Nothing - newHistory = insert p history - newWorklist = addScore cost new <|> rest - in addScore cost (success (p, mStrat, rs)) <||> rec newHistory newWorklist - - stepP a0 = do - (r, a) <- scoreList - [ (cost , (r, a)) - | (a, td) <- diffs a0 - , r <- rules - , let cost = costRule config (name r) * scoreTreeDiff td - ] - fromMaybeList $ - case applyAll r a of - [] -> [ Nothing ] - bs -> [ Just (b, r) | b <- bs] - -scoreTreeDiff :: TreeDiff -> Rational -scoreTreeDiff td = - case td of - Equal -> 1000 - _ -> 1 - {- Equal -> 20 - Inside -> 10 - Different -> 1 - Top -> 2 -} - --- History and X are a work-around, since we don't have an Ord instance for our type -data History a = History (a -> a -> Ordering) (S.Set (X a)) - -newtype X a = X (a -> a -> Ordering, a) - -instance Eq (X a) where - X (f, a) == X (_, b) = f a b == EQ - -instance Ord (X a) where - X (f, a) `compare` X (_, b) = f a b - -empty :: (a -> a -> Ordering) -> History a -empty f = History f S.empty - -member :: a -> History a -> Bool -member a (History f s) = S.member (X (f, a)) s - -insert :: a -> History a -> History a -insert a (History f s) = History f (S.insert (X (f, a)) s) - ------------------------------------------------------- --- Example for logic domain -{- -buggyRules = map liftRuleToContext [buggyDeMorganOr, buggyDeMorganAnd, buggyAndOverOr, buggyOrOverAnd] -expensiveRules = map liftRuleToContext [ruleDefEquiv, ruleAndOverOr, ruleOrOverAnd] - -buggyDeMorganOr :: LogicRule -buggyDeMorganOr = buggyRule $ makeRule "Buggy DeMorganOr" $ - (Not (x :||: y)) |- (Not x :||: Not y) - -buggyDeMorganAnd :: LogicRule -buggyDeMorganAnd = buggyRule $ makeRule "Buggy DeMorganAnd" $ - (Not (x :&&: y)) |- (Not x :&&: Not y) - -buggyAndOverOr :: LogicRule -buggyAndOverOr = buggyRule $ makeRuleList "Buggy AndOverOr" - [ (x :&&: (y :||: z)) |- ((x :||: y) :&&: (x :||: z)) - , ((x :||: y) :&&: z) |- ((x :||: z) :&&: (y :||: z)) - ] - -buggyOrOverAnd :: LogicRule -buggyOrOverAnd = buggyRule $ makeRuleList "Buggy OrOverAnd" - [ (x :||: (y :&&: z)) |- ((x :&&: y) :||: (x :&&: z)) - , ((x :&&: y) :||: z) |- ((x :&&: z) :||: (y :&&: z)) - ] - -ex = (T :->: Var "p") :&&: (Var "q" :||: T) - -q = putStrLn $ unlines $ map f $ successes $ maxDepth 20 $ stepsP (inContext ex) - where f (a, rs) = ppLogic (fromContext a) ++ " " ++ show rs - -w = map (\(a,b) -> (a, length b)) $ successesForScore $ maxDepth 25 $ stepsP (inContext ex) - -ruleScore :: Rule (Context Logic) -> Int -ruleScore r - | name r `elem` map name buggyRules = fromInteger costBUGGY - | name r `elem` map name expensiveRules = fromInteger costEXPENSIVE - | otherwise = fromInteger costRULE - -stepsP :: Context Logic -> Progress Int (Context Logic, [Rule (Context Logic)]) -stepsP = searchSpace (emptyPrefix toDNF) rules - where - list = map liftRuleToContext logicRules ++ buggyRules - rules = zip (map ruleScore list) list -} diff --git a/src/Service/ServiceList.hs b/src/Service/ServiceList.hs --- a/src/Service/ServiceList.hs +++ b/src/Service/ServiceList.hs @@ -1,5 +1,6 @@ +{-# OPTIONS -XRankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,123 +10,219 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Service.ServiceList (serviceList, Service(..), getService, evalService) where +module Service.ServiceList + ( serviceList, exerciselistS + , Service(..), evalService + ) where -import Common.Context +import Common.Exercise hiding (Exercise) +import Common.Strategy (toStrategy) import Common.Transformation -import qualified Common.Exercise as E import Common.Utils (Some(..)) -import Common.Exercise hiding (Exercise) -import Control.Monad.Error -import qualified Service.ExerciseList as S -import qualified Service.TypedAbstractService as S -import Service.FeedbackText -import Service.Types import Data.List (sortBy) +import Service.FeedbackText hiding (ExerciseText) +import Service.ProblemDecomposition +import Service.ExercisePackage +import Service.RulesInfo +import Service.Types +import qualified Common.Exercise as E +import qualified Service.Diagnose as S +import qualified Service.Submit as S +import qualified Service.TypedAbstractService as S -data Service a = Service - { serviceName :: String - , typedValue :: TypedValue a +data Service = Service + { serviceName :: String + , serviceDescription :: String + , serviceDeprecated :: Bool + , serviceFunction :: forall a . TypedValue a } ------------------------------------------------------ -- Querying a service -serviceList :: [Service a] +serviceList :: [Service] serviceList = [ derivationS, allfirstsS, onefirstS, readyS , stepsremainingS, applicableS, applyS, generateS - , submitS + , submitS, diagnoseS , onefirsttextS, findbuggyrulesS , submittextS, derivationtextS - , exerciselistS, rulelistS + , problemdecompositionS + , rulelistS, rulesinfoS, strategyinfoS ] -getService :: Monad m => String -> m (Service a) -getService txt = - case filter ((==txt) . serviceName) serviceList of - [hd] -> return hd - [] -> fail $ "No service " ++ txt - _ -> fail $ "Ambiguous service " ++ txt +makeService :: String -> String -> (forall a . TypedValue a) -> Service +makeService name descr f = Service name descr False f -evalService :: Monad m => Evaluator m inp out a -> Service a -> inp -> m out -evalService f = eval f . typedValue +deprecate :: Service -> Service +deprecate s = s { serviceDeprecated = True } + +evalService :: Monad m => Evaluator m inp out a -> Service -> inp -> m out +evalService f = eval f . serviceFunction ------------------------------------------------------ -- Basic services -derivationS :: Service a -derivationS = Service "derivation" $ - S.derivation ::: State :-> List (Pair Rule Term) +derivationS :: Service +derivationS = makeService "derivation" + "Returns one possible derivation (or: worked-out example) starting with the \ + \current expression. The first optional argument lets you configure the \ + \strategy, i.e., make some minor modifications to it. Rules used and \ + \intermediate expressions are returned in a list." $ + S.derivation ::: Maybe StrategyCfg :-> State :-> Error (List (tuple2 Rule Context)) -allfirstsS :: Service a -allfirstsS = Service "allfirsts" $ - S.allfirsts ::: State :-> List (Triple Rule Location State) +allfirstsS :: Service +allfirstsS = makeService "allfirsts" + "Returns all next steps that are suggested by the strategy. See the \ + \onefirst service to get only one suggestion. For each suggestion, a new \ + \state, the rule used, and the location where the rule was applied are \ + \returned." $ + S.allfirsts ::: State :-> Error (List (tuple3 Rule Location State)) -onefirstS :: Service a -onefirstS = Service "onefirst" $ - S.onefirst ::: State :-> Elem (Triple Rule Location State) +onefirstS :: Service +onefirstS = makeService "onefirst" + "Returns a possible next step according to the strategy. Use the allfirsts \ + \service to get all possible steps that are allowed by the strategy. In \ + \addition to a new state, the rule used and the location where to apply \ + \this rule are returned." $ + S.onefirst ::: State :-> Elem (Error (tuple3 Rule Location State)) -readyS :: Service a -readyS = Service "ready" $ +readyS :: Service +readyS = makeService "ready" + "Test if the current expression is in a form accepted as a final answer. \ + \For this, the strategy is not used." $ S.ready ::: State :-> Bool -stepsremainingS :: Service a -stepsremainingS = Service "stepsremaining" $ - S.stepsremaining ::: State :-> Int +stepsremainingS :: Service +stepsremainingS = makeService "stepsremaining" + "Computes how many steps are remaining to be done, according to the \ + \strategy. For this, only the first derivation is considered, which \ + \corresponds to the one returned by the derivation service." $ + S.stepsremaining ::: State :-> Error Int -applicableS :: Service a -applicableS = Service "applicable" $ +applicableS :: Service +applicableS = makeService "applicable" + "Given a current expression and a location in this expression, this service \ + \yields all rules that can be applied at this location, regardless of the \ + \strategy." $ S.applicable ::: Location :-> State :-> List Rule -applyS :: Service a -applyS = Service "apply" $ - S.apply ::: Rule :-> Location :-> State :-> State +applyS :: Service +applyS = makeService "apply" + "Apply a rule at a certain location to the current expression. If this rule \ + \was not expected by the strategy, we deviate from it. If the rule cannot \ + \be applied, this service call results in an error." $ + S.apply ::: Rule :-> Location :-> State :-> Error State -generateS :: Service a -generateS = Service "generate" $ S.generate ::: - Exercise :-> Optional 5 Int :-> IO State +generateS :: Service +generateS = makeService "generate" + "Given an exercise code and a difficulty level (optional), this service \ + \returns an initial state with a freshly generated expression. The meaning \ + \of the difficulty level (an integer) depends on the exercise at hand." $ + S.generate ::: Exercise :-> Optional 5 Int :-> IO State -findbuggyrulesS :: Service a -findbuggyrulesS = Service "findbuggyrules" $ +findbuggyrulesS :: Service +findbuggyrulesS = makeService "findbuggyrules" + "Search for common misconceptions (buggy rules) in an expression (compared \ + \to the current state). It is assumed that the expression is indeed not \ + \correct. This service has been superseded by the diagnose service." $ S.findbuggyrules ::: State :-> Term :-> List Rule -submitS :: Service a -submitS = Service "submit" $ (\a -> S.submit a . fromContext) ::: - State :-> Term :-> Result +submitS :: Service +submitS = deprecate $ makeService "submit" + "Analyze an expression submitted by a student. Possible answers are Buggy, \ + \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \ + \by the diagnose service." $ + S.submit ::: State :-> Term :-> Result +diagnoseS :: Service +diagnoseS = makeService "diagnose" + "Diagnose an expression submitted by a student. Possible diagnosis are \ + \Buggy (a common misconception was detected), NotEquivalent (something is \ + \wrong, but we don't know what), Similar (the expression is pretty similar \ + \to the last expression in the derivation), Expected (the submitted \ + \expression was anticipated by the strategy), Detour (the submitted \ + \expression was not expected by the strategy, but the applied rule was \ + \detected), and Correct (it is correct, but we don't know which rule was \ + \applied)." $ + S.diagnose ::: State :-> Term :-> Diagnosis + ------------------------------------------------------ -- Services with a feedback component -onefirsttextS :: Service a -onefirsttextS = Service "onefirsttext" $ - onefirsttext ::: State :-> Maybe String :-> Elem (Triple Bool String State) +onefirsttextS :: Service +onefirsttextS = makeService "onefirsttext" + "Similar to the onefirst service, except that the result is now returned as \ + \a formatted text message. The optional string is for announcing the event \ + \leading to this service call (which can influence the returned result). \ + \The boolean in the result specifies whether a suggestion was available or \ + \not." $ + onefirsttext ::: ExerciseText :-> State :-> Maybe String :-> Elem (tuple3 Bool String State) -submittextS :: Service a -submittextS = Service "submittext" $ - submittext ::: State :-> String :-> Maybe String :-> Elem (Triple Bool String State) +submittextS :: Service +submittextS = makeService "submittext" + "Similar to the submit service, except that the result is now returned as \ + \a formatted text message. The expression 'submitted' by the student is sent \ + \in plain text (and parsed by the exercise's parser). The optional string is \ + \for announcing the event leading to this service call. The boolean in the \ + \result specifies whether the submitted term is accepted and incorporated \ + \in the new state." $ + submittext ::: ExerciseText :-> State :-> String :-> Maybe String :-> Elem (tuple3 Bool String State) -derivationtextS :: Service a -derivationtextS = Service "derivationtext" $ - derivationtext ::: State :-> Maybe String :-> List (Pair String Term) - +derivationtextS :: Service +derivationtextS = makeService "derivationtext" + "Similar to the derivation service, but the rules appearing in the derivation \ + \have been replaced by a short description of the rule. The optional string is \ + \for announcing the event leading to this service call." $ + derivationtext ::: ExerciseText :-> State :-> Maybe String :-> Error (List (tuple2 String Context)) + ------------------------------------------------------ +-- Problem decomposition service + +problemdecompositionS :: Service +problemdecompositionS = makeService "problemdecomposition" + "Strategy service developed for the SURF project Intelligent Feedback for a \ + \binding with the MathDox system on linear algebra exercises. This is a \ + \composite service, and available for backwards compatibility." $ + problemDecomposition ::: State :-> StrategyLoc :-> Maybe Term :-> DecompositionReply + +------------------------------------------------------ -- Reflective services -exerciselistS :: Service a -exerciselistS = Service "exerciselist" $ - allExercises ::: List (Quadruple (Tag "domain" String) (Tag "identifier" String) (Tag "description" String) (Tag "status" String)) +exerciselistS :: [Some ExercisePackage] -> Service +exerciselistS list = makeService "exerciselist" + "Returns all exercises known to the system. For each exercise, its domain, \ + \identifier, a short description, and its current status are returned." $ + allExercises list ::: List (tuple4 (Tag "domain" String) (Tag "identifier" String) (Tag "description" String) (Tag "status" String)) -rulelistS :: Service a -rulelistS = Service "rulelist" $ - allRules ::: Exercise :-> List (Triple (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) +rulelistS :: Service +rulelistS = makeService "rulelist" + "Returns all rules of a particular exercise. For each rule, we return its \ + \name (or identifier), whether the rule is buggy, and whether the rule was \ + \expressed as an observable rewrite rule. See rulesinfo for more details \ + \about the rules." $ + allRules ::: Exercise :-> List (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) -allExercises :: [(String, String, String, String)] -allExercises = map make $ sortBy cmp S.exerciseList +rulesinfoS :: Service +rulesinfoS = makeService "rulesinfo" + "Returns a list of all rules of a particular exercise, with many details \ + \including Formal Mathematical Properties (FMPs) and example applications." $ + mkRulesInfo ::: RulesInfo + +strategyinfoS :: Service +strategyinfoS = makeService "strategyinfo" + "Returns the representation of the strategy of a particular exercise." $ + (toStrategy . strategy) ::: Exercise :-> Strategy + +allExercises :: [Some ExercisePackage] -> [(String, String, String, String)] +allExercises = map make . sortBy cmp where cmp e1 e2 = f e1 `compare` f e2 - f (Some e) = (domain (exerciseCode e), identifier (exerciseCode e)) - make (Some ex) = (domain (exerciseCode ex), identifier (exerciseCode ex), description ex, show (status ex)) + f (Some pkg) = exerciseCode (exercise pkg) + make (Some pkg) = + let ex = exercise pkg + code = exerciseCode ex + in (domain code, identifier code, description ex, show (status ex)) allRules :: E.Exercise a -> [(String, Bool, Bool)] allRules = map make . ruleset diff --git a/src/Service/StrategyInfo.hs b/src/Service/StrategyInfo.hs new file mode 100644 --- /dev/null +++ b/src/Service/StrategyInfo.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Converting a strategy to XML, and the other way around. +-- +----------------------------------------------------------------------------- +module Service.StrategyInfo (strategyToXML, xmlToStrategy) where + +import Data.Char +import Data.Maybe +import Control.Monad +import Common.Strategy.Core (Core(..), noLabels) +import Common.Strategy.Abstract +import Text.XML +import Common.Transformation hiding (name) +import Common.Utils (readInt) + +instance InXML (LabeledStrategy a) where + toXML = toXML . toStrategy + fromXML xml = fromXML xml >>= toLabeledStrategy + +instance InXML (Strategy a) where + toXML = strategyToXML + fromXML = xmlToStrategy unknownRule + +----------------------------------------------------------------------- +-- Strategy to XML + +strategyToXML :: IsStrategy f => f a -> XML +strategyToXML = coreToXML . toCore . toStrategy + +infoToXML :: LabelInfo -> XMLBuilder +infoToXML info = do + "name" .=. labelName info + when (removed info) ("removed" .=. "true") + when (collapsed info) ("collapsed" .=. "true") + when (hidden info) ("hidden" .=. "true") + +coreToXML :: Core LabelInfo a -> XML +coreToXML core = makeXML "label" $ + case core of + Label l a -> infoToXML l >> coreBuilder infoToXML a + _ -> coreBuilder infoToXML core + +coreBuilder :: (l -> XMLBuilder) -> Core l a -> XMLBuilder +coreBuilder f = rec + where + rec core = + case core of + _ :*: _ -> asList "sequence" isSequence + _ :|: _ -> asList "choice" isChoice + _ :|>: _ -> asList "orelse" isOrElse + Many a -> element "many" (rec a) + Repeat a -> element "repeat" (rec a) + Label l a -> element "label" (f l >> rec a) + Rec n a -> element "rec" (("var" .=. show n) >> rec a) + Not a -> element "not" (recNot a) + Rule l r -> element "rule" (maybe ("name" .=. show r) f l) + Var n -> element "var" ("var" .=. show n) + Succeed -> tag "succeed" + Fail -> tag "fail" + where + asList s g = element s (mapM_ rec (collect g core)) + recNot = coreBuilder (const (return ())) + +collect :: (a -> Maybe (a, a)) -> a -> [a] +collect f = ($ []) . rec + where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a) + +isSequence :: Core l a -> Maybe (Core l a, Core l a) +isSequence (a :*: b) = Just (a, b) +isSequence _ = Nothing + +isChoice :: Core l a -> Maybe (Core l a, Core l a) +isChoice (a :|: b) = Just (a, b) +isChoice _ = Nothing + +isOrElse :: Core l a -> Maybe (Core l a, Core l a) +isOrElse (a :|>: b) = Just (a, b) +isOrElse _ = Nothing + +----------------------------------------------------------------------- +-- XML to strategy + +xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) -> XML -> m (Strategy a) +xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g + where + g info = case f (labelName info) of + Just r -> return r + Nothing -> fail $ "Unknown rule: " ++ show (labelName info) + +xmlToInfo :: Monad m => XML -> m LabelInfo +xmlToInfo xml = do + n <- findAttribute "name" xml + let boolAttr s = fromMaybe False (findBool s xml) + return (makeInfo n) + { removed = boolAttr "removed" + , collapsed = boolAttr "collapsed" + , hidden = boolAttr "hidden" + } + +findBool :: Monad m => String -> XML -> m Bool +findBool attr xml = do + s <- findAttribute attr xml + case map toLower s of + "true" -> return True + "false" -> return False + _ -> fail "not a boolean" + +unknownRule :: Monad m => String -> m (Rule a) +unknownRule s = + let n = "#Unknown rule:" ++ s + in return (makeSimpleRule n (const Nothing)) + +readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a) +readStrategy f g xml = do + xs <- mapM (readStrategy f g) (children xml) + let s = name xml + case lookup s table of + Just f -> f s xs + Nothing -> + fail $ "Unknown strategy combinator " ++ show s + where + buildSequence _ xs + | null xs = return Succeed + | otherwise = return (foldr1 (:*:) xs) + buildChoice _ xs + | null xs = return Fail + | otherwise = return (foldr1 (:|:) xs) + buildOrElse _ xs + | null xs = return Fail + | otherwise = return (foldr1 (:|>:) xs) + buildLabel x = do + info <- f xml + return (Label info x) + buildRule = do + info <- f xml + rule <- g info + return (Rule (Just info) rule) + buildRec x = do + s <- findAttribute "var" xml + i <- maybe (fail "var: not an int") return (readInt s) + return (Rec i x) + buildVar = do + s <- findAttribute "var" xml + i <- maybe (fail "var: not an int") return (readInt s) + return (Var i) + + nullary a _ [] = return a + nullary _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 0 args" + + unary f _ [x] = return (f x) + unary _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 1 arg" + + join2 f g a b = join (f g a b) + + table = + [ ("sequence", buildSequence) + , ("choice", buildChoice) + , ("orelse", buildOrElse) + , ("many", unary Many) + , ("repeat", unary Repeat) + , ("label", join2 unary buildLabel) + , ("rec", join2 unary buildRec) + , ("not", unary (Not . noLabels)) + , ("rule", join2 nullary buildRule) + , ("var", join2 nullary buildVar) + , ("succeed", nullary Succeed) + , ("fail", nullary Fail) + ] diff --git a/src/Service/Submit.hs b/src/Service/Submit.hs new file mode 100644 --- /dev/null +++ b/src/Service/Submit.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Diagnose a term submitted by a student. Deprecated (see diagnose service). +-- +----------------------------------------------------------------------------- +module Service.Submit (submit, Result(..), getResultState) where + +import Common.Transformation +import Common.Context +import qualified Service.Diagnose as Diagnose +import Service.Diagnose (Diagnosis, diagnose) +import Service.TypedAbstractService + +-- Note that in the typed setting there is no syntax error +data Result a = Buggy [Rule (Context a)] + | NotEquivalent + | Ok [Rule (Context a)] (State a) -- equivalent + | Detour [Rule (Context a)] (State a) -- equivalent + | Unknown (State a) -- equivalent + +fromDiagnose :: Diagnosis a -> Result a +fromDiagnose diagnose = + case diagnose of + Diagnose.Buggy r -> Buggy [r] + Diagnose.NotEquivalent -> NotEquivalent + Diagnose.Similar _ s -> Ok [] s + Diagnose.Expected _ s r -> Ok [r] s + Diagnose.Detour _ s r -> Detour [r] s + Diagnose.Correct _ s -> Unknown s + +submit :: State a -> a -> Result a +submit state new = fromDiagnose (diagnose state new) + +getResultState :: Result a -> Maybe (State a) +getResultState result = + case result of + Ok _ st -> return st + Detour _ st -> return st + Unknown st -> return st + _ -> Nothing diff --git a/src/Service/TypedAbstractService.hs b/src/Service/TypedAbstractService.hs --- a/src/Service/TypedAbstractService.hs +++ b/src/Service/TypedAbstractService.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,37 +13,30 @@ ( -- * Exercise state State(..), emptyState, term -- * Services - , stepsremaining, findbuggyrules, submit, ready, allfirsts - , derivation, onefirst, applicable, apply, generate, generateWith - -- * Result data type - , Result(..), getResultState, resetStateIfNeeded + , stepsremaining, findbuggyrules, ready, allfirsts, derivation + , onefirst, applicable, apply, generate, generateWith ) where import qualified Common.Apply as Apply import Common.Context import Common.Derivation hiding (derivation) -import Common.Exercise (Exercise(..), ruleset, randomTermWith) -import Common.Strategy hiding (not) +import Common.Exercise (Exercise(..), ruleset, randomTermWith, inContext) +import Common.Strategy hiding (not, fail) import Common.Transformation (Rule, name, isMajorRule, isBuggyRule) import Common.Utils (safeHead) +import Common.Navigator import Data.Maybe import System.Random +import Control.Monad data State a = State - { exercise :: Exercise a - , prefix :: Maybe (Prefix (Context a)) - , context :: Context a + { exercise :: Exercise a + , prefix :: Maybe (Prefix (Context a)) + , context :: Context a } term :: State a -> a -term = fromContext . context - --- Note that in the typed setting there is no syntax error -data Result a = Buggy [Rule (Context a)] - | NotEquivalent - | Ok [Rule (Context a)] (State a) -- equivalent - | Detour [Rule (Context a)] (State a) -- equivalent - | Unknown (State a) -- equivalent +term = fromMaybe (error "invalid term") . fromContext . context ----------------------------------------------------------- @@ -51,7 +44,7 @@ emptyState ex a = State { exercise = ex , prefix = Just (emptyPrefix (strategy ex)) - , context = inContext a + , context = inContext ex a } -- result must be in the IO monad to access a standard random number generator @@ -62,134 +55,98 @@ generateWith :: StdGen -> Exercise a -> Int -> State a generateWith rng ex level = emptyState ex (randomTermWith rng level ex) - -derivation :: State a -> [(Rule (Context a), Context a)] -derivation state = - case allfirsts state of - [] -> [] - (r, _, next):_ -> (r, context next) : derivation next +derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)] +derivation mcfg state = + case (prefix state, mcfg) of + (Nothing, _) -> fail "Prefix is required" + -- configuration is only allowed beforehand: hence, the prefix + -- should be empty (or else, the configuration is ignored). This + -- restriction should probably be relaxed later on. + (Just p, Just cfg) | null (prefixToSteps p) -> + let new = configure cfg $ strategy $ exercise state + in rec state + { prefix = Just (emptyPrefix new) + , exercise = (exercise state) {strategy=new} + } + _ -> rec state + where + rec :: Monad m => State a -> m [(Rule (Context a), Context a)] + rec state = do + xs <- allfirsts state + case xs of + [] -> return [] + (r, _, next):_ -> liftM ((r, context next):) (rec next) + -- Note that we have to inspect the last step of the prefix afterwards, because -- the remaining part of the derivation could consist of minor rules only. -allfirsts :: State a -> [(Rule (Context a), Location, State a)] +allfirsts :: Monad m => State a -> m [(Rule (Context a), Location, State a)] allfirsts state = case prefix state of Nothing -> - error "allfirsts: no prefix" + fail "Prefix is required" Just p0 -> let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (context state)) - in mapMaybe make (derivations tree) + in return (mapMaybe make (derivations tree)) where - stop (Just (Step _ r)) = isMajorRule r + stop (Just (Step r)) = isMajorRule r stop _ = False make d = do prefixEnd <- safeHead (reverse (steps d)) termEnd <- safeHead (reverse (terms d)) case lastStepInPrefix prefixEnd of - Just (Step _ r) | isMajorRule r -> return + Just (Step r) | isMajorRule r -> return ( r , location termEnd , state { context = termEnd - , prefix = Just prefixEnd + , prefix = Just prefixEnd } ) _ -> Nothing -onefirst :: State a -> (Rule (Context a), Location, State a) -onefirst = fromMaybe (error "onefirst") . safeHead . allfirsts +onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a) +onefirst state = + case allfirsts state of + Right (hd:_) -> return hd + Right [] -> fail "No step possible" + Left msg -> fail msg applicable :: Location -> State a -> [Rule (Context a)] applicable loc state = let check r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (context state)) in filter check (ruleset (exercise state)) +-- local helper +setLocation :: Location -> Context a -> Context a +setLocation loc c0 = fromMaybe c0 $ do + navigateTo loc c0 + -- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the -- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied -- to the current term at the given location, in which case the request is invalid. -apply :: Rule (Context a) -> Location -> State a -> State a +apply :: Monad m => Rule (Context a) -> Location -> State a -> m (State a) apply r loc state = maybe applyOff applyOn (prefix state) where applyOn _ = -- scenario 1: on-strategy - fromMaybe applyOff $ safeHead - [ s1 | (r1, loc1, s1) <- allfirsts state, name r == name r1, loc==loc1 ] + maybe applyOff return $ safeHead + [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, name r == name r1, loc==loc1 ] applyOff = -- scenario 2: off-strategy case Apply.apply r (setLocation loc (context state)) of - Just new -> state { context=new } - Nothing -> error "apply" + Just new -> return state { context=new, prefix=Nothing } + Nothing -> fail ("Cannot apply " ++ show r) ready :: State a -> Bool ready state = isReady (exercise state) (term state) -stepsremaining :: State a -> Int -stepsremaining = length . derivation +stepsremaining :: Monad m => State a -> m Int +stepsremaining = liftM length . derivation Nothing -findbuggyrules :: State a -> Context a -> [Rule (Context a)] +findbuggyrules :: State a -> a -> [Rule (Context a)] findbuggyrules state a = let ex = exercise state - isA = similarity ex (fromContext a) . fromContext + isA = maybe False (similarity ex a) . fromContext buggies = filter isBuggyRule (ruleset ex) check r = any isA (Apply.applyAll r (context state)) - in filter check buggies - --- make sure that new has a prefix (because of possible detour) --- when resetting the prefix, also make sure that the context is refreshed -resetStateIfNeeded :: State a -> State a -resetStateIfNeeded s - | isJust (prefix s) = s - | otherwise = s - { prefix = Just (emptyPrefix (strategy (exercise s))) - , context = inContext (fromContext (context s)) - } - -submit :: State a -> a -> Result a -submit state new - -- Is the submitted term equivalent? - | not (equivalence (exercise state) (term state) new) = - -- Is the rule used discoverable by trying all known buggy rules? - case discovered True of - Just r -> -- report the buggy rule - Buggy [r] - Nothing -> -- unknown mistake - NotEquivalent - -- Is the submitted term (very) similar to the previous one? - | similarity (exercise state) (term state) new = - -- If yes, report this - Ok [] state - -- Was the submitted term expected by the strategy - | isJust expected = - -- If yes, return new state and rule - let (r, _, ns) = fromJust expected - in Ok [r] ns - -- Is the rule used discoverable by trying all known rules? - | otherwise = - case discovered False of - Just r -> -- If yes, report the found rule as a detour - Detour [r] state { prefix=Nothing, context=inContext new } - Nothing -> -- If not, we give up - Unknown state { prefix=Nothing, context=inContext new } - where - expected = - let p (_, _, ns) = similarity (exercise state) new (term ns) - in safeHead (filter p (allfirsts state)) - - discovered searchForBuggy = safeHead - [ r - | r <- ruleset (exercise state) - , isBuggyRule r == searchForBuggy - , a <- Apply.applyAll r (inContext sub1) - , similarity (exercise state) sub2 (fromContext a) - ] - where - mode = not searchForBuggy - diff = difference (exercise state) mode (term state) new - (sub1, sub2) = fromMaybe (term state, new) diff - -getResultState :: Result a -> Maybe (State a) -getResultState result = - case result of - Ok _ st -> return st - Detour _ st -> return st - Unknown st -> return st - _ -> Nothing + in filter check buggies diff --git a/src/Service/TypedExample.hs b/src/Service/TypedExample.hs new file mode 100644 --- /dev/null +++ b/src/Service/TypedExample.hs @@ -0,0 +1,91 @@ +{-# OPTIONS -XGADTs #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.TypedExample (typedExample) where + +import Data.Char +import Service.DomainReasoner +import Service.ModeXML +import Service.ExercisePackage +import Service.ServiceList +import Service.Types +import Common.Exercise +import Text.XML + +typedExample :: ExercisePackage a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool) +typedExample pkg service args = do + -- Construct a request in xml + xmlRequest <- + case makeArgType args of + Nothing -> return $ + stdReply (serviceName service) enc (exercise pkg) (return ()) + Just (reqTuple ::: reqTp) -> + case encodeType (encoder evaluator) reqTp reqTuple of + Left err -> fail err + Right xml -> return $ + stdReply (serviceName service) enc (exercise pkg) xml + -- Construct a reply in xml + xmlReply <- return $ + case foldl dynamicApply (serviceFunction service) args of + reply ::: replyTp -> + case encodeType (encoder evaluator) replyTp reply of + Left err -> resultError err + Right xml -> resultOk xml + -- Check request/reply pair + vers <- getVersion + xmlTest <- do + (_, txt, _) <- processXML (show xmlRequest) + let p = filter (not . isSpace) + out = showXML (if null vers then xmlReply else addVersion vers xmlReply) + return (p txt == p out) + `catchError` + const (return False) + return (xmlRequest, xmlReply, xmlTest) + where + (evaluator, enc) + | withOpenMath pkg = (openMathConverterTp pkg, "openmath") + | otherwise = (stringFormatConverterTp pkg, "string") + +stdReply :: String -> String -> Exercise a -> XMLBuilder -> XML +stdReply s enc ex body = makeXML "request" $ do + "service" .=. s + "exerciseid" .=. show (exerciseCode ex) + "source" .=. "test" + "encoding" .=. enc + body + +makeArgType :: [TypedValue a] -> Maybe (TypedValue a) +makeArgType [] = fail "makeArgType: empty list" +makeArgType [_ ::: Exercise] = fail "makeArgType: empty list" +makeArgType [tv] = return tv +makeArgType ((a1 ::: t1) : rest) = do + a2 ::: t2 <- makeArgType rest + return $ (a1, a2) ::: Pair t1 t2 + +dynamicApply :: TypedValue a -> TypedValue a -> TypedValue a +dynamicApply fun arg = + case (fun, arg) of + (f ::: t1 :-> t2, a ::: t3) -> + case equal t3 t1 of + Just eq -> f (eq a) ::: t2 + Nothing -> error $ "mismatch (argument type): " ++ show t3 ++ " does not match " ++ show t1 + _ -> error "mismatch (not a function)" + +equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2) +equal t1 t2 = + case (t1, t2) of + (Maybe a, Maybe b) -> fmap fmap (equal a b) + (StrategyCfg, StrategyCfg) -> Just id + (State, State) -> Just id + (Location, Location) -> Just id + (Exercise, Exercise) -> Just id + _ -> Nothing diff --git a/src/Service/Types.hs b/src/Service/Types.hs --- a/src/Service/Types.hs +++ b/src/Service/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,83 +12,120 @@ ----------------------------------------------------------------------------- module Service.Types where -import Common.Context (Context, Location, fromContext) +import Common.Context (Context, fromContext) import Common.Exercise (Exercise) +import Common.Navigator (Location) import Common.Transformation (Rule, name) +import Common.Strategy (Strategy, StrategyLocation, StrategyConfiguration) import Common.Utils (commaList) import Control.Arrow import Control.Monad import Data.Maybe -import Service.TypedAbstractService (State, Result) +import Service.ExercisePackage (ExercisePackage, exercise, getExerciseText) +import Service.TypedAbstractService (State) +import Service.Submit (Result) +import Service.Diagnose (Diagnosis) +import Service.FeedbackText (ExerciseText) +import Service.RulesInfo import System.IO.Unsafe +import qualified Service.ProblemDecomposition as Decomposition infix 2 ::: infixr 3 :-> data TypedValue a = forall t . t ::: Type a t +tuple2 :: Type a t1 -> Type a t2 -> Type a (t1, t2) +tuple2 = Pair + +tuple3 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3) +tuple3 t1 t2 t3 = Iso f g (Pair t1 (Pair t2 t3)) + where + f (a, (b, c)) = (a, b, c) + g (a, b, c) = (a, (b, c)) + +tuple4 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4) +tuple4 t1 t2 t3 t4 = Iso f g (Pair t1 (Pair t2 (Pair t3 t4))) + where + f (a, (b, (c, d))) = (a, b, c, d) + g (a, b, c, d) = (a, (b, (c, d))) + data Type a t where + -- Type isomorphisms (for defining type synonyms) + Iso :: (t1 -> t2) -> (t2 -> t1) -> Type a t1 -> Type a t2 -- Function type - (:->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) - -- Tuple types - Pair :: Type a t1 -> Type a t2 -> Type a (t1, t2) - Triple :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3) - Quadruple :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4) + (:->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) -- Special annotations - Tag :: String -> Type a t1 -> Type a t1 - Optional :: t1 -> Type a t1 -> Type a t1 - Maybe :: Type a t1 -> Type a (Maybe t1) + Tag :: String -> Type a t1 -> Type a t1 + Optional :: t1 -> Type a t1 -> Type a t1 + Maybe :: Type a t1 -> Type a (Maybe t1) + Error :: Type a t -> Type a (Either String t) -- Type constructors - List :: Type a t -> Type a [t] - Elem :: Type a t -> Type a t -- quick fix - IO :: Type a t -> Type a (IO t) + List :: Type a t -> Type a [t] + Pair :: Type a t1 -> Type a t2 -> Type a (t1, t2) + Elem :: Type a t -> Type a t -- quick fix + IO :: Type a t -> Type a (IO t) -- Exercise-specific types - State :: Type a (State a) - Exercise :: Type a (Exercise a) - Rule :: Type a (Rule (Context a)) - Term :: Type a (Context a) - Result :: Type a (Result a) + State :: Type a (State a) + Exercise :: Type a (Exercise a) + Strategy :: Type a (Strategy (Context a)) + ExerciseText :: Type a (ExerciseText a) + Rule :: Type a (Rule (Context a)) + RulesInfo :: Type a (RulesInfo a) + Term :: Type a a + Context :: Type a (Context a) + Result :: Type a (Result a) + Diagnosis :: Type a (Diagnosis a) + Location :: Type a Location + StrategyLoc :: Type a StrategyLocation + StrategyCfg :: Type a StrategyConfiguration + DecompositionReply :: Type a (Decomposition.Reply a) -- Basic types - Bool :: Type a Bool - Int :: Type a Int - String :: Type a String - Location :: Type a Location + Bool :: Type a Bool + Int :: Type a Int + String :: Type a String instance Show (Type a t) where - show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 - show (Pair t1 t2) = "(" ++ commaList [show t1, show t2] ++ ")" - show (Triple t1 t2 t3) = "(" ++ commaList [show t1, show t2, show t3] ++ ")" - show (Quadruple t1 t2 t3 t4) = "(" ++ commaList [show t1, show t2, show t3, show t4] ++ ")" - show (Tag _ t) = show t - show (Optional _ t) = "(" ++ show t ++ ")?" - show (Maybe t) = "(" ++ show t ++ ")?" - show (List t) = "[" ++ show t ++ "]" - show (Elem t) = show t - show (IO t) = show t - show t = fromMaybe "unknown" (groundType t) - + show (Iso _ _ t) = show t + show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 + show t@(Pair _ _) = showTuple t + show (Tag _ t) = show t + show (Optional _ t) = "(" ++ show t ++ ")?" + show (Maybe t) = "(" ++ show t ++ ")?" + show (Error t) = show t + show (List t) = "[" ++ show t ++ "]" + show (Elem t) = show t + show (IO t) = show t + show t = fromMaybe "unknown" (groundType t) + +showTuple :: Type a t -> String +showTuple t = "(" ++ commaList (collect t) ++ ")" + where + collect :: Type a t -> [String] + collect (Pair t1 t2) = collect t1 ++ collect t2 + collect (Iso _ _ t) = collect t + collect t = [show t] + groundType :: Type a t -> Maybe String groundType tp = case tp of - State -> Just "State" - Exercise -> Just "Exercise" - Rule -> Just "Rule" - Term -> Just "Term" - Result -> Just "Result" - Bool -> Just "Bool" - Int -> Just "Int" - String -> Just "String" - Location -> Just "Location" - _ -> Nothing - -{- eqType :: Type a1 t1 -> Type a2 t2 -> Bool -eqType (t1 :-> t2) (t3 :-> t4) = eqType t1 t3 && eqType t2 t4 -eqType (Pair t1 t2) (Pair t3 t4) = eqType t1 t3 && eqType t2 t4 -eqType (Triple t1 t2 t3) (Triple t4 t5 t6) = eqType t1 t4 && eqType t2 t5 && eqType t3 t6 -eqType (List t1) (List t2) = eqType t1 t2 -eqType (Elem t1) (Elem t2) = eqType t1 t2 -eqType (IO t1) (IO t2) = eqType t1 t2 -eqType t1 t2 = maybe False ((groundType t1 ==) . Just) (groundType t2) -} + State -> Just "State" + Exercise -> Just "Exercise" + Strategy -> Just "Strategy" + ExerciseText -> Just "ExerciseText" + Rule -> Just "Rule" + RulesInfo -> Just "RulesInfo" + Term -> Just "Term" + Context -> Just "Context" + Result -> Just "Result" + Diagnosis -> Just "Diagnosis" + Bool -> Just "Bool" + Int -> Just "Int" + String -> Just "String" + Location -> Just "Location" + StrategyLoc -> Just "StrategyLocation" + StrategyCfg -> Just "StrategyConfiguration" + _ -> Nothing data Evaluator m inp out a = Evaluator { encoder :: Encoder m out a @@ -102,11 +139,14 @@ } data Decoder m s a = Decoder - { decodeType :: forall t . Type a t -> s -> m (t, s) - , decodeTerm :: s -> m a - , decoderExercise :: Exercise a + { decodeType :: forall t . Type a t -> s -> m (t, s) + , decodeTerm :: s -> m a + , decoderPackage :: ExercisePackage a } +decoderExercise :: Decoder m s a -> Exercise a +decoderExercise = exercise . decoderPackage + eval :: Monad m => Evaluator m inp out a -> TypedValue a -> inp -> m out eval f (tv ::: tp) s = case tp of @@ -119,59 +159,48 @@ decodeDefault :: MonadPlus m => Decoder m s a -> Type a t -> s -> m (t, s) decodeDefault dec tp s = case tp of + Iso f _ t -> liftM (first f) (decodeType dec t s) Pair t1 t2 -> do (a, s1) <- decodeType dec t1 s (b, s2) <- decodeType dec t2 s1 return ((a, b), s2) - Triple t1 t2 t3 -> do - (a, s1) <- decodeType dec t1 s - (b, s2) <- decodeType dec t2 s1 - (c, s3) <- decodeType dec t3 s2 - return ((a, b, c), s3) - Quadruple t1 t2 t3 t4 -> do - (a, s1) <- decodeType dec t1 s - (b, s2) <- decodeType dec t2 s1 - (c, s3) <- decodeType dec t3 s2 - (d, s4) <- decodeType dec t4 s3 - return ((a, b, c, d), s4) Tag _ t1 -> decodeType dec t1 s Optional a t1 -> decodeType dec t1 s `mplus` return (a, s) Maybe t1 -> liftM (first Just) (decodeType dec t1 s) `mplus` return (Nothing, s) + Error t -> + liftM (first Right) (decodeType dec t s) + Exercise -> do + return (exercise (decoderPackage dec), s) + ExerciseText -> do + exText <- case getExerciseText (decoderPackage dec) of + Just a -> return a + Nothing -> fail "No support for exercise texts" + return (exText, s) _ -> fail $ "No support for argument type: " ++ show tp encodeDefault :: Monad m => Encoder m s a -> Type a t -> t -> m s encodeDefault enc tp tv = case tp of + Iso _ f t -> encodeType enc t (f tv) Pair t1 t2 -> do let (a, b) = tv x <- encodeType enc t1 a y <- encodeType enc t2 b return (encodeTuple enc [x, y]) - Triple t1 t2 t3 -> do - let (a, b, c) = tv - x <- encodeType enc t1 a - y <- encodeType enc t2 b - z <- encodeType enc t3 c - return (encodeTuple enc [x, y, z]) - Quadruple t1 t2 t3 t4 -> do - let (a, b, c, d) = tv - x <- encodeType enc t1 a - y <- encodeType enc t2 b - z <- encodeType enc t3 c - u <- encodeType enc t4 d - return (encodeTuple enc [x, y, z, u]) Tag _ t1 -> encodeType enc t1 tv Elem t1 -> encodeType enc t1 tv Optional _ t1 -> encodeType enc t1 tv Maybe t1 -> case tv of Just a -> encodeType enc t1 a Nothing -> return (encodeTuple enc []) + Error t -> either fail (encodeType enc t) tv IO t1 -> encodeType enc t1 (unsafePerformIO tv) Rule -> encodeType enc String (name tv) - Term -> encodeTerm enc (fromContext tv) + Term -> encodeTerm enc tv + Context -> fromContext tv >>= encodeType enc Term Location -> encodeType enc String (show tv) - _ -> fail "No support for result type" + _ -> fail ("No support for result type: " ++ show tp) diff --git a/src/Text/HTML.hs b/src/Text/HTML.hs --- a/src/Text/HTML.hs +++ b/src/Text/HTML.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,12 +13,14 @@ ----------------------------------------------------------------------------- module Text.HTML ( HTML, HTMLBuilder, showHTML - , htmlPage, errorPage, link, h1, h2, preText, ul, table, text, image, space - , bold, italic, para, ttText, hr, br, pre, center + , htmlPage, errorPage, link, h1, h2, h3, h4, preText, ul, table, noBorderTable + , text, image, space, tt, spaces + , bold, italic, para, ttText, hr, br, pre, center, bullet ) where import Text.XML hiding (text) import qualified Text.XML as XML +import Control.Monad type HTML = XML @@ -58,6 +60,13 @@ h2 :: String -> HTMLBuilder h2 = element "h2" . text +h3 :: String -> HTMLBuilder +h3 = element "h3" . text + +h4 :: String -> HTMLBuilder +h4 = element "h4" . text + + bold, italic :: HTMLBuilder -> HTMLBuilder bold = element "b" italic = element "i" @@ -91,19 +100,20 @@ "border" .=. "1" mapM_ (element "tr" . mapM_ (element "td")) rows -space :: HTMLBuilder -space = XML.text " " +noBorderTable :: [[HTMLBuilder]] -> HTMLBuilder +noBorderTable rows = element "table" $ do + "border" .=. "0" + mapM_ (element "tr" . mapM_ (element "td")) rows +spaces :: Int -> HTMLBuilder +spaces n = replicateM_ n space + +space, bullet :: HTMLBuilder +space = XML.unescaped " " +bullet = XML.unescaped "•" + image :: String -> HTMLBuilder image n = element "img" ("src" .=. n) text :: String -> HTMLBuilder -text = XML.text . escape - -escape :: String -> String -escape = concatMap f - where - f '<' = "<" - f '>' = ">" - f '\n' = "
" - f c = [c] +text = XML.text diff --git a/src/Text/JSON.hs b/src/Text/JSON.hs --- a/src/Text/JSON.hs +++ b/src/Text/JSON.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -17,30 +17,16 @@ , InJSON(..) -- type class" , lookupM , parseJSON, showCompact, showPretty -- parser and pretty-printers - , jsonRPC, JSON_RPC_Handler + , jsonRPC, JSON_RPC_Handler, testMe ) where import Text.Parsing import qualified Text.UTF8 as UTF8 -import Common.Utils (indent) -import Data.Char import Data.List (intersperse) import Data.Maybe -import Control.Monad -import Service.Revision (version, revision) +import Control.Monad.Error +import Test.QuickCheck --- temporary test -{- -main :: IO () -main = do - input <- readFile "ex.json" - print (scan input) - putStrLn input - let Just json = parseJSON input - print json - print (parseJSON $ show json) --} - data JSON = Number Number -- integer, real, or floating point | String String -- double-quoted Unicode with backslash escapement @@ -48,10 +34,11 @@ | Array [JSON] -- ordered sequence (comma-separated, square brackets) | Object [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets | Null + deriving Eq type Key = String -data Number = I Integer | F Float +data Number = I Integer | D Double deriving Eq instance Show JSON where show = showPretty @@ -89,7 +76,7 @@ instance Show Number where show (I n) = show n - show (F f) = show f + show (D d) = show d class InJSON a where toJSON :: a -> JSON @@ -110,9 +97,9 @@ fromJSON (Number (I n)) = return n fromJSON _ = fail "expecting a number" -instance InJSON Float where - toJSON = Number . F - fromJSON (Number (F n)) = return n +instance InJSON Double where + toJSON = Number . D + fromJSON (Number (D n)) = return n fromJSON _ = fail "expecting a number" instance InJSON Char where @@ -147,15 +134,20 @@ fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d) fromJSON _ = fail "expecting an array with 4 elements" -parseJSON :: String -> Maybe JSON +parseJSON :: Monad m => String -> m JSON parseJSON input = - case parse json (scanWith (makeCharsSpecial ":" defaultScanner) input) of - (result, []) -> Just result - _ -> Nothing + case parseWith jsonScanner json input of + Left err -> fail (show err) + Right a -> return a where + jsonScanner = specialSymbols ":" defaultScanner + { keywords = ["true", "false", "null"] + , unaryMinus = True + } + json :: TokenParser JSON json = (Number . I) <$> pInteger - <|> (Number . F) <$> pFraction + <|> (Number . D) <$> pReal <|> (String . fromMaybe [] . UTF8.decodeM) <$> pString <|> Boolean True <$ pKey "true" <|> Boolean False <$ pKey "false" @@ -210,7 +202,6 @@ [ ("result", responseResult resp) , ("error" , responseError resp) , ("id" , responseId resp) - , ("version", String $ version ++ " (" ++ show revision ++ ")") ] fromJSON obj = do rj <- lookupM "result" obj @@ -236,17 +227,76 @@ lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs) lookupM _ _ = fail "expecting a JSON object" +indent :: Int -> String -> String +indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines + -------------------------------------------------------- -- JSON-RPC over HTTP -type JSON_RPC_Handler = String -> JSON -> IO JSON +type JSON_RPC_Handler m = String -> JSON -> m JSON -jsonRPC :: String -> JSON_RPC_Handler -> IO String +jsonRPC :: (MonadError a m, InJSON a) + => JSON -> JSON_RPC_Handler m -> m JSON_RPC_Response jsonRPC input handler = - case parseJSON input >>= fromJSON of - Nothing -> fail "Invalid request" - Just req -> do - json <- handler (requestMethod req) (requestParams req) - return $ show $ okResponse json (requestId req) - `catch` \e -> - return $ show $ errorResponse (String (show e)) (requestId req) + case fromJSON input of + Nothing -> return (errorResponse (String "Invalid request") Null) + Just req -> do + json <- handler (requestMethod req) (requestParams req) + return (okResponse json (requestId req)) + `catchError` \msg -> + return (errorResponse (toJSON msg) (requestId req)) + +-------------------------------------------------------- +-- Testing parser/pretty-printer + +instance Arbitrary JSON where + arbitrary = sized arbJSON + +instance CoArbitrary JSON where + coarbitrary json = + case json of + Number a -> variant 0 . coarbitrary a + String s -> variant 1 . coarbitrary s + Boolean b -> variant 2 . coarbitrary b + Array xs -> variant 3 . coarbitrary xs + Object xs -> variant 4 . coarbitrary xs + Null -> variant 5 + +instance Arbitrary Number where + arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary] +instance CoArbitrary Number where + coarbitrary (I n) = variant 0 . coarbitrary n + coarbitrary (D d) = variant 1 . coarbitrary d + +arbJSON :: Int -> Gen JSON +arbJSON n + | n == 0 = oneof + [ liftM Number arbitrary, liftM String myStringGen + , liftM Boolean arbitrary, return Null + ] + | otherwise = oneof + [ arbJSON 0 + , do i <- choose (0, 6) + xs <- replicateM i rec + return (Array xs) + , do i <- choose (0, 6) + xs <- replicateM i myStringGen + ys <- replicateM i rec + return (Object (zip xs ys)) + ] + where + rec = arbJSON (n `div` 2) + +myStringGen :: Gen String +myStringGen = do + n <- choose (1, 10) + replicateM n $ oneof $ map return $ + ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] + +testMe :: IO () +testMe = do + putStrLn "** JSON encoding" + quickCheck prop + where + prop :: JSON -> Bool + prop a = parseJSON (show a) == Just a diff --git a/src/Text/OpenMath/ContentDictionary.hs b/src/Text/OpenMath/ContentDictionary.hs --- a/src/Text/OpenMath/ContentDictionary.hs +++ b/src/Text/OpenMath/ContentDictionary.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -18,6 +18,7 @@ ) where import Text.OpenMath.Object (OMOBJ, xml2omobj) +import Text.Scanning (scanInt, Pos(..)) import Text.XML import Data.Char import Data.List @@ -108,21 +109,22 @@ _ -> fail ("invalid date (YYYY-MM-DD): " ++ txt) extractInt :: String -> XML -> Either String Int -extractInt s xml = do +extractInt s xml = do txt <- extractText s xml - case reads txt of - [(n, xs)] | all isSpace xs -> - return n - _ -> fail ("invalid number" ++ txt) + case scanInt (Pos 0 0) txt of + Just (i, _, rest) | all isSpace rest + -> return i + _ -> fail "Not an int" extractStatus :: XML -> Either String ContentDictionaryStatus extractStatus xml = do txt <- extractText "CDStatus" xml let (hd, tl) = splitAt 1 txt - case reads (map toUpper hd ++ map toLower tl) of - [(st, xs)] | all isSpace xs -> - return st - _ -> fail ("invalid status: " ++ txt) + list = [Official, Experimental, Private, Obsolete] + table = [ (show s, s) | s <- list ] + case lookup (map toUpper hd ++ map toLower tl) table of + Just hd -> return hd + _ -> fail "Unknown status" extractText :: MonadPlus m => String -> XML -> m String extractText s xml = do @@ -145,7 +147,8 @@ type VersionNumber = (Int, Int) -- major and minor part type Date = (Int, Int, Int) -- YYYY-MM-DD -data ContentDictionaryStatus = Official | Experimental | Private | Obsolete deriving (Read,Show) +data ContentDictionaryStatus = Official | Experimental | Private | Obsolete + deriving Show data Definition = Definition { symbolName :: String @@ -154,4 +157,5 @@ , commentedProperties :: [String] , formalProperties :: [OMOBJ] , examples :: [[XML]] - } deriving Show + } + deriving Show diff --git a/src/Text/OpenMath/Dictionary/Quant1.hs b/src/Text/OpenMath/Dictionary/Quant1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Quant1.hs @@ -0,0 +1,23 @@ +-- Automatically generated from content dictionary quant1.ocd. Do not change. +module Text.OpenMath.Dictionary.Quant1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in quant1 dictionary +quant1List :: [Symbol] +quant1List = [forallSymbol, existsSymbol] + +{-| This symbol represents the universal ("for all") quantifier which takes +two arguments. It must be placed within an OMBIND element. The first argument +is the bound variables (placed within an OMBVAR element), and the second is an +expression. -} +forallSymbol :: Symbol +forallSymbol = makeSymbol "quant1" "forall" + +{-| This symbol represents the existential ("there exists") quantifier which +takes two arguments. It must be placed within an OMBIND element. The first +argument is the bound variables (placed within an OMBVAR element), and the +second is an expression. -} +existsSymbol :: Symbol +existsSymbol = makeSymbol "quant1" "exists" + diff --git a/src/Text/OpenMath/FMP.hs b/src/Text/OpenMath/FMP.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/FMP.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Formal mathematical properties (FMP) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.FMP where + +import Data.List (union) +import Text.OpenMath.Object +import Text.OpenMath.Symbol +import Text.OpenMath.Dictionary.Quant1 (forallSymbol, existsSymbol) +import Text.OpenMath.Dictionary.Relation1 (eqSymbol, neqSymbol) + +data FMP = FMP + { quantor :: Symbol + , metaVariables :: [String] + , leftHandSide :: OMOBJ + , relation :: Symbol + , rightHandSide :: OMOBJ + } + +toObject :: FMP -> OMOBJ +toObject fmp + | null (metaVariables fmp) = body + | otherwise = + OMBIND (OMS (quantor fmp)) (metaVariables fmp) body + where + body = OMA [OMS (relation fmp), leftHandSide fmp, rightHandSide fmp] + +eqFMP :: OMOBJ -> OMOBJ -> FMP +eqFMP lhs rhs = FMP + { quantor = forallSymbol + , metaVariables = getOMVs lhs `union` getOMVs rhs + , leftHandSide = lhs + , relation = eqSymbol + , rightHandSide = rhs + } + +-- | Represents a common misconception. In certain (most) situations, +-- the two objects are not the same. +buggyFMP :: OMOBJ -> OMOBJ -> FMP +buggyFMP lhs rhs = (eqFMP lhs rhs) + { quantor = existsSymbol + , relation = neqSymbol + } diff --git a/src/Text/OpenMath/MakeSymbols.hs b/src/Text/OpenMath/MakeSymbols.hs --- a/src/Text/OpenMath/MakeSymbols.hs +++ b/src/Text/OpenMath/MakeSymbols.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Text/OpenMath/Object.hs b/src/Text/OpenMath/Object.hs --- a/src/Text/OpenMath/Object.hs +++ b/src/Text/OpenMath/Object.hs @@ -1,5 +1,6 @@ +{-# OPTIONS -XDeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,27 +11,38 @@ -- ----------------------------------------------------------------------------- module Text.OpenMath.Object - ( OMOBJ(..), xml2omobj, omobj2xml + ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml ) where -import Text.XML import Data.Char (isSpace) +import Data.List (nub) import Data.Maybe +import Data.Typeable import Text.OpenMath.Symbol +import Text.Scanning (scanInt, scanNumber, Pos(..)) +import Text.XML -- internal representation for OpenMath objects data OMOBJ = OMI Integer - | OMF Float + | OMF Double | OMV String | OMS Symbol | OMA [OMOBJ] | OMBIND OMOBJ [String] OMOBJ - deriving (Show, Eq) + deriving (Show, Eq, Typeable) instance InXML OMOBJ where toXML = omobj2xml fromXML = either fail return . xml2omobj +getOMVs :: OMOBJ -> [String] +getOMVs = nub . rec + where + rec (OMA xs) = concatMap rec xs + rec (OMBIND q _ b) = rec q ++ rec b + rec (OMV s) = [s] + rec _ = [] + ---------------------------------------------------------- -- conversion functions: XML <-> OMOBJ @@ -53,15 +65,17 @@ return (OMS (Symbol mcd name)) [Left s] | name xml == "OMI" -> - case reads s of - [(i, xs)] | all isSpace xs -> return (OMI i) - _ -> fail "invalid integer in OMI" + case scanInt (Pos 0 0) s of + Just (i, _, rest) | all isSpace rest + -> return (OMI (toInteger i)) + _ -> fail "invalid integer in OMI" [] | name xml == "OMF" -> do s <- findAttribute "dec" xml - case reads s of - [(fp, xs)] | all isSpace xs -> return (OMF fp) - _ -> fail "invalid floating-point in OMF" + case scanNumber (Pos 0 0) s of + Just (nr, _, rest) | all isSpace rest + -> return (OMF (either fromIntegral id nr)) + _ -> fail "invalid floating-point in OMF" [] | name xml == "OMV" -> do s <- findAttribute "name" xml @@ -81,7 +95,7 @@ f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this in mapM (f . rec) (children xml) | otherwise = - fail ("expected tag OMVAR, but found " ++ show tag) + fail ("expected tag OMVAR, but found " ++ show (name xml)) omobj2xml :: OMOBJ -> XML omobj2xml object = makeXML "OMOBJ" $ do diff --git a/src/Text/OpenMath/Reply.hs b/src/Text/OpenMath/Reply.hs deleted file mode 100644 --- a/src/Text/OpenMath/Reply.hs +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Text.OpenMath.Reply - ( Reply(..), replyToXML, replyInXML - , ReplyOk(..), ReplyIncorrect(..), ReplyError(..), Args - ) where - -import Control.Monad -import Common.Exercise -import Common.Strategy hiding (not) -import Domain.Math.Expr -import Text.OpenMath.Object -import Text.XML -import Service.Revision - ------------------------------------------------------------------------- --- Data types for replies - --- There are three possible replies: ok, incorrect, or an error in the protocol (e.g., a parse error) -data Reply a = Ok (ReplyOk a) | Incorrect (ReplyIncorrect a) | Error ReplyError - -data ReplyOk a = ReplyOk - { repOk_Code :: Exercise a - , repOk_Location :: StrategyLocation - , repOk_Context :: String - , repOk_Steps :: Int - } - -data ReplyIncorrect a = ReplyIncorrect - { repInc_Code :: Exercise a - , repInc_Location :: StrategyLocation - , repInc_Expected :: a - , repInc_Derivation :: [(String, a)] - , repInc_Arguments :: Args - , repInc_Steps :: Int - , repInc_Equivalent :: Bool - } - -data ReplyError = ReplyError - { repErr_Kind :: String - , repErr_Message :: String - } - -type Args = [(String, String)] - ------------------------------------------------------------------------- --- Conversion functions to XML - -replyInXML :: IsExpr a => Reply a -> String -replyInXML = showXML . replyToXML - -replyToXML :: IsExpr a => Reply a -> XML -replyToXML reply = - case reply of - Ok r -> replyOkToXML r - Incorrect r -> replyIncorrectToXML r - Error r -> replyErrorToXML r - -replyOkToXML :: ReplyOk a -> XML -replyOkToXML r = makeReply "ok" $ do - element "strategy" (text $ show $ exerciseCode $ repOk_Code r) - element "location" (text $ show $ repOk_Location r) - element "context" (text $ repOk_Context r) - element "steps" (text $ show $ repOk_Steps r) - -replyIncorrectToXML :: IsExpr a => ReplyIncorrect a -> XML -replyIncorrectToXML r = makeReply "incorrect" $ do - element "strategy" (text $ show $ exerciseCode $ repInc_Code r) - element "location" (text $ show $ repInc_Location r) - element "expected" (builder $ omobj2xml $ toOMOBJ $ toExpr $ repInc_Expected r) - element "steps" (text $ show $ repInc_Steps r) - element "equivalent" (text $ show $ repInc_Equivalent r) - - unless (null $ repInc_Arguments r) $ - let f (x, y) = element "elem" $ do - "descr" .=. x - text y - in element "arguments" $ mapM_ f (repInc_Arguments r) - - unless (null $ repInc_Derivation r) $ - let f (x,y) = element "elem" $ do - "ruleid" .=. x - builder (omobj2xml (toOMOBJ (toExpr y))) - in element "derivation" $ mapM_ f (repInc_Derivation r) - -replyErrorToXML :: ReplyError -> XML -replyErrorToXML r = makeReply (repErr_Kind r) (text $ repErr_Message r) - -makeReply :: String -> XMLBuilder -> XML -makeReply kind body = makeXML "reply" $ do - "result" .=. kind - "version" .=. version - body diff --git a/src/Text/OpenMath/Request.hs b/src/Text/OpenMath/Request.hs deleted file mode 100644 --- a/src/Text/OpenMath/Request.hs +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Text.OpenMath.Request (xmlToRequest) where - -import Service.TypedAbstractService -import Text.XML -import Control.Monad -import Common.Context -import Common.Exercise -import Common.Strategy hiding (fail) -import Common.Utils (splitAtElem) -import Text.OpenMath.Object -import Data.Char -import Data.Maybe -import Domain.Math.Expr - -extractString :: String -> XML -> Either String String -extractString s = liftM getData . findChild s - -xmlToRequest :: IsExpr a => XML -> Exercise a -> Either String (State a, StrategyLocation, Maybe a) -xmlToRequest xml ex = do - unless (name xml == "request") $ - fail "XML document is not a request" - loc <- optional (extractLocation "location" xml) - term <- extractExpr "term" xml - context <- optional (extractString "context" xml) - answer <- optional (extractExpr "answer" xml) - t <- fromExpr $ fromOMOBJ term - mt <- case answer of - Nothing -> return Nothing - Just o -> return $ fromExpr $ fromOMOBJ o - return - ( State - { exercise = ex - , prefix = case context of - Just s -> Just $ getPrefix2 s (strategy ex) - Nothing -> Just $ emptyPrefix (strategy ex) - , context = case context of - Just s -> putInContext2 s t - Nothing -> inContext t - } - , fromMaybe [] loc - , mt - ) - ------------------------------------------------------------ -putInContext2 :: String -> a -> Context a -putInContext2 s = fromMaybe inContext $ do - (_, s2) <- splitAtElem ';' s - c <- parseContext s2 - return (flip fmap c . const) - -getPrefix2 :: String -> LabeledStrategy (Context a) -> Prefix (Context a) -getPrefix2 s ls = fromMaybe (emptyPrefix ls) $ do - (s1, _) <- splitAtElem ';' s - case reads s1 of - [(is, xs)] | all isSpace xs -> return (makePrefix is ls) - _ -> Nothing - -optional :: Either String a -> Either String (Maybe a) -optional = Right . either (const Nothing) Just - -extractLocation :: String -> XML -> Either String StrategyLocation -extractLocation s xml = do - c <- findChild s xml - case reads (getData c) of - [(n, xs)] | all isSpace xs -> return n - _ -> fail "invalid location" - -extractExpr :: String -> XML -> Either String OMOBJ -extractExpr n xml = - case findChild n xml of - Just expr -> - case children expr of - [this] -> xml2omobj this - _ -> fail $ "error in " ++ show (n, xml) - _ -> fail $ "error in " ++ show (n, xml) diff --git a/src/Text/OpenMath/Symbol.hs b/src/Text/OpenMath/Symbol.hs --- a/src/Text/OpenMath/Symbol.hs +++ b/src/Text/OpenMath/Symbol.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -19,7 +19,13 @@ instance Show Symbol where show s = maybe "" (++".") (dictionary s) ++ symbolName s - + +instance Read Symbol where + readsPrec _ s = + case break (=='.') s of + (xs,_:ys) -> [(makeSymbol xs ys, "")] + _ -> [(extraSymbol s, "")] + makeSymbol :: String -> String -> Symbol makeSymbol = Symbol . Just diff --git a/src/Text/Parsing.hs b/src/Text/Parsing.hs --- a/src/Text/Parsing.hs +++ b/src/Text/Parsing.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,121 +9,32 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- A simplified interface to the UU.Parsing and UU.Scanner libraries. This module --- provides some additional functionality to determine valid sub-expressions. +-- A simplified interface to the UU.Parsing library. -- ----------------------------------------------------------------------------- module Text.Parsing ( -- * Scaning - Scanner(..), defaultScanner, makeCharsSpecial, newlinesAsSpecial, minusAsSpecial, scan, scanWith, UU.Token + module Text.Scanning -- * Parsing - , Parser, CharParser, TokenParser, parse, Message + , Parser, CharParser, TokenParser + , parse, parseWith, parseWithM + -- * Primitive token parsers + , pVarid, pConid, pOpid, pQVarid, pQConid + , pKey, pSpec, pInt, pReal, pString + -- * Derived token parsers + , pParens, pBracks, pCurly, pCommas, pLines, pInteger -- * UU parser combinators , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1 , pChainl, pChainr, pChoice, pFail - -- * Subexpressions - , Ranged, Range(..), Pos(..), toRanged, fromRanged, subExpressionAt - , pKey, pSpec, pVarid, pConid, unaryOp, binaryOp, pParens, indicesToRange - , pInteger, pFraction, pString, pBracks, pCurly, pCommas, pLines -- * Operator table (parser) , OperatorTable, Associativity(..), pOperators - -- * Analyzing parentheses - , SyntaxError(..), fromMessage, errorToPositions - , checkParentheses, showTokenPos, tokenNoPosition - , toPosition, tokenText ) where -import qualified UU.Parsing as UU -import qualified UU.Scanner as UU -import qualified UU.Scanner.GenToken as UU -import Control.Arrow -import Common.Utils -import Data.Char -import Data.List import Data.Maybe +import Text.Scanning +import qualified UU.Parsing as UU ---------------------------------------------------------- --- Scaning - --- | Data type to configure a scanner -data Scanner = Scanner - { fileName :: Maybe String - , keywords :: [String] - , keywordOperators :: [String] - , specialCharacters :: String - , operatorCharacters :: String - } - --- | A default scanner configuration (using Haskell's special characters) -defaultScanner :: Scanner -defaultScanner = Scanner - { fileName = Nothing - , keywords = [] - , keywordOperators = [] - , specialCharacters = "(),;[]`{}" -- Haskell's special characters - , operatorCharacters = "!#$%&*+./<=>?@\\^|-~" -- The non-special characters - } - --- | Add characters to the list of special characters (and remove these from the list of operator characters) -makeCharsSpecial :: String -> Scanner -> Scanner -makeCharsSpecial cs scanner = scanner - { specialCharacters = specialCharacters scanner `union` cs - , operatorCharacters = operatorCharacters scanner \\ cs - } - --- Newline characters are mapped to "special" tokens --- The current solution to deal with newlines is a hack: all characters '\n' in the input --- are first mapped to '\001', and later the tokens are adapted -newlinesAsSpecial :: Scanner -> Scanner -newlinesAsSpecial = makeCharsSpecial [specialNewlinesChar] - -specialNewlinesChar :: Char -specialNewlinesChar = chr 1 - --- Minus characters are mapped to "special" tokens --- The current solution to deal with minus is a hack: all characters '-' in the input --- are first mapped to '\002', and later the tokens are adapted --- (since the scanner considers -- to be comment) -minusAsSpecial :: Scanner -> Scanner -minusAsSpecial = makeCharsSpecial [specialMinusChar] - -specialMinusChar :: Char -specialMinusChar = chr 2 - --- | Scan an input string with the default scanner configuration -scan :: String -> [UU.Token] -scan = scanWith defaultScanner - --- | Scan an input string with the given scanner configuration -scanWith :: Scanner -> String -> [UU.Token] -scanWith scanner = post . uuScan . pre - where - -- very special characters - special = or [specialNewlines, specialMinus] - specialNewlines = specialNewlinesChar `elem` specialCharacters scanner - specialMinus = specialMinusChar `elem` specialCharacters scanner - - pre = if special then map changeChar else id - post = if special then map changeToken else id - pos = UU.initPos $ fromMaybe "" (fileName scanner) - uuScan = UU.scan (keywords scanner) (keywordOperators scanner) - (specialCharacters scanner) (operatorCharacters scanner) pos - - changeChar :: Char -> Char - changeChar c - | c == '\n' && specialNewlines = specialNewlinesChar - | c == '-' && specialMinus = specialMinusChar - | otherwise = c - - changeToken :: UU.Token -> UU.Token - changeToken t = - case t of - UU.Reserved [c] pos - | c == specialNewlinesChar && specialNewlines -> UU.Reserved "\n" pos - | c == specialMinusChar && specialMinus -> UU.Reserved "-" pos - _ -> t - ----------------------------------------------------------- -- Parsing -- | Abstract data type for a parser, where @s@ is the symbol type, and @a@ is @@ -135,8 +46,10 @@ type CharParser = Parser Char -- | A parser with tokens as symbol type -type TokenParser = Parser UU.Token +type TokenParser = Parser Token +instance UU.Symbol Token + instance (UU.Symbol s, Ord s) => UU.IsParser (Parser s) s where ~(P p) <*> ~(P q) = P (p UU.<*> q) ~(P p) <* ~(P q) = P (p UU.<* q) @@ -156,19 +69,97 @@ getzerop = fmap P . UU.getzerop . unP getonep = fmap P . UU.getonep . unP -type Message s = (UU.Expecting s, Maybe s) - --- Parsing an input string always returns a result and a list of error messages -parse :: UU.Symbol s => Parser s a -> [s] -> (a, [Message s]) -parse (P p) input = (result, map f messages) +parse :: UU.Symbol s => Parser s a -> [s] -> Either (Maybe s) a +parse (P p) input = + case messages of + [] -> Right result + UU.Msg _ ms _:_ -> Left ms where steps = UU.parse p input - result = fstPair (UU.evalSteps steps) messages = UU.getMsgs steps - fstPair (UU.Pair a _) = a - f (UU.Msg a b _) = (a, b) + result = (\(UU.Pair a _) -> a) (UU.evalSteps steps) + +parseWith :: Scanner -> TokenParser a -> String -> Either SyntaxError a +parseWith scanner p = either f Right . parse p . scanWith scanner + where + f (Just s) = Left (Unexpected s) + f Nothing = Left (ErrorMessage "Syntax error") +parseWithM :: Monad m => Scanner -> TokenParser a -> String -> m a +parseWithM scanner p = either (fail . show) return . parseWith scanner p + ---------------------------------------------------------- +-- Primitive token parsers + +pVarid, pConid, pOpid :: TokenParser String +pQVarid, pQConid :: TokenParser (String, String) +pString :: TokenParser String +pInt :: TokenParser Int +pReal :: TokenParser Double + +pKey :: String -> TokenParser String +pSpec :: Char -> TokenParser Char + +pVarid = makeTokS isTokenVarId TokenVarId +pConid = makeTokS isTokenConId TokenConId +pOpid = makeTokS isTokenOpId TokenOpId +pQVarid = makeTokT isTokenQVarId TokenQVarId +pQConid = makeTokT isTokenQConId TokenQConId +pString = makeTokS isTokenString TokenString +pInt = makeTokN isTokenInt TokenInt +pReal = makeTokN isTokenReal TokenReal +pKey = makeTokA TokenKeyword +pSpec = makeTokA TokenSpecial + +-- helpers +makeTokS f con = makeTok f "" (con minString) (con maxString) +makeTokT f con = makeTok f ("","") (con minString minString) (con maxString maxString) +makeTokN f con = makeTok f 0 (con minBound) (con maxBound) +makeTokA con a = makeTok (const Nothing) a (con a) (con a) + +makeTok f a con1 con2 = + (fromMaybe a . f) UU.<$> con1 minPos UU.<..> con2 maxPos + +minPos, maxPos :: Pos +minPos = Pos minBound minBound +maxPos = Pos maxBound maxBound + +minString, maxString :: String +minString = [] +maxString = replicate 100 maxBound + +minDouble, maxDouble :: Double +minDouble = -(10^500) -- -Infinity +maxDouble = 10^500 -- Infinity + +instance Bounded Double where + minBound = minDouble + maxBound = maxDouble + +---------------------------------------------------------- +-- Derived token parsers + +pParens, pBracks, pCurly :: TokenParser a -> TokenParser a +pParens p = pSpec '(' UU.*> p UU.<* pSpec ')' +pBracks p = pSpec '[' UU.*> p UU.<* pSpec ']' +pCurly p = pSpec '{' UU.*> p UU.<* pSpec '}' + +pCommas :: TokenParser a -> TokenParser [a] +pCommas p = optional ((:) <$> p <*> pList ((\_ a -> a) <$> pSpec ',' <*> p)) [] + +-- | Parse lines, separated by the newline character. The boolean argument indicates whether empy lines should +-- be accepted or not. Make sure to configure the scanner to treat newlines as special characters! +pLines :: Bool -> TokenParser a -> TokenParser [a] +pLines allowEmptyLine p = catMaybes <$> pn + where + pOne | allowEmptyLine = optional (Just <$> p) Nothing + | otherwise = Just <$> p + pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne) + +pInteger :: TokenParser Integer +pInteger = fromIntegral <$> pInt + +---------------------------------------------------------- -- UU parser combinators infixl 3 <|> @@ -210,131 +201,6 @@ pFail = UU.pFail ---------------------------------------------------------- --- Subexpressions - --- | Abstract data type for expressions that ''know'' about the ranges of their --- subexpressions -data Ranged a = Ranged - { fromRanged :: a -- ^ Forget about the subexpressions - , getRange :: Range - , special :: Bool - , children :: [Ranged a] - } - -instance Show a => Show (Ranged a) where - show = show . fromRanged - --- | Data type for ranges -data Range = Range - { beginPos :: Pos - , endPos :: Pos - } - deriving (Show, Eq, Ord) - --- | Data type for positions -data Pos = Pos - { line :: Int - , column :: Int - } - deriving (Show, Eq, Ord) - --- | A value without subexpressions -toRanged :: a -> Range -> Ranged a -toRanged a r = Ranged a r False [] - --- | Given a selection (range) and a ranged term, return the location of the selected --- subexpression (or Nothing to indicate that the selection is invalid) -subExpressionAt :: Range -> Ranged a -> Maybe [Int] -subExpressionAt r ra - | r == getRange ra = return [] - | otherwise = - let f i | special ra = id - | otherwise = (i:) - in safeHead $ catMaybes - [ fmap (f i) (subExpressionAt r c) | (i, c) <- zip [0..] (children ra) ] - -pKey :: String -> TokenParser Range -pKey s = toRange 1 <$> UU.pKeyPos s - -pSpec :: Char -> TokenParser Range -pSpec c = toRange 1 <$> UU.pSpecPos c - -pVarid, pConid :: TokenParser (String, Range) -pVarid = second (toRange 1) <$> UU.pVaridPos -pConid = second (toRange 1) <$> UU.pConidPos - -unaryOp :: (a -> a) -> Range -> Ranged a -> Ranged a -unaryOp f r1 r2 = Ranged (f $ fromRanged r2) (r1 & getRange r2) False [r2] - -binaryOp :: (a -> a -> a) -> Ranged a -> Ranged a -> Ranged a -binaryOp f r1 r2 = Ranged (f (fromRanged r1) (fromRanged r2)) (getRange r1 & getRange r2) False [r1, r2] - -pParens :: TokenParser (Ranged a) -> TokenParser (Ranged a) -pParens p = (\p1 r p2 -> Ranged (fromRanged r) (toRange 1 p1 & toRange 1 p2) True [r]) <$> UU.pOParenPos <*> p <*> UU.pCParenPos - --- TODO: fix inconsistency with pParens -pBracks :: TokenParser a -> TokenParser a -pBracks = UU.pBracks - --- | Parse lines, separated by the newline character. The boolean argument indicates whether empy lines should --- be accepted or not. Make sure to configure the scanner to treat newlines as special characters! -pLines :: Bool -> TokenParser a -> TokenParser [a] -pLines allowEmptyLine p = catMaybes <$> pn - where - pOne | allowEmptyLine = optional (Just <$> p) Nothing - | otherwise = Just <$> p - pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne) - --- TODO: fix inconsistency with pParens -pCurly :: TokenParser a -> TokenParser a -pCurly = UU.pCurly - -pInteger :: TokenParser Integer -pInteger = (maybe 0 fromIntegral . readInt) <$> UU.pInteger - -pFraction :: TokenParser Float -pFraction = read <$> UU.pFraction - -pString :: TokenParser String -pString = UU.pString - -pCommas :: TokenParser a -> TokenParser [a] -pCommas = UU.pCommas - --- | Helper function to translate two indices on a string to a range: the positions of a range are line-based -indicesToRange :: String -> Int -> Int -> Range -indicesToRange s i j = Range (indexToPos s a) (indexToPos s b) - where (a, b) = trimIndexPair s i j - --- local helper functions -(&) :: Range -> Range -> Range -Range p1 p2 & Range p3 p4 = Range (p1 `min` p3) (p2 `max` p4) - -toPos :: UU.Pos -> Pos -toPos p = Pos (UU.line p) (UU.column p) - -toRange :: Int -> UU.Pos -> Range -toRange n p = Range (toPos p) (toPos (UU.advc n p)) - -indexToPos :: String -> Int -> Pos -indexToPos = rec . zip [1..] . lines - where - rec [] _ = Pos 0 0 - rec ((lnr, x):rest) i - | i <= len = Pos lnr (i+1) - | otherwise = rec rest (i-len-1) - where - len = length x - -trimIndexPair :: String -> Int -> Int -> (Int, Int) -trimIndexPair s i j - | j < i = trimIndexPair s j i - | otherwise = (i + f sub, j - f (reverse sub)) - where - sub = take (j-i) (drop i s) - f = length . takeWhile isSpace - ----------------------------------------------------------- -- Operator table (parser) -- | Type for an operator table. Operators with a low priority should appear in the front of the list. @@ -345,7 +211,7 @@ data Associativity = LeftAssociative | RightAssociative | NonAssociative | NoMix -- | Construct a parser using an operator table -pOperators :: OperatorTable a -> TokenParser (Ranged a) -> TokenParser (Ranged a) +pOperators :: OperatorTable a -> TokenParser a -> TokenParser a pOperators table p = foldr op p table where op (a, ops) q = case a of @@ -355,7 +221,7 @@ NoMix -> let make op = flip <$> f op <*> pChainr (f op) q in flip ($) <$> q <*> optional (pChoice $ map make ops) id _ -> pChain a (pChoice $ map f ops) q - f (s, g) = binaryOp g <$ pKey s + f (s, g) = g <$ pKey s -- local helper function @@ -364,85 +230,4 @@ LeftAssociative -> pChainl p q RightAssociative -> pChainr p q NonAssociative -> flip ($) <$> q <*> p <*> q - NoMix -> pChainr p q - ------------------------------------------------------------ ---- Syntax errors - -data SyntaxError - = Unexpected UU.Token - | ParNotClosed UU.Token - | ParNoOpen UU.Token - | ParMismatch UU.Token UU.Token - | ErrorMessage String - -instance Show SyntaxError where - show err = - case err of - Unexpected t -> "Unexpected " ++ show (tokenNoPosition t) - ParNotClosed t -> "Opening parenthesis " ++ show (tokenNoPosition t) ++ " is not closed" - ParNoOpen t -> "Closing parenthesis " ++ show (tokenNoPosition t) ++ " has no matching symbol" - ParMismatch t1 t2 -> "Opening parenthesis " ++ show (tokenNoPosition t1) ++ " is closed with " ++ show (tokenNoPosition t2) - ErrorMessage msg -> msg - -fromMessage :: Message UU.Token -> SyntaxError -fromMessage (_, Just t) = Unexpected t -fromMessage _ = ErrorMessage "Syntax error" - -errorToPositions :: SyntaxError -> [(Int, Int)] -errorToPositions err = - case err of - Unexpected t -> [toPosition t] - ParNotClosed t -> [toPosition t] - ParNoOpen t -> [toPosition t] - ParMismatch t1 t2 -> [toPosition t1, toPosition t2] - ErrorMessage _ -> [] - ------------------------------------------------------------ ---- Analyzing parentheses - -tokenText :: UU.Token -> String -tokenText (UU.Reserved s _) = "symbol " ++ s -tokenText (UU.ValToken s v _) = show s ++ " " ++ v - -showTokenPos :: UU.Token -> String -showTokenPos (UU.Reserved _ p) = showPosition p -showTokenPos (UU.ValToken _ _ p) = showPosition p - -toPosition :: UU.Token -> (Int, Int) -toPosition (UU.Reserved _ p) = (UU.line p, UU.column p) -toPosition (UU.ValToken _ _ p) = (UU.line p, UU.column p) - -showPosition :: UU.Position a => a -> String -showPosition p = show (UU.line p, UU.column p) - -tokenNoPosition :: UU.Token -> UU.Token -tokenNoPosition (UU.Reserved a _) = UU.Reserved a UU.noPos -tokenNoPosition (UU.ValToken a b _) = UU.ValToken a b UU.noPos - -checkParentheses :: [UU.Token] -> Maybe SyntaxError -checkParentheses = rec [] - where - rec [] [] = Nothing - rec (t:_) [] = Just (ParNotClosed t) - rec stack (t:ts) - | isOpening t = - rec (t:stack) ts - | isClosing t = - case stack of - [] -> Just (ParNoOpen t) - x:xs - | match x t -> rec xs ts - | otherwise -> Just (ParMismatch x t) - | otherwise = - rec stack ts - -isOpening, isClosing :: UU.Token -> Bool -isOpening (UU.Reserved ("(") _) = True -isOpening _ = False -isClosing (UU.Reserved (")") _) = True -isClosing _ = False - -match :: UU.Token -> UU.Token -> Bool -match (UU.Reserved ("(") _) (UU.Reserved (")") _) = True -match _ _ = False + NoMix -> pChainr p q diff --git a/src/Text/Scanning.hs b/src/Text/Scanning.hs new file mode 100644 --- /dev/null +++ b/src/Text/Scanning.hs @@ -0,0 +1,363 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A simple scanner with some configuration facilities +-- +----------------------------------------------------------------------------- +module Text.Scanning + ( -- Data types + Pos(..), Token(..) + -- Token selectors + , isTokenConId, isTokenVarId, isTokenOpId, isTokenQConId + , isTokenQVarId, isTokenKeyword, isTokenSpecial + , isTokenString, isTokenInt, isTokenReal, tokenPosition + -- Scanner configuration + , Scanner(..), defaultScanner, specialSymbols + -- Scanning + , scan, scanWith, scanInt, scanNumber + -- Lexical analysis + , SyntaxError(..), checkParentheses, errorPositions + ) where + +import Control.Monad +import Data.List +import Data.Char + +---------------------------------------------------------- +-- * Data types + +data Pos = Pos { line :: !Int, column :: !Int } + deriving (Eq, Ord) + +-- position field in last position, needed for ranged parsing +data Token + = TokenConId String Pos + | TokenVarId String Pos + | TokenOpId String Pos + | TokenQConId String String Pos + | TokenQVarId String String Pos + | TokenKeyword String Pos + | TokenSpecial Char Pos + | TokenString String Pos + | TokenInt Int Pos + | TokenReal Double Pos + deriving (Eq, Ord) + +instance Show Pos where + show (Pos l c) = "(" ++ show l ++ "," ++ show c ++ ")" + +instance Show Token where + show token = + case token of + TokenConId s _ -> "identifier " ++ s + TokenVarId s _ -> "identifier " ++ s + TokenOpId s _ -> "operator " ++ s + TokenQConId q s _ -> "identifier " ++ q ++ "." ++ s + TokenQVarId q s _ -> "identifier " ++ q ++ "." ++ s + TokenKeyword s _ -> "keyword " ++ s + TokenSpecial c _ -> "symbol " ++ [c] + TokenString s _ -> "string " ++ show s + TokenInt i _ -> "integer " ++ show i + TokenReal d _ -> "floating-point number " ++ show d + +---------------------------------------------------------- +-- * Token selectors + +isTokenConId :: Token -> Maybe String +isTokenConId (TokenConId s _) = Just s +isTokenConId _ = Nothing + +isTokenVarId :: Token -> Maybe String +isTokenVarId (TokenVarId s _) = Just s +isTokenVarId _ = Nothing + +isTokenOpId :: Token -> Maybe String +isTokenOpId (TokenOpId s _) = Just s +isTokenOpId _ = Nothing + +isTokenQConId :: Token -> Maybe (String, String) +isTokenQConId (TokenQConId q s _) = Just (q, s) +isTokenQConId _ = Nothing + +isTokenQVarId :: Token -> Maybe (String, String) +isTokenQVarId (TokenQVarId q s _) = Just (q, s) +isTokenQVarId _ = Nothing + +isTokenKeyword :: Token -> Maybe String +isTokenKeyword (TokenKeyword s _) = Just s +isTokenKeyword _ = Nothing + +isTokenSpecial :: Token -> Maybe Char +isTokenSpecial (TokenSpecial c _) = Just c +isTokenSpecial _ = Nothing + +isTokenString :: Token -> Maybe String +isTokenString (TokenString s _) = Just s +isTokenString _ = Nothing + +isTokenInt :: Token -> Maybe Int +isTokenInt (TokenInt i _) = Just i +isTokenInt _ = Nothing + +isTokenReal :: Token -> Maybe Double +isTokenReal (TokenReal d _) = Just d +isTokenReal _ = Nothing + +tokenPosition :: Token -> Pos +tokenPosition token = + case token of + TokenConId _ p -> p + TokenVarId _ p -> p + TokenOpId _ p -> p + TokenQConId _ _ p -> p + TokenQVarId _ _ p -> p + TokenKeyword _ p -> p + TokenSpecial _ p -> p + TokenString _ p -> p + TokenInt _ p -> p + TokenReal _ p -> p + +---------------------------------------------------------- +-- * Scanner configuration + +-- | Data type to configure a scanner +data Scanner = Scanner + { keywords :: [String] + , keywordOperators :: [String] + , isIdentifierCharacter :: Char -> Bool + , specialCharacters :: String + , operatorCharacters :: String + , unaryMinus :: Bool + , qualifiedIdentifiers :: Bool + } + +-- | A default scanner configuration (using Haskell's special characters) +defaultScanner :: Scanner +defaultScanner = Scanner + { keywords = [] + , keywordOperators = [] + , isIdentifierCharacter = \c -> isAlphaNum c || c `elem` "_'" + , specialCharacters = "(),;[]`{}" -- Haskell's special characters + , operatorCharacters = "!#$%&*+./<=>?@\\^|-~" -- The non-special characters + , unaryMinus = False + , qualifiedIdentifiers = False + } + +-- | Add characters to the list of special characters (and remove these from the list of operator characters) +specialSymbols :: String -> Scanner -> Scanner +specialSymbols cs scanner = scanner + { specialCharacters = specialCharacters scanner `union` cs } + +---------------------------------------------------------- +-- * Scanning + +-- | Scan an input string with the default scanner configuration +scan :: String -> [Token] +scan = scanWith defaultScanner + +scanWith :: Scanner -> String -> [Token] +scanWith scanner = rec (Pos 1 1) + where + rec :: Pos -> String -> [Token] + rec _ [] = [] + rec pos input@(x:rest) + | isSpace x = + let newp = advance [x] pos + in if x `elem` specialCharacters scanner + then TokenSpecial x pos : rec newp rest + else rec newp rest + | isAlpha x = + case scanIdentifier scanner input of + Just (Just q, s, xs) + | isLower (head s) -> make TokenQVarId + | otherwise -> make TokenQConId + where + make f = f q s pos : rec newp xs + newp = incr (length q + length s + 1) pos + Just (Nothing, s, xs) + | s `elem` keywords scanner -> make TokenKeyword + | isLower (head s) -> make TokenVarId + | otherwise -> make TokenConId + where + make f = f s pos : rec newp xs + newp = incr (length s) pos + _ -> error "unexpected case in scanner" + | isNumber input = + case scanNumber pos input of + Just (Left i, newp, xs) -> TokenInt i pos : rec newp xs + Just (Right d, newp, xs) -> TokenReal d pos : rec newp xs + _ -> error "unexpected case in scanner" + | x == '"' = + case scanString pos rest of + Just (s, newp, xs) -> + TokenString s pos : rec newp xs + Nothing -> + TokenSpecial x pos : rec (incr 1 pos) rest + | x `elem` specialCharacters scanner = + let newp = incr 1 pos + in if [x] `elem` keywordOperators scanner + then TokenKeyword [x] pos : rec newp rest + else TokenSpecial x pos : rec newp rest + | x `elem` operatorCharacters scanner = + let (xs, ys) = break stop rest + newp = incr (length (x:xs)) pos + stop c = c `elem` specialCharacters scanner + || c `notElem` operatorCharacters scanner + in if (x:xs) `elem` keywordOperators scanner + then TokenKeyword (x:xs) pos : rec newp ys + else TokenOpId (x:xs) pos : rec newp ys + | otherwise = + let newp = incr 1 pos + in TokenSpecial x pos : rec newp rest + + isNumber :: String -> Bool + isNumber ('-':x:_) = isDigit x && unaryMinus scanner + isNumber (x:_) = isDigit x + isNumber _ = False + +scanIdentifier :: Scanner -> String -> Maybe (Maybe String, String, String) +scanIdentifier scanner (x:rest) | isAlpha x = + case break (not . isIdentifierCharacter scanner) rest of + (xs, '.':y:rest2) | qualifiedIdentifiers scanner && isAlpha y -> + let (ys, zs) = break (not . isIdentifierCharacter scanner) rest2 + in Just (Just (x:xs), y:ys, zs) + (xs, ys) -> + Just (Nothing, x:xs, ys) +scanIdentifier _ _ = Nothing + +scanNumber :: Pos -> String -> Maybe (Either Int Double, Pos, String) +scanNumber pos input = do + (i, p, xs) <- scanInt pos input + case fractionPart p xs of + Just (p1, ys) -> + case powerPart p1 ys of + Just (p2, zs) -> + let txt = take (column p2 - column pos) input + in return (Right (read txt), p2, zs) + Nothing -> + let txt = take (column p1 - column pos) input + in return (Right (read txt), p1, ys) + Nothing -> + case powerPart p xs of + Just (p1, ys) -> + let txt = take (column p1 - column pos) input + in return (Right (read txt), p1, ys) + Nothing -> + return (Left i, p, xs) + +fractionPart :: Pos -> String -> Maybe (Pos, String) +fractionPart pos ('.':rest) = do + (_, p, ys) <- scanNatural pos rest + return (incr 1 p, ys) +fractionPart _ _ = Nothing + +powerPart :: Pos -> String -> Maybe (Pos, String) +powerPart pos (s:rest) | s == 'e' || s == 'E' = do + (_, p, ys) <- scanInt pos rest + return (incr 1 p, ys) +powerPart _ _ = Nothing + +scanInt :: Pos -> String -> Maybe (Int, Pos, String) +scanInt pos ('-':xs) = + do (nat, p, rest) <- scanNatural pos xs + return (-nat, incr 1 p, rest) +scanInt pos xs = + scanNatural pos xs + +scanNatural :: Pos -> String -> Maybe (Int, Pos, String) +scanNatural pos input = do + let (xs, ys) = break (not . isDigit) input + guard (not (null xs)) + let nat = foldl' (\a b -> a*10+ord b-48) 0 xs + return (nat, incr (length xs) pos, ys) + +scanString :: Pos -> String -> Maybe (String, Pos, String) +scanString pos input = + case input of + [] -> Nothing + '\\':x:xs -> add x (scanString (incr 2 pos) xs) + '"':xs -> Just ("",incr 1 pos,xs) + x:xs -> add x (scanString (incr 1 pos) xs) + where + add c = fmap (\(s, np, t) -> (c:s, np, t)) + +advance :: String -> Pos -> Pos +advance [] = id +advance (x:xs) + | x == '\n' = advance xs . nextline + | otherwise = advance xs . incr 1 + +incr :: Int -> Pos -> Pos +incr i p = p { column = column p + i } + +nextline :: Pos -> Pos +nextline p = p { line = line p + 1, column = 1 } + +----------------------------------------------------------- +--- Lexical analysis + +data SyntaxError + = Unexpected Token + | ParNotClosed Token + | ParNoOpen Token + | ParMismatch Token Token + | ErrorMessage String + +instance Show SyntaxError where + show err = prefixPosition err ++ + case err of + Unexpected t -> "Unexpected " ++ show t + ParNotClosed t -> "Opening parenthesis " ++ show t ++ " is not closed" + ParNoOpen t -> "Closing parenthesis " ++ show t ++ " has no matching symbol" + ParMismatch t1 t2 -> "Opening parenthesis " ++ show t1 ++ " is closed with " ++ show t2 + ErrorMessage msg -> msg + +prefixPosition :: SyntaxError -> String +prefixPosition err + | null xs = "" + | otherwise = concat (intersperse "," xs) ++ ": " + where + xs = map show (errorPositions err) + +errorPositions :: SyntaxError -> [Pos] +errorPositions err = + case err of + Unexpected t -> [tokenPosition t] + ParNotClosed t -> [tokenPosition t] + ParNoOpen t -> [tokenPosition t] + ParMismatch t1 t2 -> [tokenPosition t1, tokenPosition t2] + ErrorMessage _ -> [] + +checkParentheses :: [Token] -> Maybe SyntaxError +checkParentheses = rec [] + where + rec [] [] = Nothing + rec (t:_) [] = Just (ParNotClosed t) + rec stack (t:ts) + | isOpening t = + rec (t:stack) ts + | isClosing t = + case stack of + [] -> Just (ParNoOpen t) + x:xs + | match x t -> rec xs ts + | otherwise -> Just (ParMismatch x t) + | otherwise = + rec stack ts + +isOpening, isClosing :: Token -> Bool +isOpening (TokenSpecial ('(') _) = True +isOpening _ = False +isClosing (TokenSpecial (')') _) = True +isClosing _ = False + +match :: Token -> Token -> Bool +match (TokenSpecial ('(') _) (TokenSpecial (')') _) = True +match _ _ = False diff --git a/src/Text/UTF8.hs b/src/Text/UTF8.hs --- a/src/Text/UTF8.hs +++ b/src/Text/UTF8.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Text/XML.hs b/src/Text/XML.hs --- a/src/Text/XML.hs +++ b/src/Text/XML.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,18 +14,15 @@ ----------------------------------------------------------------------------- module Text.XML ( XML, Attr, AttrList, InXML(..), Element(..) - , XMLBuilder, makeXML, text, element, tag, attribute + , XMLBuilder, makeXML, text, unescaped, element, tag, attribute , parseXML, showXML, compactXML, (.=.), findAttribute - , children, Attribute(..), builder, findChild, getData {-, extract, extractText -} - , {- isText, isTag, mkTag mkText , findChild-} + , children, Attribute(..), builder, findChild, getData ) where -import Common.Utils (trim) -import Control.Monad.State import Control.Monad.Error () -import Data.Char -import Data.List +import Control.Monad.State import Data.Monoid +import Text.XML.Document (trim) import Text.XML.Interface hiding (parseXML) import qualified Text.XML.Interface as I @@ -112,8 +109,13 @@ in Element s (bsAttributes bs []) (bsElements bs []) text :: String -> XMLBuilder -text = XMLBuilder . modify . appendElemBS . Left +text = unescaped . escape +-- Should be used with care: the argument String is not escaped, and +-- therefore may contain xml tags or xml entities +unescaped :: String -> XMLBuilder +unescaped = XMLBuilder . modify . appendElemBS . Left + element :: String -> XMLBuilder -> XMLBuilder element s = XMLBuilder . modify . appendElemBS . Right . makeXML s @@ -128,6 +130,14 @@ builder :: Element -> XMLBuilder builder = XMLBuilder . modify . appendElemBS . Right + +escape :: String -> String +escape = concatMap f + where + f '<' = "<" + f '>' = ">" + f '&' = "&" + f c = [c] ---------------------------------------------------------------- -- XML utility functions diff --git a/src/Text/XML/Document.hs b/src/Text/XML/Document.hs --- a/src/Text/XML/Document.hs +++ b/src/Text/XML/Document.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -243,6 +243,9 @@ parenthesize :: String -> String parenthesize s = "(" ++ s ++ ")" + +trim :: String -> String +trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse --------------------------------------------------- diff --git a/src/Text/XML/Interface.hs b/src/Text/XML/Interface.hs --- a/src/Text/XML/Interface.hs +++ b/src/Text/XML/Interface.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- module Text.XML.Interface where +import Control.Arrow import Text.XML.Document (Name) import Text.XML.Unicode (decoding) import Text.XML.Parser (document, extParsedEnt) @@ -65,14 +66,17 @@ refToContent (D.EntityRef s) = case lookup s entities of Just c -> c - Nothing -> [] -- error + Nothing -> undefined -- [] -- error entities :: [(String, Content)] entities = - [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] + [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] ++ + -- predefined entities + map (second (return . Left . return)) + [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')] merge :: Content -> Content - merge (Left s:Left t:rest) = Left (s++t) : merge rest + merge (Left s:Left t:rest) = merge (Left (s++t) : rest) merge (x:xs) = x:merge xs merge [] = [] diff --git a/src/Text/XML/ParseLib.hs b/src/Text/XML/ParseLib.hs --- a/src/Text/XML/ParseLib.hs +++ b/src/Text/XML/ParseLib.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Text/XML/Parser.hs b/src/Text/XML/Parser.hs --- a/src/Text/XML/Parser.hs +++ b/src/Text/XML/Parser.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- diff --git a/src/Text/XML/TestSuite.hs b/src/Text/XML/TestSuite.hs --- a/src/Text/XML/TestSuite.hs +++ b/src/Text/XML/TestSuite.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,7 @@ module Main (main) where import Text.XML.Interface -import Common.Utils (trim) +import Text.XML.Document (trim) import Control.Monad.Error import Data.List import Data.Maybe diff --git a/src/Text/XML/Unicode.hs b/src/Text/XML/Unicode.hs --- a/src/Text/XML/Unicode.hs +++ b/src/Text/XML/Unicode.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. -----------------------------------------------------------------------------