diff --git a/ideas.cabal b/ideas.cabal --- a/ideas.cabal +++ b/ideas.cabal @@ -1,7 +1,7 @@ name: ideas -version: 0.6 +version: 0.7 synopsis: Feedback services for intelligent tutoring systems -homepage: http://ideas.cs.uu.nl/ +homepage: http://ideas.cs.uu.nl/www/ description: ideas provides feedback services to intelligent tutoring systems such as @@ -18,47 +18,54 @@ extra-source-files: CREDITS.txt build-type: Simple cabal-version: >= 1.8.0.2 -tested-with: GHC == 6.12.1 +tested-with: GHC == 6.10.1, GHC == 6.12.1 -------------------------------------------------------------------------------- Executable ideas Main-is: Main.hs - ghc-options: -W -fwarn-tabs -fwarn-duplicate-exports + ghc-options: -Wall hs-source-dirs: src - other-modules: - Common.Apply + other-modules: + Common.Classes Common.Context Common.Derivation Common.Exercise + Common.Id + Common.Library Common.Navigator Common.Rewriting.AC + Common.Rewriting.Axioms + Common.Rewriting.Confluence Common.Rewriting.Difference - Common.Rewriting.MetaVar + Common.Rewriting.Group + Common.Rewriting.Operator Common.Rewriting.RewriteRule Common.Rewriting.Substitution Common.Rewriting.Term Common.Rewriting.Unification Common.Rewriting Common.Strategy.Abstract - Common.Strategy.BiasedChoice Common.Strategy.Combinators Common.Strategy.Configuration Common.Strategy.Core - Common.Strategy.Grammar Common.Strategy.Location + Common.Strategy.Parsing Common.Strategy.Prefix Common.Strategy + Common.StringRef + Common.TestSuite Common.Transformation - Common.Traversable Common.Uniplate Common.Utils Common.View Documentation.DefaultPage + Documentation.DerivationUnitTests Documentation.ExercisePage - Documentation.LatexRules Documentation.Make Documentation.OverviewPages + Documentation.RulePage + Documentation.RulePresenter Documentation.SelfCheck Documentation.ServicePage Documentation.TestsPage @@ -72,18 +79,20 @@ Domain.LinearAlgebra.MatrixRules Domain.LinearAlgebra.Parser Domain.LinearAlgebra.Strategies - Domain.LinearAlgebra.Symbols Domain.LinearAlgebra.Vector Domain.LinearAlgebra Domain.Logic.BuggyRules + Domain.Logic.Examples Domain.Logic.Exercises Domain.Logic.FeedbackText Domain.Logic.Formula Domain.Logic.GeneralizedRules Domain.Logic.Generator Domain.Logic.Parser + Domain.Logic.Proofs Domain.Logic.Rules Domain.Logic.Strategies + Domain.Logic.Views Domain.Logic Domain.Math.Approximation Domain.Math.Clipboard @@ -93,17 +102,20 @@ Domain.Math.Data.PrimeFactors Domain.Math.Data.Relation Domain.Math.Data.SquareRoot - Domain.Math.DerivativeExercise - Domain.Math.DerivativeRules + Domain.Math.Derivative.Exercises + Domain.Math.Derivative.Rules + Domain.Math.Derivative.Strategies + Domain.Math.Equation.BalanceRules Domain.Math.Equation.CoverUpExercise Domain.Math.Equation.CoverUpRules Domain.Math.Equation.Views Domain.Math.Examples.DWO1 Domain.Math.Examples.DWO2 Domain.Math.Examples.DWO3 + Domain.Math.Examples.DWO4 + Domain.Math.Examples.DWO5 Domain.Math.Expr.Data Domain.Math.Expr.Parser - Domain.Math.Expr.Symbolic Domain.Math.Expr.Symbols Domain.Math.Expr.Views Domain.Math.Expr @@ -120,23 +132,27 @@ Domain.Math.Polynomial.Exercises Domain.Math.Polynomial.Generators Domain.Math.Polynomial.IneqExercises + Domain.Math.Polynomial.LeastCommonMultiple + Domain.Math.Polynomial.RationalExercises + Domain.Math.Polynomial.RationalRules Domain.Math.Polynomial.Rules Domain.Math.Polynomial.Strategies Domain.Math.Polynomial.Tests Domain.Math.Polynomial.Views + Domain.Math.Power.Equation.Exercises + Domain.Math.Power.Equation.NormViews + Domain.Math.Power.Equation.Rules + Domain.Math.Power.Equation.Strategies Domain.Math.Power.Exercises + Domain.Math.Power.NormViews + Domain.Math.Power.OldViews Domain.Math.Power.Rules Domain.Math.Power.Strategies + Domain.Math.Power.Utils Domain.Math.Power.Views Domain.Math.Simplification Domain.Math.SquareRoot.Tests Domain.Math.SquareRoot.Views - Domain.RegularExpr.Definitions - Domain.RegularExpr.Exercises - Domain.RegularExpr.Expr - Domain.RegularExpr.Parser - Domain.RegularExpr.Strategy - Domain.RelationAlgebra.Equivalence Domain.RelationAlgebra.Exercises Domain.RelationAlgebra.Formula Domain.RelationAlgebra.Generator @@ -144,13 +160,15 @@ Domain.RelationAlgebra.Rules Domain.RelationAlgebra.Strategies Domain.RelationAlgebra - Main.ExerciseList + Main.IDEAS Main.LoggingDatabase Main.Options Main.Revision Main + Service.BasicServices Service.Diagnose Service.DomainReasoner + Service.Evaluator Service.ExercisePackage Service.FeedbackText Service.ModeJSON @@ -159,9 +177,9 @@ Service.Request Service.RulesInfo Service.ServiceList + Service.State Service.StrategyInfo Service.Submit - Service.TypedAbstractService Service.TypedExample Service.Types Text.HTML @@ -181,6 +199,7 @@ Text.OpenMath.MakeSymbols Text.OpenMath.Object Text.OpenMath.Symbol + Text.OpenMath.Tests Text.Parsing Text.Scanning Text.UTF8 @@ -202,7 +221,8 @@ uulib, filepath, parsec, - old-time + old-time, + uniplate -------------------------------------------------------------------------------- diff --git a/src/Common/Apply.hs b/src/Common/Apply.hs deleted file mode 100644 --- a/src/Common/Apply.hs +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines the type class Apply and some related utility functions. --- ------------------------------------------------------------------------------ -module Common.Apply where - -import Common.Utils (safeHead) -import Control.Monad (join) -import Data.Maybe (isJust, fromMaybe) - - --- | A type class for functors that can be applied to a value. Transformation, Rule, and --- Strategy are all instances of this type class. Minimal complete definition: only one of --- the two member functions should be defined. -class Apply t where - apply :: t a -> a -> Maybe a -- ^ Returns zero or one results - applyAll :: t a -> a -> [a] -- ^ Returns zero or more results - -- default definitions - apply ta = safeHead . applyAll ta - applyAll ta = maybe [] return . apply ta - --- | Checks whether the functor is applicable (at least one result) -applicable :: Apply t => t a -> a -> Bool -applicable ta = isJust . apply ta - --- | If not applicable, return the current value (as default) -applyD :: Apply t => t a -> a -> a -applyD ta a = fromMaybe a (apply ta a) - --- | Same as apply, except that the result (at most one) is returned in some monad -applyM :: (Apply t, Monad m) => t a -> a -> m a -applyM ta = maybe (fail "applyM") return . apply ta - --- | Apply a list of steps, and return at most one result -applyList :: Apply t => [t a] -> a -> Maybe a -applyList xs a = foldl (\ma t -> join $ fmap (apply t) ma) (Just a) xs - --- | Apply a list of steps, and return all results -applyListAll :: Apply t => [t a] -> a -> [a] -applyListAll xs a = foldl (\ma t -> concatMap (applyAll t) ma) [a] xs - --- | Apply a list of steps, and if there is no result, return the current value (as default) -applyListD :: Apply t => [t a] -> a -> a -applyListD xs a = foldl (\a t -> applyD t a) a xs - --- Apply a list of steps, and return the result (at most one) in some monad -applyListM :: (Apply t, Monad m) => [t a] -> a -> m a -applyListM xs a = foldl (\ma t -> ma >>= applyM t) (return a) xs diff --git a/src/Common/Classes.hs b/src/Common/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Common/Classes.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Type classes and instances. +-- +----------------------------------------------------------------------------- +module Common.Classes + ( Apply(..), applicable, applyD, applyM + , Switch(..), Crush(..), Zip(..) + ) where + +import Common.Utils (safeHead) +import Data.Maybe +import Control.Monad.Identity +import qualified Data.IntMap as IM +import qualified Data.Map as M + +----------------------------------------------------------- +-- * Type class |Apply| + +-- | A type class for functors that can be applied to a value. Transformation, Rule, and +-- Strategy are all instances of this type class. Minimal complete definition: only one of +-- the two member functions should be defined. +class Apply t where + apply :: t a -> a -> Maybe a -- ^ Returns zero or one results + applyAll :: t a -> a -> [a] -- ^ Returns zero or more results + -- default definitions + apply ta = safeHead . applyAll ta + applyAll ta = maybe [] return . apply ta + +-- | Checks whether the functor is applicable (at least one result) +applicable :: Apply t => t a -> a -> Bool +applicable ta = isJust . apply ta + +-- | If not applicable, return the current value (as default) +applyD :: Apply t => t a -> a -> a +applyD ta a = fromMaybe a (apply ta a) + +-- | Same as apply, except that the result (at most one) is returned in some monad +applyM :: (Apply t, Monad m) => t a -> a -> m a +applyM ta = maybe (fail "applyM") return . apply ta + +----------------------------------------------------------- +-- * Type class |Switch| + +class Functor f => Switch f where + switch :: Monad m => f (m a) -> m (f a) + +instance Switch [] where + switch = sequence + +instance Switch Maybe where + switch = maybe (return Nothing) (liftM Just) + +instance Switch Identity where + switch (Identity m) = liftM Identity m + +instance Eq a => Switch (M.Map a) where + switch m = do + let (ns, ms) = unzip (M.toList m) + as <- sequence ms + return $ M.fromAscList $ zip ns as + +instance Switch IM.IntMap where + switch m = do + let (ns, ms) = unzip (IM.toList m) + as <- sequence ms + return $ IM.fromAscList $ zip ns as + +----------------------------------------------------------- +-- * Type class |Crush| + +class Functor f => Crush f where + crush :: f a -> [a] + +instance Crush [] where + crush = id + +instance Crush Maybe where + crush = maybe [] return + +instance Crush Identity where + crush = return . runIdentity + +instance Crush (M.Map a) where + crush = M.elems + +instance Crush IM.IntMap where + crush = IM.elems + +----------------------------------------------------------- +-- * Type class |Zip| + +class Functor f => Zip f where + fzip :: f a -> f b -> f (a, b) + fzipWith :: (a -> b -> c) -> f a -> f b -> f c + -- default implementation + fzip = fzipWith (,) + fzipWith f a b = fmap (uncurry f) (fzip a b) + +instance Zip [] where + fzipWith = zipWith + +instance Zip Maybe where + fzipWith = liftM2 diff --git a/src/Common/Context.hs b/src/Common/Context.hs --- a/src/Common/Context.hs +++ b/src/Common/Context.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XDeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -22,17 +22,17 @@ -- * Variables , Var, newVar, makeVar -- * Lifting - , liftToContext, liftTransContext, contextView + , liftToContext, liftTransContext + , use, useC, termNavigator, applyTop -- * Context Monad - , ContextMonad, runCM, readVar, writeVar, modifyVar - , maybeCM, withCM, evalCM -- , listCM, runListCM, withListCM + , ContextMonad, readVar, writeVar, modifyVar + , maybeCM, withCM, evalCM ) where import Common.Navigator - -import qualified Common.Navigator as Navigator +import Common.Rewriting import Common.Transformation -import Common.Utils (safeHead, commaList, readM) +import Common.Utils (commaList, readM) import Common.View import Control.Monad import Data.Maybe @@ -65,7 +65,7 @@ up (C env a) = liftM (C env) (up a) allDowns (C env a) = map (C env) (allDowns a) current (C _ a) = current a - location (C _ a) = Navigator.location a + location (C _ a) = location a changeM f (C env a) = liftM (C env) (changeM f a) instance TypedNavigator Context where @@ -155,46 +155,65 @@ -- | Lift a rule to operate on a term in a context liftToContext :: Rule a -> Rule (Context a) -liftToContext = liftRuleIn thisView +liftToContext = liftRuleIn contextView liftTransContext :: Transformation a -> Transformation (Context a) -liftTransContext = liftTransIn thisView +liftTransContext = liftTransIn contextView -thisView :: View (Context a) (a, Context a) -thisView = makeView f g +-- | Apply a function at top-level. Afterwards, try to return the focus +-- to the old position +applyTop :: (a -> a) -> Context a -> Context a +applyTop f c = + case top c of + Just ok -> navigateTowards (location c) (change f ok) + Nothing -> c + +termNavigator :: IsTerm a => a -> Navigator a +termNavigator a = fromMaybe (noNavigator a) (make a) where - f ctx = current ctx >>= \a -> Just (a, ctx) - g = uncurry replace + make = castT termView . viewNavigatorWith spineHoles . toTerm -contextView :: MonadPlus m => ViewM m a b -> ViewM m (Context a) (Context b) -contextView v = makeView f g + spineHoles :: Term -> [(Term, Term -> Term)] + spineHoles term + | null xs = [] + | otherwise = (x, flip makeTerm xs) : zipWith f [0..] xs + where + (x, xs) = getSpine term + f i y = (y, makeTerm x . changeAt i) + changeAt i b = + case splitAt i xs of + (ys, _:zs) -> ys ++ b:zs + _ -> xs + +use :: (IsTerm a, IsTerm b) => Rule a -> Rule (Context b) +use = useC . liftToContext + +useC :: (IsTerm a, IsTerm b) => Rule (Context a) -> Rule (Context b) +useC = liftRule (makeView (castT termView) (fromJust . castT termView)) + +contextView :: View (Context a) (a, Context a) +contextView = newView "views.contextView" f g where - f ca = do - guard (isTop ca) - a <- leave ca - b <- match v a - return (newContext (getEnvironment ca) (noNavigator b)) - g cb = fromJust $ do - guard (isTop cb) - b <- leave cb - let a = build v b - return (newContext (getEnvironment cb) (noNavigator a)) + f ctx = current ctx >>= \a -> Just (a, ctx) + g = uncurry replace ---------------------------------------------------------- -- Context monad -newtype ContextMonad a = CM (Environment -> [(a, Environment)]) +newtype ContextMonad a = CM { unCM :: Environment -> Maybe (a, Environment) } -withCM :: (a -> ContextMonad b) -> Context a -> Maybe (Context b) -withCM f c = fromContext c >>= \a -> runCM (f a) (getEnvironment c) +withCM :: (a -> ContextMonad a) -> Context a -> Maybe (Context a) +withCM f c = do + a0 <- current c + (a, env) <- unCM (f a0) (getEnvironment c) + let nav = replace a (getNavigator c) + return (newContext env nav) evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b -evalCM f c = withCM f c >>= fromContext - -runCM :: ContextMonad a -> Environment -> Maybe (Context a) -runCM (CM f) env = do - (a, e) <- safeHead (f env) - return (newContext e (noNavigator a)) +evalCM f c = do + a0 <- current c + (b, _) <- unCM (f a0) (getEnvironment c) + return b instance Functor ContextMonad where fmap = liftM @@ -229,16 +248,3 @@ maybeCM :: Maybe a -> ContextMonad a maybeCM = maybe mzero return - - -{- -listCM :: [a] -> ContextMonad a -listCM = foldr (mplus . return) mzero - -withListCM :: (a -> ContextMonad b) -> Context a -> [Context b] -withListCM f c = runListCM (f (fromContext c)) (getEnvironment c) - -runListCM :: ContextMonad a -> Environment -> [Context a] -runListCM (CM f) env = do - (a, e) <- f env - return (C e a) -} diff --git a/src/Common/Derivation.hs b/src/Common/Derivation.hs --- a/src/Common/Derivation.hs +++ b/src/Common/Derivation.hs @@ -22,9 +22,11 @@ , results, lengthMax -- * Adapters , restrictHeight, restrictWidth, commit - , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps, changeLabel + , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps + , changeLabel, sortTree -- * Query a derivation , isEmpty, derivationLength, terms, steps, triples, filterDerivation + , mapStepsDerivation, derivationM -- * Conversions , derivation, randomDerivation, derivations ) where @@ -32,6 +34,7 @@ import Common.Utils (safeHead) import Control.Arrow import Control.Monad +import Data.List import Data.Maybe import System.Random @@ -143,8 +146,14 @@ changeLabel :: (l -> m) -> DerivationTree l a -> DerivationTree m a changeLabel f = rec where - rec t = t {branches = map (\(l, st) -> (f l, rec st)) (branches t)} + rec t = t {branches = map (f *** rec) (branches t)} +sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a +sortTree f t = t {branches = change (branches t) } + where + change = map (second (sortTree f)) . sortBy cmp + cmp (l1, _) (l2, _) = f l1 l2 + mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a mergeMaybeSteps = mapSteps fromJust . mergeSteps isJust @@ -166,6 +175,9 @@ isEmpty :: Derivation s a -> Bool isEmpty (D _ xs) = null xs +mapStepsDerivation :: (s -> t) -> Derivation s a -> Derivation t a +mapStepsDerivation f (D a xs) = D a (map (first f) xs) + -- | Returns the number of steps in a derivation derivationLength :: Derivation s a -> Int derivationLength (D _ xs) = length xs @@ -187,6 +199,10 @@ filterDerivation :: (s -> a -> Bool) -> Derivation s a -> Derivation s a filterDerivation p (D a xs) = D a (filter (uncurry p) xs) +-- | Apply a monadic function to each term, and to each step +derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m () +derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) xs + ----------------------------------------------------------------------------- -- Conversions from a derivation tree @@ -194,7 +210,7 @@ derivations :: DerivationTree s a -> Derivations s a derivations t = map (D (root t)) $ [ [] | endpoint t ] ++ - [ ((r,a2):ys) | (r, st) <- branches t, D a2 ys <- derivations st ] + [ (r,a2):ys | (r, st) <- branches t, D a2 ys <- derivations st ] -- | The first derivation (if any) derivation :: DerivationTree s a -> Maybe (Derivation s a) @@ -214,8 +230,8 @@ shuffle :: RandomGen g => g -> [a] -> ([a], g) shuffle g0 xs = rec g0 [] (length xs) xs where - rec g acc n xs = - case splitAt i xs of + rec g acc n ys = + case splitAt i ys of (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs) _ -> (acc, g) where diff --git a/src/Common/Exercise.hs b/src/Common/Exercise.hs --- a/src/Common/Exercise.hs +++ b/src/Common/Exercise.hs @@ -14,45 +14,48 @@ module Common.Exercise ( -- * Exercises Exercise, testableExercise, makeExercise, emptyExercise - , description, exerciseCode, status, parser, prettyPrinter + , exerciseId, status, parser, prettyPrinter , equivalence, similarity, isReady, isSuitable, eqWithContext - , strategy, navigation, canBeRestarted, extraRules + , strategy, navigation, canBeRestarted, extraRules, ruleOrdering , difference, ordering, testGenerator, randomExercise, examples, getRule , simpleGenerator, useGenerator , randomTerm, randomTermWith, ruleset - , makeContext, inContext + , makeContext, inContext, recognizeRule, ruleIsRecognized + , ruleOrderingWith, ruleOrderingWithId -- * Exercise status , Status(..), isPublic, isPrivate - -- * Exercise codes - , ExerciseCode, noCode, makeCode, readCode, domain, identifier -- * Miscellaneous + , prettyPrinterContext , equivalenceContext, restrictGenerator , showDerivation, printDerivation + , ExerciseDerivation, defaultDerivation, derivationDiffEnv , checkExercise, checkParserPretty - , checkExamples, generate + , checkExamples, exerciseTestSuite + , module Common.Id -- for backwards compatibility ) where -import Common.Apply +import Common.Classes import Common.Context import Common.Strategy hiding (not, fail, replicate) import qualified Common.Strategy as S import Common.Derivation +import Common.Id import Common.Navigator +import Common.TestSuite import Common.Transformation -import Common.Utils (putLabel) +import Common.Utils (ShowString(..)) import Common.View (makeView) import Control.Monad.Error -import Data.Char import Data.List import Data.Maybe +import Data.Ord import System.Random import Test.QuickCheck hiding (label) import Test.QuickCheck.Gen data Exercise a = Exercise { -- identification and meta-information - description :: String -- short sentence describing the task - , exerciseCode :: ExerciseCode -- uniquely determines the exercise (in a given domain) + exerciseId :: Id -- identifier that uniquely determines the exercise , status :: Status -- parsing and pretty-printing , parser :: String -> Either String a @@ -70,6 +73,7 @@ , navigation :: a -> Navigator a , canBeRestarted :: Bool -- By default, assumed to be the case , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy + , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst) -- testing and exercise generation , testGenerator :: Maybe (Gen a) , randomExercise :: Maybe (StdGen -> Int -> a) @@ -77,14 +81,18 @@ } instance Eq (Exercise a) where - e1 == e2 = exerciseCode e1 == exerciseCode e2 + e1 == e2 = getId e1 == getId e2 instance Ord (Exercise a) where - e1 `compare` e2 = exerciseCode e1 `compare` exerciseCode e2 + compare = comparing getId instance Apply Exercise where applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex +instance HasId (Exercise a) where + getId = exerciseId + changeId f ex = ex { exerciseId = f (exerciseId ex) } + testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a testableExercise = makeExercise { testGenerator = Just arbitrary @@ -100,8 +108,7 @@ emptyExercise :: Exercise a emptyExercise = Exercise { -- identification and meta-information - description = "<>" - , exerciseCode = noCode + exerciseId = error "no exercise code" , status = Experimental -- parsing and pretty-printing , parser = const (Left "<>") @@ -118,7 +125,8 @@ , strategy = label "Fail" S.fail , navigation = noNavigator , canBeRestarted = True - , extraRules = [] + , extraRules = [] + , ruleOrdering = compareId -- testing and exercise generation , testGenerator = Nothing , randomExercise = Nothing @@ -137,28 +145,22 @@ -- returns a sorted list of rules (no duplicates) ruleset :: Exercise a -> [Rule (Context a)] -ruleset ex = nub (sortBy cmp list) +ruleset ex = nub (sortBy compareId list) where list = rulesInStrategy (strategy ex) ++ extraRules ex - cmp a b = name a `compare` name b simpleGenerator :: Gen a -> Maybe (StdGen -> Int -> a) simpleGenerator = useGenerator (const True) . const useGenerator :: (a -> Bool) -> (Int -> Gen a) -> Maybe (StdGen -> Int -> a) -useGenerator p g = Just f +useGenerator p makeGen = Just (\rng -> rec rng . makeGen) where - f rng level + rec rng gen@(MkGen f) | p a = a - | otherwise = f (snd (next rng)) level + | otherwise = rec (snd (next rng)) gen where - a = generate 100 rng (g level) - where - -generate :: Int -> StdGen -> Gen a -> a -generate n rnd (MkGen m) = m rnd' size - where - (size, rnd') = randomR (0, n) rnd + (size, r) = randomR (0, 100) rng + a = f r size restrictGenerator :: (a -> Bool) -> Gen a -> Gen a restrictGenerator p g = do @@ -181,6 +183,29 @@ xs !! fst (randomR (0, length xs - 1) rng) where xs = examples ex +ruleIsRecognized :: Exercise a -> Rule (Context a) -> Context a -> Context a -> Bool +ruleIsRecognized ex r ca = not . null . recognizeRule ex r ca + +-- Recognize a rule at (possibly multiple) locations +recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [Location] +recognizeRule ex r ca cb = rec (fromMaybe ca (top ca)) + where + rec x = [ location x | here r x cb ] ++ concatMap rec (allDowns x) + here = ruleRecognizer $ \cx cy -> fromMaybe False $ + liftM2 (similarity ex) (fromContext cx) (fromContext cy) + +ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering +ruleOrderingWith = ruleOrderingWithId . map getId + +ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering +ruleOrderingWithId bs r1 r2 = + let xs = map getId bs in + case (findIndex (==getId r1) xs, findIndex (==getId r2) xs) of + (Just i, Just j ) -> i `compare` j + (Just _, Nothing) -> LT + (Nothing, Just _ ) -> GT + (Nothing, Nothing) -> compareId r1 r2 + --------------------------------------------------------------- -- Exercise status @@ -197,46 +222,7 @@ -- | An exercise that is not public isPrivate :: Exercise a -> Bool -isPrivate = not . isPublic - ---------------------------------------------------------------- --- Exercise codes (unique identification) - -data ExerciseCode = EC String String | NoCode - deriving (Eq, Ord) - -instance Show ExerciseCode where - show (EC xs ys) = xs ++ "." ++ ys - show NoCode = "no code" - -noCode :: ExerciseCode -noCode = NoCode - -makeCode :: String -> String -> ExerciseCode -makeCode a b - | null a || null b || any invalidCodeChar (a++b) = - error $ "Invalid exercise code: " ++ show (EC a b) - | otherwise = - EC (map toLower a) (map toLower b) - -readCode :: String -> Maybe ExerciseCode -readCode xs = - case break invalidCodeChar xs of - (as, '.':bs) | all validCodeChar bs -> - return $ makeCode as bs - _ -> Nothing - -validCodeChar, invalidCodeChar :: Char -> Bool -validCodeChar c = isAlphaNum c || c `elem` "-_" -invalidCodeChar = not . validCodeChar - -domain :: ExerciseCode -> String -domain (EC s _) = s -domain _ = [] - -identifier :: ExerciseCode -> String -identifier (EC _ s) = s -identifier _ = [] +isPrivate = not . isPublic --------------------------------------------------------------- -- Rest @@ -252,42 +238,47 @@ prettyPrinterContext ex = maybe "<>" (prettyPrinter ex) . fromContext -getRule :: Monad m => Exercise a -> String -> m (Rule (Context a)) -getRule ex s = - case filter ((==s) . name) (ruleset ex) of +getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a)) +getRule ex a = + case filter ((a ==) . getId) (ruleset ex) of [hd] -> return hd - [] -> fail $ "Could not find ruleid " ++ s - _ -> fail $ "Ambiguous ruleid " ++ s + [] -> fail $ "Could not find ruleid " ++ showId a + _ -> fail $ "Ambiguous ruleid " ++ showId a +-- |Shows a derivation for a given start term. The specified rule ordering +-- is used for selection. showDerivation :: Exercise a -> a -> String -showDerivation ex a = - case derivation tree of - Just d -> show (f d) ++ extra d - Nothing -> prettyPrinterContext ex (root tree) - ++ "\n =>\n<>" +showDerivation ex a = show (present der) ++ extra where - tree = derivationTree (strategy ex) (inContext ex a) - extra d = - case fromContext (last (terms d)) of + der = derivationDiffEnv (defaultDerivation ex a) + extra = + case fromContext (last (terms der)) of Nothing -> "<>" - Just a | isReady ex a -> "" + Just b | isReady ex b -> "" | 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) + present = mapStepsDerivation (ShowString . uncurry f) + . fmap (ShowString . prettyPrinterContext ex) + f b env | nullEnv env = showId b + | otherwise = showId b ++ "\n " ++ show env --- local helper datatype -data Shown = Shown String +type ExerciseDerivation a = Derivation (Rule (Context a)) (Context a) -instance Show Shown where - show (Shown s) = s +defaultDerivation :: Exercise a -> a -> ExerciseDerivation a +defaultDerivation ex a = + let ca = inContext ex a + tree = sortTree (ruleOrdering ex) (derivationTree (strategy ex) ca) + single = newDerivation ca [] + in fromMaybe single (derivation tree) +derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a) +derivationDiffEnv d = + -- A bit of hack to show the delta between two environments, not including + -- the location variable + let t:ts = terms d + xs = zipWith3 f (steps d) (drop 1 (terms d)) (terms d) + f b x y = (b, deleteEnv "location" (diffEnv (getEnvironment x) (getEnvironment y))) -- ShowString (show a ++ extra) + in newDerivation t (zip xs ts) + printDerivation :: Exercise a -> a -> IO () printDerivation ex = putStrLn . showDerivation ex @@ -337,26 +328,28 @@ ++ " => " ++ prettyPrinterContext ex y -} checkExercise :: Exercise a -> IO () -checkExercise ex = do - putStrLn ("** " ++ show (exerciseCode ex)) +checkExercise = runTestSuite . exerciseTestSuite + +exerciseTestSuite :: Exercise a -> TestSuite +exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do checkExamples ex case testGenerator ex of Nothing -> return () Just gen -> do let showAsGen = showAs (prettyPrinter ex) gen - check txt p = putLabel txt >> quickCheck p - check "parser/pretty printer" $ forAll showAsGen $ + addProperty "parser/pretty printer" $ forAll showAsGen $ checkParserPrettyEx ex . from - putStrLn "Soundness non-buggy rules" - forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> do - putLabel (" " ++ name r) - let eq a b = equivalenceContext ex (from a) (from b) - myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) - myView = makeView (return . from) (S (prettyPrinterContext ex)) - testRuleSmart eq (liftRule myView r) myGen - - check "soundness strategy/generator" $ + suite "Soundness non-buggy rules" $ + forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> + let eq a b = equivalenceContext ex (from a) (from b) + myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) + myView = makeView (return . from) (S (prettyPrinterContext ex)) + args = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100} + in addPropertyWith (showId r) args $ + propRuleSmart eq (liftRule myView r) myGen + + addProperty "soundness strategy/generator" $ forAll showAsGen $ maybe False (isReady ex) . fromContext . applyD (strategy ex) . inContext ex . from @@ -371,47 +364,42 @@ -- check combination of parser and pretty-printer checkParserPretty :: (a -> a -> Bool) -> (String -> Either b a) -> (a -> String) -> a -> Bool -checkParserPretty eq parser pretty a = - either (const False) (eq a) (parser (pretty a)) +checkParserPretty eq p pretty a = + either (const False) (eq a) (p (pretty a)) checkParserPrettyEx :: Exercise a -> a -> Bool checkParserPrettyEx ex = checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex) -checkExamples :: Exercise a -> IO () +checkExamples :: Exercise a -> TestSuite checkExamples ex = do let xs = examples ex - unless (null xs) $ do - putStrLn $ "Checking " ++ show (length xs) ++ " examples" - bs <- forM xs $ \a -> checksForTerm True ex a - when (and bs) $ - putStrLn "Passed all tests" + unless (null xs) $ suite "Examples" $ + mapM_ (checksForTerm True ex) xs -checksForTerm :: Bool -> Exercise a -> a -> IO Bool +checksForTerm :: Bool -> Exercise a -> a -> TestSuite checksForTerm leftMost ex a = do let tree = derivationTree (strategy ex) (inContext ex a) -- Left-most derivation - b1 <- if not leftMost then return True else - case derivation tree of - Just d -> checksForDerivation ex d - Nothing -> do - report $ "no derivation for " ++ prettyPrinter ex a - return False + when leftMost $ + case derivation tree of + Just d -> checksForDerivation ex d + Nothing -> + fail $ "no derivation for " ++ prettyPrinter ex a -- Random derivation - g <- getStdGen - b2 <- case randomDerivation g tree of - Just d -> checksForDerivation ex d - Nothing -> return True - return $ and [b1, b2] + g <- liftIO getStdGen + case randomDerivation g tree of + Just d -> checksForDerivation ex d + Nothing -> return () -checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> IO Bool +checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> TestSuite checksForDerivation ex d = do -- Conditions on starting term let start = head (terms d) - b1 <- do let b = maybe False (isSuitable ex) (fromContext start) - unless b $ report $ - "start term not suitable: " ++ prettyPrinterContext ex start - return b + assertTrueMsg "start term" + ("not suitable: " ++ prettyPrinterContext ex start) $ + maybe False (isSuitable ex) (fromContext start) + {- b2 <- do let b = False -- maybe True (isReady ex) (fromContext start) when b $ report $ @@ -425,55 +413,35 @@ "final term is suitable: " ++ prettyPrinterContext ex start ++ " => " ++ prettyPrinterContext ex final return b -} - b4 <- do let b = maybe False (isReady ex) (fromContext final) - unless b $ report $ - "final term not ready: " ++ prettyPrinterContext ex start - ++ " => " ++ prettyPrinterContext ex final - return b + assertTrueMsg "final term" + ("not ready: " ++ prettyPrinterContext ex start + ++ " => " ++ prettyPrinterContext ex final) $ + maybe False (isReady ex) (fromContext final) + -- Parser/pretty printer on terms - let ts = terms d - p = maybe False (not . checkParserPrettyEx ex) . fromContext - b5 <- case filter p ts of - [] -> return True - hd:_ -> do - let s = prettyPrinterContext ex hd - report $ "parse error for " ++ s ++ ": parsed as " - ++ either show (prettyPrinter ex) (parser ex s) - return False + let ts = terms d + p1 = maybe False (not . checkParserPrettyEx ex) . fromContext + assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd -> + let s = prettyPrinterContext ex hd + in "parse error for " ++ s ++ ": parsed as " + ++ either show (prettyPrinter ex) (parser ex s) + + -- Equivalences between terms let pairs = [ (x, y) | x <- ts, y <- ts ] - p (x, y) = not (equivalenceContext ex x y) - b6 <- case filter p pairs of - [] -> return True - (x, y):_ -> do - report $ "not equivalent: " ++ prettyPrinterContext ex x - ++ " with " ++ prettyPrinterContext ex y - return False + p2 (x, y) = not (equivalenceContext ex x y) + assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) -> + "not equivalent: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + -- Similarity of terms - {- - let p (x, _, y) = fromMaybe False $ + let p3 (x, _, y) = fromMaybe False $ liftM2 (similarity ex) (fromContext x) (fromContext y) - b7 <- case filter p (triples d) of - [] -> return True - (x, r, y):_ -> do - report $ "similar subsequent terms: " ++ prettyPrinterContext ex x - ++ " with " ++ prettyPrinterContext ex y - ++ " using " ++ show r - return False -} + assertNull "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) -> + "similar subsequent terms: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + ++ " using " ++ show r + let xs = [ x | cx <- terms d, x <- fromContext cx, not (similarity ex x x) ] - b8 <- case xs of - [] -> return True - hd:_ -> do - report $ "term not similar to itself: " ++ prettyPrinter ex hd - return False - -- Result - return $ and [b1, b4, b5, b6, b8] - -report :: String -> IO () -report txt = putStrLn ("Error: " ++ txt) - -{- -generateIO :: Int -> Gen a -> IO [a] -generateIO n gen = forM [0..n] $ \i -> do - std <- newStdGen - return (generate i std gen) -} + assertNull "self similarity" $ take 1 $ flip map xs $ \hd -> + "term not similar to itself: " ++ prettyPrinter ex hd diff --git a/src/Common/Id.hs b/src/Common/Id.hs new file mode 100644 --- /dev/null +++ b/src/Common/Id.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Identification of entities +-- +----------------------------------------------------------------------------- +module Common.Id + ( Id, IsId(..), HasId(..), ( # ), sameId + , unqualified, qualifiers, qualification + , describe, description, showId, compareId + ) where + +import Data.Char +import Data.List +import Data.Monoid +import Data.Ord +import Common.StringRef +import Common.Utils (splitsWithElem) + +--------------------------------------------------------------------- +-- Abstract data type and its instances + +data Id = Id + { idList :: [String] + , idDescription :: String + , idRef :: !StringRef + } + +instance Show Id where + show = concat . intersperse "." . idList + +instance Eq Id where + a == b = idRef a == idRef b + +instance Ord Id where + compare = comparing idRef + +instance Monoid Id where + mempty = stringId "" + mappend = ( # ) + +--------------------------------------------------------------------- +-- Type class for constructing identifiers + +class IsId a where + newId :: a -> Id + concatId :: [a] -> Id -- for String instance + -- default definition + concatId = mconcat . map newId + +instance IsId Id where + newId = id + +instance IsId Char where + newId c = stringId [c] + concatId = stringId + +instance IsId a => IsId [a] where + newId = concatId + concatId = mconcat . map newId + +instance IsId () where + newId = const mempty + +instance (IsId a, IsId b) => IsId (a, b) where + newId (a, b) = newId a # newId b + +instance (IsId a, IsId b, IsId c) => IsId (a, b, c) where + newId (a, b, c) = newId a # newId b # newId c + +instance IsId a => IsId (Maybe a) where + newId = maybe mempty newId + +instance (IsId a, IsId b) => IsId (Either a b) where + newId = either newId newId + +----------------------------------------------------- +-- Type class for structures containing an identifier + +class HasId a where + getId :: a -> Id + changeId :: (Id -> Id) -> a -> a + +instance HasId Id where + getId = id + changeId = id + +instance (HasId a, HasId b) => HasId (Either a b) where + getId = either getId getId + changeId f = either (Left . changeId f) (Right . changeId f) + +--------------------------------------------------------------------- +-- Private constructors + +appendId :: Id -> Id -> Id +appendId a b + | null (idList a) = b + | null (idList b) = a + | otherwise = Id (idList a ++ idList b) "" ref + where + ref = stringRef (show a ++ "." ++ show b) + +-- Only allow alphanum and '-' ('.' has a special meaning) +stringId :: String -> Id +stringId txt = Id (make s) "" (stringRef s) + where + s = norm txt + make = filter (not . null) . splitsWithElem '.' + norm = filter ok . map toLower + ok c = isAlphaNum c || c `elem` ".-_" + +--------------------------------------------------------------------- +-- Additional functionality (overloaded) + +infixr 8 # + +( # ) :: (IsId a, IsId b) => a -> b -> Id +a # b = appendId (newId a) (newId b) + +sameId :: (IsId a, IsId b) => a -> b -> Bool +sameId a b = newId a == newId b + +unqualified :: HasId a => a -> String +unqualified a + | null xs = "" + | otherwise = last xs + where + xs = idList (getId a) + +qualifiers :: HasId a => a -> [String] +qualifiers a + | null xs = [] + | otherwise = init xs + where + xs = idList (getId a) + +qualification :: HasId a => a -> String +qualification = concat . intersperse "." . qualifiers + +description :: HasId a => a -> String +description = idDescription . getId + +showId :: HasId a => a -> String +showId = show . getId + +compareId :: HasId a => a -> a -> Ordering +compareId = comparing showId + +describe :: HasId a => String -> a -> a +describe = changeId . describeId + where + describeId s a + | null (idDescription a) = + a {idDescription = s} + | otherwise = + a {idDescription = s ++ " " ++ idDescription a} diff --git a/src/Common/Library.hs b/src/Common/Library.hs new file mode 100644 --- /dev/null +++ b/src/Common/Library.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exports most from package Common +-- +----------------------------------------------------------------------------- +module Common.Library + ( module Common.Classes, module Common.Transformation + , module Common.Context, module Common.Navigator + , module Common.Derivation + , module Common.Rewriting, module Common.Exercise + , module Common.Strategy, module Common.View + , failS, notS, repeatS, replicateS, sequenceS + ) where + +import Common.Classes +import Common.Context +import Common.Derivation +import Common.Exercise +import Common.Navigator hiding (left, right) +import Common.Rewriting hiding (difference) +import Common.Strategy hiding (fail, not, repeat, replicate, sequence) +import Common.Transformation +import Common.View + +import qualified Common.Strategy as S +import Prelude (Int) + +-- | Alias for strategy combinator @fail@ +failS :: Strategy a +failS = S.fail + +-- | Alias for strategy combinator @not@ +notS :: IsStrategy f => f a -> Strategy a +notS = S.not + +-- | Alias for strategy combinator @repeat@ +repeatS :: IsStrategy f => f a -> Strategy a +repeatS = S.repeat + +-- | Alias for strategy combinator @replicate@ +replicateS :: IsStrategy f => Int -> f a -> Strategy a +replicateS = S.replicate + +-- | Alias for strategy combinator @sequence@ +sequenceS :: IsStrategy f => [f a] -> Strategy a +sequenceS = S.sequence diff --git a/src/Common/Navigator.hs b/src/Common/Navigator.hs --- a/src/Common/Navigator.hs +++ b/src/Common/Navigator.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -17,13 +17,14 @@ IsNavigator(..), TypedNavigator(..) -- * Types and constructors , Navigator, Location - , navigator, noNavigator, viewNavigator + , navigator, noNavigator, viewNavigator, viewNavigatorWith -- * Derived navigations , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo - , top, leafs, downFirst, downLast, left, right + , navigateTowards, top, leafs, downFirst, downLast, left, right + , replaceT ) where -import Common.Uniplate +import Common.Uniplate hiding (leafs) import Common.View hiding (left, right) import Control.Monad import Data.Maybe @@ -57,9 +58,7 @@ allDowns a = [ fa | i <- [0 .. arity a-1], fa <- down i a ] change f a = - case changeM (Just . f) a of - Just new -> new - Nothing -> a + fromMaybe a (changeM (Just . f) a) class IsNavigator f => TypedNavigator f where changeT :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a) @@ -67,10 +66,10 @@ leaveT :: (Monad m, Typeable b) => f a -> m b castT :: (Monad m, Typeable e) => View e b -> f a -> m (f b) -- By default, fail - changeT _ _ = fail "changeT" - currentT _ = fail "currentT" - leaveT _ = fail "leaveT" - castT _ _ = fail "castT" + changeT _ _ = fail "changeT: not defined" + currentT _ = fail "currentT: not defined" + leaveT _ = fail "leaveT: not defined" + castT _ _ = fail "castT: not defined" --------------------------------------------------------------- -- Derived navigations @@ -102,6 +101,18 @@ js = location a n = length (takeWhile id (zipWith (==) is js)) +navigateTowards :: IsNavigator f => Location -> f a -> f a +navigateTowards is a = + case ups (length js - n) a of + Just b -> safeDowns (drop n is) b + Nothing -> a + where + js = location a + n = length (takeWhile id (zipWith (==) is js)) + + safeDowns [] b = b + safeDowns (m:ms) b = maybe b (safeDowns ms) (down m b) + top :: (IsNavigator f, Monad m) => f a -> m (f a) top = navigateTo [] @@ -144,12 +155,12 @@ -- The uniplate function is stored in the data type to get rid of the -- Uniplate type class constraints in the member functions of the -- Navigator type class. -data UniplateNav a = UN (UniplateType a) [(Int, a -> a)] a +data UniplateNav a = UN (HolesType a) [(Int, a -> a)] a -type UniplateType a = a -> ([a], [a] -> a) +type HolesType a = a -> [(a, a -> a)] -makeUN :: Uniplate a => a -> UniplateNav a -makeUN = UN uniplate [] +makeUN :: HolesType a -> a -> UniplateNav a +makeUN f = UN f [] instance Show a => Show (UniplateNav a) where show = showNav @@ -158,14 +169,9 @@ up (UN _ [] _) = fail "up" up (UN uni ((_, f):xs) a) = return (UN uni xs (f a)) - allDowns (UN uni xs a) = zipWith make [0..] cs - where - (cs, build) = uni a - make i = UN uni ((i, build . flip (update i) cs):xs) - update _ _ [] = [] - update i x (y:ys) - | i == 0 = x:ys - | otherwise = y:update (i-1) x ys + allDowns (UN uni xs a) = + let make i (b, f) = UN uni ((i, f):xs) b + in zipWith make [0..] (uni a) location (UN _ xs _) = reverse (map fst xs) @@ -203,20 +209,27 @@ leaveT (VN _ a) = leave a >>= castM castT v (VN v0 a) - | typeOf (getTp v) == typeOf (getTp v0) = - return (VN (makeView f g) a) - | otherwise = - fail "castT" + | tp1 == tp2 = return (VN (castView v) a) + | otherwise = fail $ "castT: " ++ show tp1 ++ " and " ++ show tp2 where - f e = castM e >>= matchM v - g = fromMaybe (error "castT") . cast . build v + tp1 = typeOf (getTp v) + tp2 = typeOf (getTp v0) getTp :: View a b -> a - getTp = error "castT" + getTp = error "castT: getTp" +replaceT :: (Monad m, TypedNavigator f, Typeable b) => b -> f a -> m (f a) +replaceT = changeT . const . return + castM :: (Monad m, Typeable a, Typeable b) => a -> m b castM = maybe (fail "castM") return . cast +castView :: (Typeable c, Typeable a) => View a b -> View c b +castView v = makeView f g + where + f e = castM e >>= matchM v + g = fromMaybe (error "castT: build") . castM . build v + --------------------------------------------------------------- -- Uniform navigator type @@ -252,10 +265,13 @@ -- Constructors navigator :: Uniplate a => a -> Navigator a -navigator = N . S . makeUN +navigator = N . S . makeUN holes noNavigator :: a -> Navigator a -noNavigator = N . S . UN (\a -> ([], const a)) [] +noNavigator = N . S . UN (const []) [] viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a -viewNavigator = N . VN identity . makeUN +viewNavigator = viewNavigatorWith holes + +viewNavigatorWith :: Typeable a => HolesType a -> a -> Navigator a +viewNavigatorWith f = N . VN identity . makeUN f diff --git a/src/Common/Rewriting.hs b/src/Common/Rewriting.hs --- a/src/Common/Rewriting.hs +++ b/src/Common/Rewriting.hs @@ -10,15 +10,16 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting - ( RewriteRule, smartGenerator, rewriteRule, rewriteRules - , Builder, rewriteM, RuleSpec((:~>)), rulePair, BuilderList, showRewriteRule - , Rewrite(..), ShallowEq(..), Operator - , associativeOperator, ruleName, Operators, collectWithOperator - , equalWith, isOperator, constructor, difference, differenceMode - , acOperator, normalizeWith, IsTerm(..), Different(..) + ( module Common.Rewriting.Term + , module Common.Rewriting.Group + , module Common.Rewriting.Operator + , module Common.Rewriting.Difference + , module Common.Rewriting.RewriteRule ) where -import Common.Rewriting.AC import Common.Rewriting.Difference +import Common.Rewriting.Group hiding (identity) +import Common.Rewriting.Operator hiding (unary, binary, isUnary, isBinary) import Common.Rewriting.RewriteRule -import Common.Rewriting.Term +import Common.Rewriting.Term hiding (Term(..)) +import Common.Rewriting.Term (Term) 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 @@ -10,123 +10,53 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting.AC - ( Operator, Operators, constructor, destructor - , newOperator, associativeOperator, commutativeOperator, acOperator - , makeAssociative, makeCommutative, isAssociative, isCommutative - , collectWithOperator, buildWithOperator - , isOperator, findOperator - , normalizeWith, equalWith + ( -- * Types + Pairings, PairingsList, PairingsPair + -- * Pairings with operator , pairings, pairingsMatch - , pairingsA2, onBoth + -- * Primitive pairings functions + , pairingsNone, pairingsA + , pairingsC, pairingsAC ) where -import Common.Uniplate -import Common.Utils -import Data.List +import Common.View +import Common.Rewriting.Group +import Control.Monad import Data.Maybe ------------------------------------------------------------ --- AC theories - -type Operators a = [Operator a] - -data Operator a = O - { constructor :: a -> a -> a - , destructor :: a -> Maybe (a, a) - , isAssociative :: Bool - , isCommutative :: Bool - } - -newOperator :: (a -> a -> a) -> (a -> Maybe (a, a)) -> Operator a -newOperator f g = O f g False False - -associativeOperator, commutativeOperator, acOperator :: (a -> a -> a) -> (a -> Maybe (a, a)) -> Operator a -associativeOperator f = makeAssociative . newOperator f -commutativeOperator f = makeCommutative . newOperator f -acOperator f = makeAssociative . commutativeOperator f - -makeCommutative, makeAssociative :: Operator a -> Operator a -makeCommutative op = op { isCommutative = True } -makeAssociative op = op { isAssociative = True } - -collectWithOperator :: Operator a -> a -> [a] -collectWithOperator op a - | isAssociative op = rec a [] - | otherwise = maybe [a] (\(x, y) -> [x, y]) (destructor op a) - where - rec a = case destructor op a of - Just (x, y) -> rec x . rec y - Nothing -> (a:) - -buildWithOperator :: Operator a -> [a] -> a -buildWithOperator op xs - | null xs = - error "Rewriting.buildWithOperator: empty list" - | not (isAssociative op) && length xs > 2 = - error "Rewriting.buildWithOperator: non-associative operator" - | otherwise = - foldr1 (constructor op) xs - -isOperator :: Operator a -> a -> Bool -isOperator op = isJust . destructor op - -findOperator :: Operators a -> a -> Maybe (Operator a) -findOperator ops a = safeHead $ filter (`isOperator` a) ops - -normalizeWith :: (Uniplate a, Ord a) => Operators a -> a -> a -normalizeWith ops = rec - where - rec a = - case findOperator ops a of - Just op -> - buildWithOperator op $ (if isCommutative op then sort else id) $ map rec $ collectWithOperator op a - Nothing -> - let (cs, f) = uniplate a - in f (map rec cs) - -equalWith :: (Uniplate a, Ord a) => Operators a -> a -> a -> Bool -equalWith ops x y = normalizeWith ops x == normalizeWith ops y +type Pairings a = a -> a -> [[(a, a)]] +type PairingsList a b = [a] -> [b] -> [[([a], [b])]] +type PairingsPair a b = (a, a) -> (b, b) -> [[(a, b)]] ----------------------------------------------------------- -- Pairing terms with an AC theory -- matchMode: the left-hand sides cannot have the operator at top-level -pairings, pairingsMatch :: Operator a -> a -> a -> [[(a, a)]] +pairings, pairingsMatch :: IsMagma m => m a -> Pairings a pairings = pairingsMode False pairingsMatch = pairingsMode True -pairingsMode :: Bool -> Operator a -> a -> a -> [[(a, a)]] +pairingsMode :: IsMagma m => Bool -> m a -> Pairings a pairingsMode matchMode op = case (isAssociative op, isCommutative op) of - (True , True ) -> pairingsAC matchMode op - (True , False) -> pairingsA matchMode op - (False, True ) -> pairingsC op - (False, False) -> pairingsNone op + (True , True ) -> operatorPairings op (pairingsAC matchMode) + (True , False) -> operatorPairings op (pairingsA matchMode) + (False, True ) -> opPairings op pairingsC + (False, False) -> opPairings op pairingsNone -- non-associative, non-commutative pairings -pairingsNone :: Operator a -> a -> a -> [[(a, a)]] -pairingsNone op a b = - case (destructor op a, destructor op b) of - (Just (a1, a2), Just (b1, b2)) -> [[(a1, b1), (a2, b2)]] - _ -> [] - +pairingsNone :: PairingsPair a b +pairingsNone (a1, a2) (b1, b2) = + [[(a1, b1), (a2, b2)]] + -- commutative pairings -pairingsC :: Operator a -> a -> a -> [[(a, a)]] -pairingsC op a b = - case (destructor op a, destructor op b) of - (Just (a1, a2), Just (b1, b2)) -> [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]] - _ -> [] +pairingsC :: PairingsPair a b +pairingsC (a1, a2) (b1, b2) = + [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]] -- associative pairings -pairingsA :: Bool -> Operator a -> a -> a -> [[(a, a)]] -pairingsA matchMode op a b = map (map make) result - where - (as, bs) = onBoth (collectWithOperator op) (a, b) - result = pairingsA2 matchMode as bs - make = onBoth (buildWithOperator op) - -pairingsA2 :: Bool -> [a] -> [a] -> [[([a], [a])]] -pairingsA2 matchMode = rec +pairingsA :: Bool -> PairingsList a b +pairingsA matchMode = rec where rec [] [] = [[]] rec as bs = @@ -142,40 +72,33 @@ ] -- associative/commutative pairings -pairingsAC :: Bool -> Operator a -> a -> a -> [[(a, a)]] -pairingsAC matchMode op a b = rec (collectWithOperator op a) (collectWithOperator op b) +pairingsAC :: Bool -> PairingsList a b +pairingsAC matchMode = rec where rec [] [] = [[]] rec [] _ = [] rec (a:as) bs = - [ (a1, b1):ps + [ (as1, bs1):ps | (asr, as2) <- if matchMode then [([], as)] else splits as , let as1 = a:asr , (bs1, bs2) <- splits bs , not (null bs1) , length as1==1 || length bs1==1 - , let a1 = buildWithOperator op as1 - , let b1 = buildWithOperator op bs1 , ps <- rec as2 bs2 ] -{- -data Tree = Leaf String | Bin Tree Tree deriving (Show, Eq, Ord) +---------------------------------------------------------- +-- Helper functions -opBin :: Operator Tree -opBin = Operator isBin Bin - where - isBin (Bin a b) = Just (a, b) - isBin _ = Nothing - -tree1 = Bin (Bin (Leaf "1") (Leaf "2")) (Bin (Leaf "3") (Leaf "4")) -- Bin (Bin (Leaf "a") (Leaf "b")) (Bin (Leaf "c") (Leaf "d")) -tree2 = Bin (Bin (Leaf "a") (Leaf "b")) (Bin (Leaf "c") (Leaf "d")) --Bin (Bin (Leaf "w") (Leaf "x")) (Bin (Leaf "y") (Leaf "z")) +opPairings :: IsMagma m => m a -> PairingsPair a a -> Pairings a +opPairings op f a b = fromMaybe [] $ + liftM2 f (match (magmaView op) a) (match (magmaView op) b) -ex1 = pairingsC opBin tree1 tree2 -ex2 = pairingsA False opBin tree1 tree2 -ex3 = pairingsA True opBin tree1 tree2 -ex4 = pairingsAC False opBin tree1 tree2 -ex5 = pairingsAC True opBin tree1 tree2 -} +operatorPairings :: IsMagma m => m a -> PairingsList a a -> Pairings a +operatorPairings op g = curry $ + let f a = fromMaybe [a] $ match (magmaListView op) a + h = build (magmaListView op) + in map (map (onBoth h)) . uncurry g . onBoth f splits :: [a] -> [([a], [a])] splits = foldr insert [([], [])] diff --git a/src/Common/Rewriting/Axioms.hs b/src/Common/Rewriting/Axioms.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Axioms.hs @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Group axioms specified as rewrite rules (directed). +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Axioms + ( -- Semigroup + leftAssociative, rightAssociative, associative + -- Monoid + , leftIdentity, rightIdentity + -- Group + , leftInverse, rightInverse + , inverseIdentity, inverseTwice + , flippedInverseDistribution + , groupAxioms + -- Abelian group + , commutative, inverseDistribution + ) where + +import Common.Id +import Common.Rewriting.Group +import Common.Rewriting.RewriteRule + +-- helper +rule :: (IsMagma m, IsId n, RuleBuilder f a, Rewrite a) => m a -> n -> f -> RewriteRule a +rule m s = rewriteRule (getId (toMagma m), s) + +------------------------------------------------------------------- +-- * SemiGroup + +leftAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a +leftAssociative m = rule m "associative.left" $ + \x y z -> x.(y.z) :~> (x.y).z + where + (.) = operation m + +rightAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a +rightAssociative m = rule m "associative.right" $ + \x y z -> (x.y).z :~> x.(y.z) + where + (.) = operation m + +associative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a +associative m + | leftIsPreferred m = leftAssociative m + | otherwise = rightAssociative m + +------------------------------------------------------------------- +-- * Monoid + +leftIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a +leftIdentity m = rule m "identity.left" $ + \x -> e.x :~> x + where + (.) = operation m + e = identity m + +rightIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a +rightIdentity m = rule m "identity.right" $ + \x -> x.e :~> x + where + (.) = operation m + e = identity m + +------------------------------------------------------------------- +-- * Group + +leftInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a +leftInverse m = rule m "inverse.left" $ + \x -> f x.x :~> e + where + (.) = operation m + e = identity m + f = inverse m + +rightInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a +rightInverse m = rule m "inverse.right" $ + \x -> x.f x :~> e + where + (.) = operation m + e = identity m + f = inverse m + +inverseIdentity :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a +inverseIdentity m = rule m "inverse.identity" $ + f e :~> e + where + e = identity m + f = inverse m + +inverseTwice :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a +inverseTwice m = rule m "inverse.twice" $ + \x -> f (f x) :~> x + where + f = inverse m + +flippedInverseDistribution :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a +flippedInverseDistribution m = rule m "inverse.distribution.flipped" $ + \x y -> f (x.y) :~> f y.f x + where + (.) = operation m + f = inverse m + +groupAxioms :: (IsGroup m, Different a, Rewrite a) => m a -> [RewriteRule a] +groupAxioms g = map ($ g) + [ associative, leftIdentity, rightIdentity + , leftInverse, rightInverse + , inverseIdentity, inverseTwice, flippedInverseDistribution + ] ++ extra + where + extra + | leftIsPreferred g = + [ rule g "group1" $ \x y -> (y.x).f x :~> y + , rule g "group2" $ \x y -> (y.f x).x :~> y + ] + | otherwise = + [ rule g "group3" $ \x y -> f x.(x.y) :~> y + , rule g "group4" $ \x y -> x.(f x.y) :~> y + ] + (.) = operation g + f = inverse g + +------------------------------------------------------------------- +-- * Abelian Group + +-- The type class constraint IsAbelianGroup could be relaxed to +-- IsCommutative (or something similar) +commutative :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a +commutative m = rule m "commutative" $ + \x y -> x.y :~> y.x + where + (.) = operation m + +inverseDistribution :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a +inverseDistribution m = rule m "inverse.distribution" $ + \x y -> f (x.y) :~> f x.f y + where + (.) = operation m + f = inverse m diff --git a/src/Common/Rewriting/Confluence.hs b/src/Common/Rewriting/Confluence.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Confluence.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Confluence + ( isConfluent, checkConfluence, checkConfluenceWith + , somewhereM + , Config, defaultConfig, showTerm, complexity, termEquality + ) where + +import Common.Id +import Common.Navigator +import Common.Rewriting.RewriteRule +import Common.Rewriting.Substitution +import Common.Rewriting.Unification +import Common.Rewriting.Term +import Common.Uniplate hiding (rewriteM) +import Data.Char +import Data.Maybe + +normalForm :: [RewriteRule a] -> Term -> Term +normalForm rs = run [] + where + run hist a = + case [ b | r <- rs, b <- somewhereM (rewriteTerm r) a ] of + [] -> a + hd:_ -> if hd `elem` hist + then error "cyclic" + else run (a:hist) hd + +rewriteTerm :: RewriteRule a -> Term -> [Term] +rewriteTerm r t = do + let lhs :~> rhs = ruleSpecTerm r + sub <- match [] lhs t + return (sub |-> rhs) + +-- uniplate-like helper-functions +somewhereM :: Uniplate a => (a -> [a]) -> a -> [a] +somewhereM f = concatMap leave . rec . navigator + where + rec ca = changeM f ca ++ concatMap rec (allDowns ca) + +---------------------------------------------------- + +type Pair a = (RewriteRule a, Term) +type Triple a = (RewriteRule a, Term, Term) + +superImpose :: RewriteRule a -> RewriteRule a -> [Navigator Term] +superImpose r1 r2 = rec (navigator lhs1) + where + lhs1 :~> _ = ruleSpecTerm r1 + lhs2 :~> _ = ruleSpecTerm (renumber r1 r2) + + rec ca = case current ca of + Just (Meta _) -> [] + Just a -> [ subTop s ca | s <- unifyM a lhs2 ] ++ concatMap rec (allDowns ca) + Nothing -> [] + + subTop s ca = fromMaybe ca $ + fmap (change (freeze . (s |->))) (top ca) >>= navigateTo (location ca) + + renumber r = case metaInRewriteRule r of + [] -> id + xs -> renumberRewriteRule (maximum xs + 1) + +criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)] +criticalPairs rs = + [ (freeze a, (r1, freeze b1), (r2, freeze b2)) + | r1 <- rs + , r2 <- rs + , na <- superImpose r1 r2 + , compareId r1 r2 == LT || not (null (location na)) + , a <- leave na + , b1 <- rewriteTerm r1 a + , b2 <- changeM (rewriteTerm r2) na >>= leave + ] + +noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)] +noDiamondPairs cfg rs = noDiamondPairsWith (normalForm rs) cfg rs + +noDiamondPairsWith :: (Term -> Term) -> Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)] +noDiamondPairsWith f cfg rs = + [ (a, (r1, e1, nf1), (r2, e2, nf2)) + | (a, (r1, e1), (r2, e2)) <- criticalPairs rs + , let (nf1, nf2) = (f e1, f e2) + , not (termEquality cfg nf1 nf2) + ] + +reportPairs :: Config -> [(Term, Triple a, Triple a)] -> IO () +reportPairs cfg = putStrLn . unlines . zipWith report [1::Int ..] + where + f = showTerm cfg . unfreeze + report i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines + [ show i ++ ") " ++ f a + , " " ++ showId r1 + , " " ++ f e1 ++ if e1==nf1 then "" else " --> " ++ f nf1 + , " " ++ showId r2 + , " " ++ f e2 ++ if e2==nf2 then "" else " --> " ++ f nf2 + ] + +freeze :: Term -> Term +freeze (Meta n) = Con (newId ('m' : show n)) +freeze term = descend freeze term + +unfreeze :: Term -> Term +unfreeze (Con s) = case showId s of + 'm':is | all isDigit is -> -- && not (null is) -> + Meta (read is) + _ -> Con s +unfreeze term = descend unfreeze term + + +---------------------------------------------------- + +isConfluent :: [RewriteRule a] -> Bool +isConfluent = null . noDiamondPairs defaultConfig + +checkConfluence :: [RewriteRule a] -> IO () +checkConfluence = checkConfluenceWith defaultConfig + +checkConfluenceWith :: Config -> [RewriteRule a] -> IO () +checkConfluenceWith cfg = reportPairs cfg . noDiamondPairs cfg + +data Config = Config + { showTerm :: Term -> String + , complexity :: Term -> Int + , termEquality :: Term -> Term -> Bool + } + +defaultConfig :: Config +defaultConfig = Config show (const 0) (==) + +---------------------------------------------------- +-- Example +{- +r1, r2, r3, r4, r5 :: RewriteRule SLogic +r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r +r2 = rewriteRule "R2" $ \p q -> p :||: q :~> q :||: p +r3 = rewriteRule "R3" $ \p -> p :||: p :~> p +r4 = rewriteRule "R4" $ \p -> p :||: T :~> T +r5 = rewriteRule "R5" $ \p -> p :||: F :~> p + +this = [r1, r2, r3, r4, r5, r6] +go = reportPairs $ noDiamondPairs this + +r6 :: RewriteRule SLogic +r6 = rewriteRule "R6" $ \p -> p :||: T :~> F + +r1, r2, r3 :: RewriteRule Expr +r1 = rewriteRule "a1" $ \a -> 0+a :~> a +r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c +r3 = rewriteRule "a2" $ \a -> a+0 :~> a + +go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2] + checkConfluence [r1,r2,r3] +-} 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 @@ -16,13 +16,16 @@ ( difference, differenceEqual, differenceMode ) where -import Common.Rewriting.AC +import Common.Rewriting.Group +import Common.Rewriting.Term import Common.Rewriting.RewriteRule +import Common.View +import Common.Utils (safeHead) import Control.Monad import Common.Uniplate import Data.Maybe -differenceMode :: (Rewrite a, Uniplate a, ShallowEq a) +differenceMode :: (Rewrite a, Uniplate a) => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a) differenceMode eq b = if b then differenceEqual eq else difference @@ -30,51 +33,59 @@ -- | This function returns the difference, except that the -- returned terms should be logically equivalent. Nothing can signal that -- there is no difference, or that the terms to start with are not equivalent. -differenceEqual :: (Rewrite a, Uniplate a, ShallowEq a) +differenceEqual :: (Rewrite a, Uniplate a) => (a -> a -> Bool) -> a -> a -> Maybe (a, a) differenceEqual eq p q = do guard (eq p q) diff eq p q -difference :: (Rewrite a, Uniplate a, ShallowEq a) - => a -> a -> Maybe (a, a) +difference :: (Rewrite a, Uniplate a) => a -> a -> Maybe (a, a) difference = diff (\_ _ -> True) +shallowEq :: IsTerm a => a -> a -> Bool +shallowEq a b = + let f = liftM fst . getFunction + ta = toTerm a + tb = toTerm b + in fromMaybe (ta == tb) $ liftM2 (==) (f ta) (f tb) + +findOperator :: [Magma a] -> a -> Maybe (Magma a) +findOperator ops a = safeHead $ filter (`isOperator` a) ops + where isOperator op = isJust . match (magmaView op) + -- local implementation function -diff :: (Rewrite a, Uniplate a, ShallowEq a) - => (a -> a -> Bool) -> a -> a -> Maybe (a, a) -diff eq p q - | shallowEq p q = - case findOperator operators p of - Just op | isAssociative op && not (isCommutative op) -> - let ps = collectWithOperator op p - qs = collectWithOperator op q - in diffA eq op ps qs - _ -> diffList eq (children p) (children q) - | otherwise = Just (p, q) +diff :: (Rewrite a, Uniplate a) => (a -> a -> Bool) -> a -> a -> Maybe (a, a) +diff eq = rec + where + rec p q + | shallowEq p q = + case findOperator operators p of + Just op | isAssociative op && not (isCommutative op) -> do + ps <- match (magmaListView op) p + qs <- match (magmaListView op) q + diffA op ps qs + _ -> diffList (children p) (children q) + | otherwise = Just (p, q) -diffList :: (Rewrite a, Uniplate a, ShallowEq a) - => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a) -diffList eq xs ys - | length xs /= length ys = Nothing - | otherwise = - case catMaybes (zipWith (diff eq) xs ys) of - [p] -> Just p - _ -> Nothing + diffList xs ys + | length xs /= length ys = Nothing + | otherwise = + case catMaybes (zipWith rec xs ys) of + [p] -> Just p + _ -> Nothing -diffA :: (Rewrite a, Uniplate a, ShallowEq a) - => (a -> a -> Bool) -> Operator a -> [a] -> [a] -> Maybe (a, a) -diffA eq op = curry (make . uncurry rev . f . uncurry rev . f) - where - f (p:ps, q:qs) | not (null ps || null qs) && - isNothing (diff eq p q) && - (equal ps qs) = - f (ps, qs) - f pair = pair - - equal ps qs = buildWithOperator op ps `eq` buildWithOperator op qs - rev ps qs = (reverse ps, reverse qs) - make pair = - case pair of - ([p], [q]) -> diff eq p q - (ps, qs) -> Just (buildWithOperator op ps, buildWithOperator op qs) + diffA op = curry (make . uncurry rev . f . uncurry rev . f) + where + f (p:ps, q:qs) | not (null ps || null qs) && + isNothing (rec p q) && + equal ps qs = + f (ps, qs) + f pair = pair + + equal ps qs = builder ps `eq` builder qs + rev ps qs = (reverse ps, reverse qs) + builder = build (magmaListView op) + make pair = + case pair of + ([p], [q]) -> rec p q + (ps, qs) -> Just (builder ps, builder qs) diff --git a/src/Common/Rewriting/Group.hs b/src/Common/Rewriting/Group.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Group.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A hierarchy of magma's (binary operators) and groups, up to Abelian groups. +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Group + ( -- Magma + IsMagma(..), Magma, magma, magmaView, magmaListView + , withMatch, findMagma + , isAssociative, isCommutative, isIdempotent + , makeAssociative, makeCommutative, makeIdempotent + -- Semigroup + , IsSemiGroup(..), SemiGroup, semiGroup + , leftIsPreferred, rightIsPreferred + , preferLeft, preferRight + -- Monoid + , IsMonoid(..), Monoid, monoid + -- Group + , IsGroup(..), Group, group + -- Abelian group + , IsAbelianGroup(..), AbelianGroup, abelianGroup + ) where + +import Control.Arrow +import Common.Id +import Common.View hiding (identity) +import Common.Rewriting.Operator + +------------------------------------------------------------------- +-- * Magma + +class IsMagma f where + operation :: f a -> a -> a -> a + hasMagma :: f a -> (Magma a, Magma a -> f a) + toMagma :: f a -> Magma a + changeMagma :: (Magma a -> Magma a) -> f a -> f a + -- default definitions + operation = binary . magmaBinaryOp . toMagma + toMagma = fst . hasMagma + changeMagma f = uncurry (flip ($)) . first f . hasMagma + +data Magma a = Magma + { magmaBinaryOp :: BinaryOp a + , magmaProperties :: [MagmaProperty] + } + +data MagmaProperty = Associative | Commutative | Idempotent | PreferLeft + deriving Eq + +instance Show (Magma a) where + show m = "Magma " ++ showId m + +instance HasId (Magma a) where + getId = getId . magmaBinaryOp + changeId f m = m {magmaBinaryOp = changeId f (magmaBinaryOp m)} + +instance IsMagma Magma where + hasMagma a = (a, id) + +magma :: BinaryOp a -> Magma a +magma op = Magma op [] + +magmaView :: IsMagma m => m a -> View a (a, a) +magmaView = binaryView . magmaBinaryOp . toMagma + +-- The list can (and should) only contain more than two elements if the magma +-- is associative +magmaListView :: IsMagma m => m a -> View a [a] +magmaListView m = makeView (Just . toList) fromList + where + toList = if isAssociative m then ($ []) . rec else f + + f a = maybe [a] (\(x, y) -> [x, y]) (match (magmaView m) a) + + rec a = case match (magmaView m) a of + Just (b, c) -> rec b . rec c + Nothing -> (a:) + + fromList xs + | null xs = + error "semiGroupView.build: empty list" + | n>2 && not (isAssociative m) = + error $ "semiGroupView.build: not associativity for " + ++ showId (toMagma m) + | otherwise = fold (operation m) xs + where + n = length xs + fold = if hasProperty PreferLeft m then foldl1 else foldr1 + +withMatch :: IsMagma m => (a -> Maybe (a, a)) -> m a -> m a +withMatch f = changeMagma $ \m -> m {magmaBinaryOp = g (magmaBinaryOp m)} + where + g op = makeBinary (getId op) (binary op) f + +isAssociative, isCommutative, isIdempotent :: IsMagma m => m a -> Bool +isAssociative = hasProperty Associative +isCommutative = hasProperty Commutative +isIdempotent = hasProperty Idempotent + +makeAssociative, makeCommutative, makeIdempotent :: IsMagma m => m a -> m a +makeAssociative = giveProperty Associative +makeCommutative = giveProperty Commutative +makeIdempotent = giveProperty Idempotent + +findMagma :: IsMagma m => (m a -> b) -> m a -> (Magma a, Magma a -> b) +findMagma f = second (f .) . hasMagma + +-- helper functions +hasProperty :: IsMagma m => MagmaProperty -> m a -> Bool +hasProperty p = elem p . magmaProperties . toMagma + +giveProperty :: IsMagma m => MagmaProperty -> m a -> m a +giveProperty p = changeMagma $ \m -> + m {magmaProperties = p:magmaProperties m} + +removeProperty :: IsMagma m => MagmaProperty -> m a -> m a +removeProperty p = changeMagma $ \m -> + m {magmaProperties = filter (/=p) (magmaProperties m)} + +------------------------------------------------------------------- +-- * SemiGroup + +class IsMagma f => IsSemiGroup f where + toSemiGroup :: f a -> SemiGroup a + -- default definition + toSemiGroup m = SemiGroup (rightIsPreferred m) (toMagma m) + +data SemiGroup a = SemiGroup Bool (Magma a) + +instance Show (SemiGroup a) where + show m = "Semigroup " ++ showId m + +instance HasId (SemiGroup a) where + getId = getId . toMagma + changeId = changeMagma . changeId + +instance IsMagma SemiGroup where + hasMagma (SemiGroup b m) = findMagma (SemiGroup b) m + +instance IsSemiGroup SemiGroup where + toSemiGroup = id + +semiGroup :: BinaryOp a -> SemiGroup a +semiGroup op = makeAssociative $ SemiGroup True (magma op) + +leftIsPreferred, rightIsPreferred :: IsSemiGroup m => m a -> Bool +leftIsPreferred = hasProperty PreferLeft +rightIsPreferred = not . leftIsPreferred + +preferLeft, preferRight :: IsSemiGroup m => m a -> m a +preferLeft = giveProperty PreferLeft +preferRight = removeProperty PreferLeft + +------------------------------------------------------------------- +-- * Monoid + +class IsSemiGroup f => IsMonoid f where + identity :: f a -> a + identityCon :: f a -> Constant a + toMonoid :: f a -> Monoid a + -- default definition + identity = constant . identityCon + toMonoid m = Monoid (identityCon m) (toSemiGroup m) + +data Monoid a = Monoid (Constant a) (SemiGroup a) + +instance Show (Monoid a) where + show m = "Monoid " ++ showId m + +instance HasId (Monoid a) where + getId = getId . toMagma + changeId = changeMagma . changeId + +instance IsMagma Monoid where + hasMagma (Monoid e g) = findMagma (Monoid e) g + +instance IsSemiGroup Monoid + +instance IsMonoid Monoid where + identityCon (Monoid e _) = e + toMonoid = id + +monoid :: BinaryOp a -> Constant a -> Monoid a +monoid op e = Monoid e (semiGroup op) + +------------------------------------------------------------------- +-- * Group + +class IsMonoid f => IsGroup f where + inverse :: f a -> a -> a + inverseOp :: f a -> UnaryOp a + toGroup :: f a -> Group a + -- default definition + inverse = unary . inverseOp + toGroup g = Group (inverseOp g) (toMonoid g) + +data Group a = Group (UnaryOp a) (Monoid a) + +instance Show (Group a) where + show m = "Group " ++ showId m + +instance HasId (Group a) where + getId = getId . toMagma + changeId = changeMagma . changeId + +instance IsMagma Group where + hasMagma (Group inv m) = findMagma (Group inv) m + +instance IsSemiGroup Group + +instance IsMonoid Group where + identityCon (Group _ m) = identityCon m + +instance IsGroup Group where + inverseOp (Group inv _) = inv + toGroup = id + +group :: BinaryOp a -> Constant a -> UnaryOp a -> Group a +group op e inv = Group inv (monoid op e) + +------------------------------------------------------------------- +-- * Abelian Group + +class IsGroup f => IsAbelianGroup f where + toAbelianGroup :: f a -> AbelianGroup a + -- default definition + toAbelianGroup = AbelianGroup . toGroup + +newtype AbelianGroup a = AbelianGroup (Group a) + deriving (HasId, IsMagma, IsSemiGroup, IsMonoid, IsGroup) + +abelianGroup :: BinaryOp a -> Constant a -> UnaryOp a -> AbelianGroup a +abelianGroup op e inv = makeCommutative $ AbelianGroup (group op e inv) + +instance Show (AbelianGroup a) where + show m = "Abelian group " ++ showId m + +instance IsAbelianGroup AbelianGroup diff --git a/src/Common/Rewriting/MetaVar.hs b/src/Common/Rewriting/MetaVar.hs deleted file mode 100644 --- a/src/Common/Rewriting/MetaVar.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.MetaVar where - -import Common.Uniplate -import Common.Utils (readInt) -import qualified Data.IntSet as IS - ------------------------------------------------------------ ---- Meta variables - --- | Type class for creating meta-variables -class MetaVar a where - metaVar :: Int -> a - isMetaVar :: a -> Maybe Int - -instance MetaVar String where - isMetaVar ('_':xs) = readInt xs - isMetaVar _ = Nothing - metaVar n = '_' : show n - --- | Produces an infinite list of meta-variables -metaVars :: MetaVar a => [a] -metaVars = map metaVar [0..] - --- | Collect all meta-variables -getMetaVars :: (MetaVar a, Uniplate a) => a -> IS.IntSet -getMetaVars a = getMetaVarsList [a] - --- | Collect all meta-variables in the list -getMetaVarsList :: (MetaVar a, Uniplate a) => [a] -> IS.IntSet -getMetaVarsList xs = IS.fromList [ i | x <- xs, a <- universe x, Just i <- [isMetaVar a] ] - --- | Checks whether the meta-variable is used in a term -hasMetaVar :: (MetaVar a, Uniplate a) => Int -> a -> Bool -hasMetaVar i = IS.member i . getMetaVars - --- | Checks whether the meta-variable is used in one of the elements in the list -hasMetaVarList :: (MetaVar a, Uniplate a) => Int -> [a] -> Bool -hasMetaVarList i = IS.member i . getMetaVarsList - --- | Checks whether a value has no variables -noMetaVars :: (Uniplate a, MetaVar a) => a -> Bool -noMetaVars = IS.null . getMetaVars - --- | Determine what the next unused meta-varable is -nextMetaVar :: (Uniplate a, MetaVar a) => a -> Int -nextMetaVar a = nextMetaVarOfList [a] - --- | Determine what the next meta-variable is that is not used in --- an element of the list -nextMetaVarOfList :: (Uniplate a, MetaVar a) => [a] -> Int -nextMetaVarOfList xs - | IS.null s = 0 - | otherwise = 1 + IS.findMax s - where - s = getMetaVarsList xs - --- | Rename the meta-variables -renameMetaVars :: (MetaVar a, Uniplate a) => (Int -> Int) -> a -> a -renameMetaVars f a = - case isMetaVar a of - Just i -> metaVar (f i) - Nothing -> g $ map (renameMetaVars f) cs - where - (cs, g) = uniplate a diff --git a/src/Common/Rewriting/Operator.hs b/src/Common/Rewriting/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Operator.hs @@ -0,0 +1,117 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Operator + ( -- * Constants + Constant, makeConstant, simpleConstant + , constant, isConstant, constantView + -- * Unary operators + , UnaryOp, makeUnary, simpleUnary + , unary, isUnary, unaryMatch, unaryView + -- * Binary operators + , BinaryOp, makeBinary, simpleBinary + , binary, isBinary, binaryMatch, binaryView + ) where + +import Common.Id +import Common.Uniplate +import Common.View +import Data.Maybe +import Control.Monad + +---------------------------------------------------------------------- +-- Constants + +data Constant a = C + { constantId :: Id + , constant :: a + , isConstant :: a -> Bool + } + +instance Show (Constant a) where + show = showId + +instance HasId (Constant a) where + getId = constantId + changeId f op = op {constantId = f (constantId op)} + +makeConstant :: IsId n => n -> a -> (a -> Bool) -> Constant a +makeConstant = C . newId + +simpleConstant :: (IsId n, Eq a) => n -> a -> Constant a +simpleConstant n a = makeConstant n a (==a) + +constantView :: Constant a -> View a () +constantView (C i a p) = newView i (guard . p) (const a) + +---------------------------------------------------------------------- +-- Unary operators + +data UnaryOp a = U + { unaryId :: Id + , unary :: a -> a + , unaryMatch :: a -> Maybe a + } + +instance Show (UnaryOp a) where + show = showId + +instance HasId (UnaryOp a) where + getId = unaryId + changeId f op = op {unaryId = f (unaryId op)} + +makeUnary :: IsId n => n -> (a -> a) -> (a -> Maybe a) -> UnaryOp a +makeUnary = U . newId + +simpleUnary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a) -> UnaryOp a +simpleUnary n op = makeUnary n op f + where + f a = case children a of + [x] | op x == a -> Just x + _ -> Nothing + +isUnary :: UnaryOp a -> a -> Bool +isUnary op = isJust . unaryMatch op + +unaryView :: UnaryOp a -> View a a +unaryView (U i op m) = newView i m op + +---------------------------------------------------------------------- +-- Binary operators + +data BinaryOp a = B + { binaryId :: Id + , binary :: a -> a -> a + , binaryMatch :: a -> Maybe (a, a) + } + +instance Show (BinaryOp a) where + show = showId + +instance HasId (BinaryOp a) where + getId = binaryId + changeId f op = op {binaryId = f (binaryId op)} + +makeBinary :: IsId n => n -> (a -> a -> a) -> (a -> Maybe (a, a)) -> BinaryOp a +makeBinary = B . newId + +simpleBinary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a -> a) -> BinaryOp a +simpleBinary n op = makeBinary n op f + where + f a = case children a of + [x, y] | op x y == a -> Just (x, y) + _ -> Nothing + +isBinary :: BinaryOp a -> a -> Bool +isBinary op = isJust . binaryMatch op + +binaryView :: BinaryOp a -> View a (a, a) +binaryView (B n op m) = newView n m (uncurry op) 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,5 @@ {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, - FunctionalDependencies, FlexibleInstances, UndecidableInstances, - TypeSynonymInstances #-} + FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -14,45 +13,42 @@ ----------------------------------------------------------------------------- module Common.Rewriting.RewriteRule ( -- * Supporting type classes - Rewrite(..), ShallowEq(..), Different(..) + Rewrite(..), Different(..) -- * Rewrite rules and specs - , RewriteRule(ruleName, rulePair), RuleSpec(..) - -- * Compiling a rewrite rule - , rewriteRule, rewriteRules, Builder, BuilderList + , RewriteRule, ruleSpecTerm, RuleSpec(..) + -- * Compiling rewrite rules + , rewriteRule, RuleBuilder -- * Using rewrite rules , rewrite, rewriteM, showRewriteRule, smartGenerator + , metaInRewriteRule, renumberRewriteRule, inverseRule + , useOperators ) where -import Common.Rewriting.AC +import Common.Classes +import Common.Id +import Common.View hiding (match) import Common.Rewriting.Substitution import Common.Rewriting.Term +import Common.Rewriting.Group +import Common.Rewriting.Unification hiding (match) +import Common.Uniplate (descend, leafs) import Control.Monad +import Data.Maybe import Test.QuickCheck -import Common.Apply -import Common.Rewriting.MetaVar (getMetaVars) -import Common.Rewriting.Unification +import qualified Common.Rewriting.Unification as Unification import qualified Data.IntSet as IS -import qualified Data.Map as M - + ------------------------------------------------------ -- Supporting type classes -class Different a where - different :: (a, a) - -class ShallowEq a where - shallowEq :: a -> a -> Bool - -- The arbitrary type class is a quick solution to have smart generators -- (in combination with lifting rules). The function in the RewriteRule module -- cannot have a type class for this reason -- The show type class is added for pretty-printing rules class (IsTerm a, Arbitrary a, Show a) => Rewrite a where - operators :: [Operator a] - associativeOps :: a -> [Symbol] - -- default definition: no associative/commutative operators - operators = [] - associativeOps = const [] + operators :: [Magma a] + -- default definition: no special operators + operators = [] ------------------------------------------------------ -- Rewrite rules and specs @@ -61,80 +57,69 @@ data RuleSpec a = a :~> a deriving Show -data RewriteRule a = Rewrite a => R - { ruleName :: String - , nrOfMetaVars :: Int - , rulePair :: Int -> RuleSpec Term - } - instance Functor RuleSpec where fmap f (a :~> b) = f a :~> f b ------------------------------------------------------- --- Compiling a rewrite rule +instance Crush RuleSpec where + crush (a :~> b) = [a, b] -class Builder t a | t -> a where - buildSpec :: t -> Int -> RuleSpec Term - countVars :: t -> Int +instance Zip RuleSpec where + fzipWith f (a :~> b) (c :~> d) = f a c :~> f b d -instance IsTerm a => Builder (RewriteRule a) a where - buildSpec = rulePair - countVars = nrOfMetaVars +data RewriteRule a = R + { ruleId :: Id + , ruleSpecTerm :: RuleSpec Term + , ruleOperators :: [Magma a] + , ruleShow :: a -> String + , ruleTermView :: View Term a + , ruleGenerator :: Gen a + } + +instance Show (RewriteRule a) where + show = showId -instance IsTerm a => Builder (RuleSpec a) a where - buildSpec (a :~> b) _ = toTerm a :~> toTerm b - countVars _ = 0 +instance HasId (RewriteRule a) where + getId = ruleId + changeId f r = r {ruleId = f (ruleId r)} -instance (Different a, Builder t b) => Builder (a -> t) b where - buildSpec f i = buildFunction i (\a -> buildSpec (f a) (i+1)) - countVars f = countVars (f $ error "countVars") + 1 +------------------------------------------------------ +-- Compiling a rewrite rule -class BuilderList t a | t -> a where - getSpecNr :: t -> Int -> Int -> RuleSpec Term - countSpecsL :: t -> Int - countVarsL :: t -> Int +class Different a where + different :: (a, a) -instance Rewrite a => BuilderList (RewriteRule a) a where - getSpecNr r n = if n==0 then rulePair r else error "getSpecNr" - countSpecsL _ = 1 - countVarsL = nrOfMetaVars - -instance Builder t a => BuilderList [t] a where - getSpecNr rs = buildSpec . (rs !!) - countSpecsL = length - countVarsL _ = 0 +class RuleBuilder t a | t -> a where + buildRuleSpec :: t -> Int -> RuleSpec Term -instance (Different a, BuilderList t b) => BuilderList (a -> t) b where - getSpecNr f n i = buildFunction i (\a -> getSpecNr (f a) n (i+1)) - countSpecsL f = countSpecsL (f $ error "countSpecsL") - countVarsL f = countVarsL (f $ error "countSpecsL") + 1 +instance IsTerm a => RuleBuilder (RuleSpec a) a where + buildRuleSpec = const . fmap toTerm -buildFunction :: Different a => Int -> (a -> RuleSpec Term) -> RuleSpec Term -buildFunction n f = fill n a1 a2 :~> fill n b1 b2 - where - a1 :~> b1 = f (fst different) - a2 :~> b2 = f (snd different) +instance (Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where + buildRuleSpec f i = buildFunction i (\a -> buildRuleSpec (f a) (i+1)) +buildFunction :: (Zip f, Different a) => Int -> (a -> f Term) -> f Term +buildFunction n f = fzipWith (fill n) (f a) (f b) + where (a, b) = different + fill :: Int -> Term -> Term -> Term -fill i (App a1 a2) (App b1 b2) = App (fill i a1 b1) (fill i a2 b2) -fill i a b - | a == b = a - | otherwise = Meta i - -build :: Rewrite a => RuleSpec Term -> a -> [a] -build (lhs :~> rhs) a = do - s <- match (getMatcher a) lhs (toTerm a) - fromTermM (s |-> rhs) - -rewriteRule :: (Builder f a, Rewrite a) => String -> f -> RewriteRule a -rewriteRule s f = R s (countVars f) (buildSpec f) - -rewriteRules :: (BuilderList f a, Rewrite a) => String -> f -> [RewriteRule a] -rewriteRules s f = map (R s (countVarsL f) . getSpecNr f) [0 .. countSpecsL f-1] +fill i = rec + where + rec (Apply f a) (Apply g b) = Apply (rec f g) (rec a b) + rec a b + | a == b = a + | otherwise = Meta i -getMatcher :: Rewrite a => a -> Matcher -getMatcher = M.unions . map associativeMatcher . associativeOps +buildSpec :: [Symbol] -> RuleSpec Term -> Term -> [Term] +buildSpec ops (lhs :~> rhs) a = do + s <- Unification.match ops lhs a + let (b1, b2) = (specialLeft `elem` dom s, specialRight `elem` dom s) + sym = maybe (error "buildSpec") fst (getFunction lhs) + extLeft x = if b1 then binary sym (Meta specialLeft) x else x + extRight x = if b2 then binary sym x (Meta specialRight) else x + return (s |-> extLeft (extRight rhs)) +rewriteRule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> RewriteRule a +rewriteRule s f = R (newId s) (buildRuleSpec f 0) operators show termView arbitrary ------------------------------------------------------ -- Using a rewrite rule @@ -143,10 +128,17 @@ applyAll = rewrite rewrite :: RewriteRule a -> a -> [a] -rewrite r@(R _ _ _) a = do - ext <- extendContext (associativeOps a) r - build (rulePair ext 0) a +rewrite r a = + let term = toTermRR r a + syms = mapMaybe (operatorSymbol r a) (ruleOperators r) + in concatMap (fromTermRR r) (buildSpec syms (ruleSpecTerm r) term) +operatorSymbol :: IsMagma m => RewriteRule a -> a -> m a -> Maybe Symbol +operatorSymbol r a op = + case getFunction (toTermRR r (operation op a a)) of + Just (s, [_, _]) -> Just s + _ -> Nothing + rewriteM :: MonadPlus m => RewriteRule a -> a -> m a rewriteM r = msum . map return . rewrite r @@ -154,58 +146,51 @@ -- Pretty-print a rewriteRule showRewriteRule :: Bool -> RewriteRule a -> Maybe String -showRewriteRule sound r@(R _ _ _) = do - x <- fromTermTp r (sub |-> a) - y <- fromTermTp r (sub |-> b) +showRewriteRule sound r = do + x <- fromTermRR r (sub |-> a) + y <- fromTermRR r (sub |-> b) let op = if sound then "~>" else "/~>" - return (show x ++ " " ++ op ++ " " ++ show y) + return (ruleShow r x ++ " " ++ op ++ " " ++ ruleShow r y) where - a :~> b = rulePair r 0 - vs = IS.toList (getMetaVars a `IS.union` getMetaVars b) + a :~> b = ruleSpecTerm r + vs = IS.toList (metaVarSet a `IS.union` metaVarSet b) sub = listToSubst $ zip vs [ Var [c] | c <- ['a' ..] ] - - fromTermTp :: IsTerm a => RewriteRule a -> Term -> Maybe a - fromTermTp _ = fromTerm ----------------------------------------------------------- -- Smart generator that creates instantiations of the left-hand side smartGenerator :: RewriteRule a -> Gen a -smartGenerator r@(R _ _ _) = do - let a :~> _ = rulePair r 0 - let vs = IS.toList (getMetaVars a) - list <- vector (length vs) - let sub = listToSubst (zip vs (map (tpToTerm r) list)) - case fromTerm (sub |-> a) of - Just a -> return a - Nothing -> arbitrary - where - tpToTerm :: IsTerm a => RewriteRule a -> a -> Term - tpToTerm _ = toTerm +smartGenerator r = do + let a :~> _ = ruleSpecTerm r + let vs = IS.toList (metaVarSet a) + list <- replicateM (length vs) (ruleGenerator r) + let sub = listToSubst (zip vs (map (toTermRR r) list)) + case fromTermRR r (sub |-> a) of + Just x -> return x + Nothing -> ruleGenerator r ------------------------------------------------------ --- Bug fix 4/3/2009: for associative operators, we need to extend rewrite --- rules to take "contexts" into account. In addition to a left and a right --- context, we also should consider a context on both sides. If not, we --- might miss some locations, as pointed out by Josje's bug report. -extendContext :: [Symbol] -> RewriteRule a -> [RewriteRule a] -extendContext ops r@(R _ _ _) = - case getSpine (lhs $ rulePair r 0) of - (Con s, [_, _]) | s `elem` ops -> r : - [ extend (leftContext s) r - , extend (rightContext s) r - , extend (rightContext s) (extend (leftContext s) r) - ] - _ -> [r] +inverseRule :: RewriteRule a -> RewriteRule a +inverseRule r = r {ruleSpecTerm = b :~> a} + where a :~> b = ruleSpecTerm r + +useOperators :: [Magma a] -> RewriteRule a -> RewriteRule a +useOperators xs r = r {ruleOperators = xs ++ ruleOperators r} + +-- some helpers +metaInRewriteRule :: RewriteRule a -> [Int] +metaInRewriteRule r = + [ n | a <- crush (ruleSpecTerm r), Meta n <- leafs a ] + +renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a +renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)} where - lhs (a :~> _) = a - - leftContext s a (x :~> y) = - binary s a x :~> binary s a y + f (Meta i) = Meta (i+n) + f term = descend f term - rightContext s a (x :~> y) = - binary s x a :~> binary s y a +toTermRR :: RewriteRule a -> a -> Term +toTermRR = build . ruleTermView -extend :: (Term -> RuleSpec Term -> RuleSpec Term) -> RewriteRule a -> RewriteRule a -extend f (R s n g) = R s (n+1) (\i -> f (Meta (i+n)) (g i)) +fromTermRR :: Monad m => RewriteRule a -> Term -> m a +fromTermRR = matchM . ruleTermView 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 @@ -8,75 +8,66 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Substitutions +-- Substitutions on terms -- ----------------------------------------------------------------------------- module Common.Rewriting.Substitution - ( Substitution, emptySubst, singletonSubst, listToSubst, (@@), (@@@) - , lookupVar, dom, removeDom, ran, (|->) + ( Substitution, emptySubst, singletonSubst, dom + , (@@), (@@@), (|->), listToSubst ) where import Common.Uniplate -import Common.Rewriting.MetaVar +import Common.Rewriting.Term import qualified Data.IntMap as IM -import qualified Data.IntSet as IS import Data.Maybe ----------------------------------------------------------- --- Substitution -- | Abstract data type for substitutions -newtype Substitution a = S { unS :: IM.IntMap a } +newtype Substitution = S { unS :: IM.IntMap Term } infixr 4 |-> infixr 5 @@, @@@ -instance Show a => Show (Substitution a) where +instance Show Substitution where show = show . unS -- | Returns the empty substitution -emptySubst :: (Uniplate a, MetaVar a) => Substitution a +emptySubst :: Substitution emptySubst = S IM.empty -- | Returns a singleton substitution -singletonSubst :: (MetaVar a, Uniplate a) => Int -> a -> Substitution a +singletonSubst :: Int -> Term -> Substitution singletonSubst i a = S (IM.singleton i a) -- | Turns a list into a substitution -listToSubst :: (Uniplate a, MetaVar a) => [(Int, a)] -> Substitution a +listToSubst :: [(Int, Term)] -> Substitution listToSubst = S . IM.fromListWith (error "Substitution: keys are not unique") -- | Combines two substitutions. The left-hand side substitution is first applied to -- the co-domain of the right-hand side substitution -(@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a +(@@) :: Substitution -> Substitution -> Substitution S a @@ S b = S $ a `IM.union` IM.map (S a |->) b -- | Combines two substitutions with disjoint domains. If the domains are not disjoint, -- an error is reported -(@@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a +(@@@) :: Substitution -> Substitution -> Substitution S a @@@ S b = S (IM.unionWith err a b) where err _ _ = error "Unification.(@@@): domains of substitutions are not disjoint" -- | Lookups a variable in a substitution. Nothing indicates that the variable is -- not in the domain of the substitution -lookupVar :: Int -> Substitution a -> Maybe a +lookupVar :: Int -> Substitution -> Maybe Term lookupVar s = IM.lookup s . unS -- | Returns the domain of a substitution (as a list) -dom :: Substitution a -> IS.IntSet -dom = IM.keysSet . unS - --- | Removes variables from the domain of a substitution -removeDom :: IS.IntSet -> Substitution a -> Substitution a -removeDom s (S a) = S (IM.filterWithKey (\k _ -> IS.member k s) a) - -ran :: Substitution a -> [a] -ran = IM.elems . unS +dom :: Substitution -> [Int] +dom = IM.keys . unS -- | Apply the substitution -(|->) :: (MetaVar a, Uniplate a) => Substitution a -> a -> a -s |-> e = - case isMetaVar e of - Just i -> fromMaybe e (lookupVar i s) - Nothing -> let (cs, f) = uniplate e - in f (map (s |->) cs) +(|->) :: Substitution -> Term -> Term +s |-> term = + case term of + Meta i -> fromMaybe term (lookupVar i s) + _ -> descend (s |->) term diff --git a/src/Common/Rewriting/Term.hs b/src/Common/Rewriting/Term.hs --- a/src/Common/Rewriting/Term.hs +++ b/src/Common/Rewriting/Term.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -12,46 +12,71 @@ -- A simple data type for term rewriting -- ----------------------------------------------------------------------------- -module Common.Rewriting.Term where +module Common.Rewriting.Term + ( Term(..), IsTerm(..) + , Symbol, newSymbol + , fromTermM, fromTermWith + , getSpine, makeTerm + -- * Functions and symbols + , WithFunctions(..), isSymbol, isFunction + , unary, binary, isUnary, isBinary + -- * Variables + , WithVars(..), isVariable + , vars, varSet, hasVar, withoutVar, hasSomeVar, hasNoVar + -- * Meta variables + , WithMetaVars(..), isMetaVar + , metaVars, metaVarSet, hasMetaVar + ) where +import Common.Id import Common.Utils (ShowString(..)) import Common.Uniplate +import Common.View import Control.Monad -import Common.Rewriting.MetaVar +import Data.Maybe import Data.Typeable +import qualified Data.IntSet as IS +import qualified Data.Set as S ----------------------------------------------------------- -- * Data type for terms -data Symbol = S (Maybe String) String - deriving (Eq, Ord) - data Term = Var String | Con Symbol - | App Term Term + | Apply Term Term | Num Integer | Float Double | Meta Int deriving (Show, Eq, Ord, Typeable) + +instance Uniplate Term where + uniplate (Apply f a) = ([f, a], \[g, b] -> Apply g b) + uniplate term = ([], \_ -> term) +newtype Symbol = S Id + deriving (Eq, Ord) + instance Show Symbol where - show (S ma b) = maybe b (\a -> a++ "." ++ b) ma + show = showId -instance MetaVar Term where - metaVar = Meta - isMetaVar (Meta n) = Just n - isMetaVar _ = Nothing - -instance Uniplate Term where - uniplate (App f a) = ([f,a], \[g,b] -> App g b) - uniplate term = ([], \_ -> term) +instance HasId Symbol where + getId (S a) = a + changeId f (S a) = S (f a) +newSymbol :: IsId a => a -> Symbol +newSymbol = S . newId + ----------------------------------------------------------- -- * Type class for conversion to/from terms class IsTerm a where toTerm :: a -> Term fromTerm :: MonadPlus m => Term -> m a + termView :: View Term a + -- default definitions + toTerm = build termView + fromTerm = matchM termView + termView = makeView fromTerm toTerm instance IsTerm Term where toTerm = id @@ -72,51 +97,127 @@ fromTermM = maybe (fail "fromTermM") return . fromTerm fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a -fromTermWith f a = - case getSpine a of - (t, xs) -> isCon t >>= \s -> mapM fromTermM xs >>= f s +fromTermWith f a = do + (s, xs) <- getFunction a + ys <- mapM fromTermM xs + f s ys ----------------------------------------------------------- --- * Utility functions +-- * Functions and symbols -getSpine :: Term -> (Term, [Term]) -getSpine = rec [] - where - rec xs (App f a) = rec (a:xs) f - rec xs a = (a, xs) +class WithFunctions a where + -- constructing + symbol :: Symbol -> a + function :: Symbol -> [a] -> a + -- matching + getSymbol :: Monad m => a -> m Symbol + getFunction :: Monad m => a -> m (Symbol, [a]) + -- default definition + symbol s = function s [] + getSymbol a = + case getFunction a of + Just (t, []) -> return t + _ -> fail "Common.Term.getSymbol" + +instance WithFunctions Term where + function = makeTerm . Con + getFunction a = + case getSpine a of + (Con s, xs) -> return (s, xs) + _ -> fail "Common.Rewriting.getFunction" + +isSymbol :: WithFunctions a => Symbol -> a -> Bool +isSymbol s = maybe False (==s) . getSymbol -getConSpine :: Monad m => Term -> m (Symbol, [Term]) -getConSpine a = liftM (\s -> (s, xs)) (isCon b) - where (b, xs) = getSpine a +isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a] +isFunction s a = + case getFunction a of + Just (t, as) | s == t -> return as + _ -> fail "Common.Term.isFunction" -makeTerm :: Term -> [Term] -> Term -makeTerm = foldl App +unary :: WithFunctions a => Symbol -> a -> a +unary s a = function s [a] -makeConTerm :: Symbol -> [Term] -> Term -makeConTerm = makeTerm . Con +binary :: WithFunctions a => Symbol -> a -> a -> a +binary s a b = function s [a, b] -unary :: Symbol -> Term -> Term -unary = App . Con +isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a +isUnary s a = + case isFunction s a of + Just [x] -> return x + _ -> fail "Common.Term.isUnary" -binary :: Symbol -> Term -> Term -> Term -binary s = App . App (Con s) +isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) +isBinary s a = + case isFunction s a of + Just [x, y] -> return (x, y) + _ -> fail "Common.Term.isBinary" -isUnary :: Symbol -> Term -> Maybe Term -isUnary s term = - case getSpine term of - (t, [a]) | isCon t == Just s -> Just a - _ -> Nothing +----------------------------------------------------------- +-- * Variables -isBinary :: Symbol -> Term -> Maybe (Term, Term) -isBinary s term = - case getSpine term of - (t, [a, b]) | isCon t == Just s -> Just (a, b) - _ -> Nothing +class WithVars a where + variable :: String -> a + getVariable :: Monad m => a -> m String -isVar :: Monad m => Term -> m String -isVar (Var s) = return s -isVar _ = fail "isVar" +instance WithVars Term where + variable = Var + getVariable (Var s) = return s + getVariable _ = fail "Common.Rewriting.getVariable" -isCon :: Monad m => Term -> m Symbol -isCon (Con s) = return s -isCon _ = fail "isCon" +isVariable :: WithVars a => a -> Bool +isVariable = isJust . getVariable + +vars :: (Uniplate a, WithVars a) => a -> [String] +vars = concatMap getVariable . leafs + +varSet :: (Uniplate a, WithVars a) => a -> S.Set String +varSet = S.fromList . vars + +hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool +hasVar i = (i `elem`) . vars + +withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool +withoutVar i = not . hasVar i + +hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool +hasSomeVar = not . hasNoVar + +hasNoVar :: (Uniplate a, WithVars a) => a -> Bool +hasNoVar = null . vars + +----------------------------------------------------------- +-- * Meta variables + +class WithMetaVars a where + metaVar :: Int -> a + getMetaVar :: Monad m => a -> m Int + +instance WithMetaVars Term where + metaVar = Meta + getMetaVar (Meta i) = return i + getMetaVar _ = fail "Common.Rewriting.getMetaVar" + +isMetaVar :: WithMetaVars a => a -> Bool +isMetaVar = isJust . getMetaVar + +metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int] +metaVars = concatMap getMetaVar . leafs + +metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet +metaVarSet = IS.fromList . metaVars + +hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool +hasMetaVar i = (i `elem`) . metaVars + +----------------------------------------------------------- +-- * Utility functions + +getSpine :: Term -> (Term, [Term]) +getSpine = rec [] + where + rec xs (Apply f a) = rec (a:xs) f + rec xs a = (a, xs) + +makeTerm :: Term -> [Term] -> Term +makeTerm = foldl Apply 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 @@ -9,18 +9,35 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Common.Rewriting.Unification (match, Matcher, associativeMatcher) where +module Common.Rewriting.Unification + ( match, unifyM, specialLeft, specialRight + ) where import Common.Rewriting.Term import Common.Rewriting.AC -import Common.Rewriting.MetaVar import Common.Rewriting.Substitution import Control.Monad -import qualified Data.IntSet as IS -import qualified Data.Map as M ----------------------------------------------------------- -- Unification (in both ways) + +unifyM :: Monad m => Term -> Term -> m Substitution +unifyM term1 term2 = + case (term1, term2) of + (Meta i, Meta j) | i == j -> + return emptySubst + (Meta i, _) | not (i `hasMetaVar` term2) -> + return (singletonSubst i term2) + (_, Meta j) | not (j `hasMetaVar` term1) -> + return (singletonSubst j term1) + (Apply f a, Apply g b) -> do + s1 <- unifyM f g + s2 <- unifyM (s1 |-> a) (s1 |-> b) + return (s1 @@ s2) + _ | term1 == term2 -> + return emptySubst + _ -> fail "unifyM: no unifier" + {- class ShallowEq a where shallowEq :: a -> a -> Bool @@ -66,51 +83,56 @@ ----------------------------------------------------------- -- Matching (or: one-way unification) -match :: Matcher -> Term -> Term -> [Substitution Term] -match m x y = do - s <- rec x y - guard (IS.null $ dom s `IS.intersection` getMetaVars y) - return s +-- second term should not have meta variables + +match :: [Symbol] -> Term -> Term -> [Substitution] +match assocSymbols = rec True where - rec (Meta i) y = do - guard (not (hasMetaVar i y)) + rec _ (Meta i) y = return (singletonSubst i y) - rec x y = do - let (a, as) = getSpine x - (b, bs) = getSpine y - case isCon a >>= (`M.lookup` m) of - Just f -> - concatMap (uncurry recList . unzip) (f x y) - Nothing -> do + rec isTop x y = + case getSpine x of + (Con s, [a1, a2]) | s `elem` assocSymbols -> + concatMap (uncurry recList . unzip) (associativeMatch isTop s a1 a2 y) + (a, as) -> do + let (b, bs) = getSpine y guard (a == b) recList as bs recList [] [] = return emptySubst recList (x:xs) (y:ys) = do - s1 <- rec x y + s1 <- rec False x y s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) - return (s2 @@ s1) + return (s2 @@@ s1) recList _ _ = [] - -type Matcher = M.Map Symbol (Term -> Term -> [[(Term, Term)]]) - -associativeMatcher :: Symbol -> Matcher -associativeMatcher s = M.singleton s f + +associativeMatch :: Bool -> Symbol -> Term -> Term -> Term -> [[(Term, Term)]] +associativeMatch isTop s1 a1 a2 (Apply (Apply (Con s2) b1) b2) + | s1==s2 = map (map make) result where - f a b = map (map make) result - where - (as, bs) = onBoth collect (a, b) - result = pairingsA2 True as bs - make = onBoth construct + as = collect a1 . collect a2 $ [] + bs = collect b1 . collect b2 $ [] + list | isTop = map ($ as) [id, extLeft, extRight, extBoth] + | otherwise = [as] + + extLeft = (Meta specialLeft:) + extRight = (++[Meta specialRight]) + extBoth = extLeft . extRight - collect = ($ []) . rec - where - rec term = - case isBinary s term of - Just (a, b) -> rec a . rec b - Nothing -> (term:) + result = concatMap (\zs -> pairingsA True zs bs) list + make (a, b) = (construct a, construct b) + collect term = + case getFunction term of + Just (t, [a, b]) | s1==t -> collect a . collect b + _ -> (term:) + construct xs | null xs = error "associativeMatcher: empty list" - | otherwise = foldr1 (binary s) xs + | otherwise = foldr1 (binary s1) xs +associativeMatch _ _ _ _ _ = [] + +specialLeft, specialRight :: Int -- special meta variables for context extension +specialLeft = maxBound +specialRight = pred specialLeft diff --git a/src/Common/Strategy.hs b/src/Common/Strategy.hs --- a/src/Common/Strategy.hs +++ b/src/Common/Strategy.hs @@ -16,30 +16,31 @@ ----------------------------------------------------------------------------- module Common.Strategy ( -- * Data types and type classes - Strategy, LabeledStrategy, strategyName + Strategy, LabeledStrategy , IsStrategy(..) -- * Running strategies , fullDerivationTree, derivationTree -- * Strategy combinators -- ** Basic combinators - , (<*>), (<|>), succeed, fail, label, sequence, alternatives -- <||> + , (<*>), (<|>), succeed, fail, label, sequence, alternatives -- ** EBNF combinators , many, many1, replicate, option -- ** Negation and greedy combinators , check, not, repeat, repeat1, try, (|>), exhaustive + , while, until, multi -- ** Traversal combinators , fix, once, somewhere, topDown, bottomUp + , onceWith, somewhereWith -- * Configuration combinators , module Common.Strategy.Configuration -- * Strategy locations - , StrategyLocation, topLocation, nextLocation, downLocation - , locationDepth - , subTaskLocation, nextTaskLocation, parseStrategyLocation - , StrategyOrRule, subStrategy, strategyLocations - , mapRules, mapRulesS, rulesInStrategy, cleanUpStrategy + , strategyLocations, subStrategy + , subTaskLocation, nextTaskLocation -- * Prefixes , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..) , prefixToSteps, stepsToRules, lastStepInPrefix + -- * Misc + , cleanUpStrategy, rulesInStrategy, mapRules, mapRulesS ) where import Common.Strategy.Abstract @@ -47,5 +48,5 @@ import Common.Strategy.Prefix import Common.Strategy.Location import Common.Strategy.Configuration - -import qualified Prelude () +import Common.Strategy.Parsing +import Prelude () diff --git a/src/Common/Strategy/Abstract.hs b/src/Common/Strategy/Abstract.hs --- a/src/Common/Strategy/Abstract.hs +++ b/src/Common/Strategy/Abstract.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XFlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -16,20 +16,21 @@ , fullDerivationTree, derivationTree, rulesInStrategy , mapRules, mapRulesS, cleanUpStrategy -- Accessors to the underlying representation - , toCore, fromCore, liftCore, liftCore2, fixCore, makeLabeledStrategy + , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy , toLabeledStrategy - , LabelInfo, strategyName, processLabelInfo, changeInfo, makeInfo - , removed, collapsed, hidden, labelName, IsLabeled(..) + , LabelInfo, processLabelInfo, changeInfo, makeInfo + , removed, collapsed, hidden, IsLabeled(..) ) where +import Common.Id import Common.Utils (commaList) import Common.Strategy.Core -import Common.Strategy.BiasedChoice -import Common.Apply -import Common.Rewriting (RewriteRule(..)) +import Common.Classes +import Common.Rewriting (RewriteRule) import Common.Transformation import Common.Derivation -import Common.Uniplate +import Common.Uniplate hiding (rewriteM) +import Common.Strategy.Parsing ----------------------------------------------------------- --- Strategy data-type @@ -41,13 +42,13 @@ show = show . toCore instance Apply Strategy where - applyAll s = results . fullDerivationTree s + applyAll = runCore . toCore ----------------------------------------------------------- --- The information used as label in a strategy data LabelInfo = Info - { labelName :: String + { labelId :: Id , removed :: Bool , collapsed :: Bool , hidden :: Bool @@ -59,16 +60,20 @@ ["collapsed" | collapsed info] ++ ["hidden" | hidden info] extra = " (" ++ commaList ps ++ ")" - in show (labelName info) ++ if null ps then "" else extra + in showId info ++ if null ps then "" else extra -makeInfo :: String -> LabelInfo -makeInfo s = Info s False False False +instance HasId LabelInfo where + getId = labelId + changeId f info = info { labelId = f (labelId info) } + +makeInfo :: IsId a => a -> LabelInfo +makeInfo s = Info (newId s) False False False ----------------------------------------------------------- --- Type class -- | Type class to turn values into strategies -class Apply f => IsStrategy f where +class IsStrategy f where toStrategy :: f a -> Strategy a instance IsStrategy (Core LabelInfo) where @@ -78,20 +83,16 @@ toStrategy = id instance IsStrategy (LabeledStrategy) where - toStrategy (LS info (S core)) = - case core of - Rule Nothing r | name r == labelName info -> - S (Rule (Just info) r) - _ -> S (Label info core) + toStrategy (LS info (S core)) = S (Label info core) -instance IsStrategy Rule where -- Major rules receive a label +instance IsStrategy Rule where toStrategy r | isMajorRule r = toStrategy (toLabeled r) - | otherwise = S (Rule Nothing r) + | otherwise = S (Rule r) instance IsStrategy RewriteRule where toStrategy r = - toStrategy (makeRule (ruleName r) (RewriteRule r)) + toStrategy (makeRule (getId r) (makeRewriteTrans r)) ----------------------------------------------------------- --- Labeled Strategy data-type @@ -111,15 +112,16 @@ Label l c -> return (makeLabeledStrategy l (fromCore c)) _ -> fail "Strategy without label" -strategyName :: LabeledStrategy a -> String -strategyName = getLabel - instance Show (LabeledStrategy a) where show s = show (labelInfo s) ++ ": " ++ show (unlabel s) instance Apply LabeledStrategy where applyAll = applyAll . toStrategy +instance HasId (LabeledStrategy a) where + getId = getId . labelInfo + changeId = changeInfo . changeId + class IsLabeled f where toLabeled :: f a -> LabeledStrategy a @@ -127,18 +129,15 @@ toLabeled = id instance IsLabeled Rule where - toLabeled r = LS (makeInfo (name r)) (S (Rule Nothing r)) + toLabeled r = LS (makeInfo (showId r)) (S (Rule r)) instance IsLabeled RewriteRule where - toLabeled r = toLabeled (makeRule (ruleName r) (RewriteRule r)) + toLabeled r = toLabeled (makeRule (showId r) (makeRewriteTrans r)) -- | Labels a strategy with a string -label :: IsStrategy f => String -> f a -> LabeledStrategy a +label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a label l = LS (makeInfo l) . toStrategy -getLabel :: IsLabeled f => f a -> String -getLabel = labelName . labelInfo . toLabeled - changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a changeInfo f a = LS (f info) s where LS info s = toLabeled a @@ -147,42 +146,45 @@ --- Process Label Information processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a -processLabelInfo getInfo = mapCore forLabel forRule +processLabelInfo getInfo = rec emptyCoreEnv where - forLabel l c + rec env core = + case core of + Rec n a -> Rec n (rec (insertCoreEnv n core env) a) + Label l a -> forLabel env l (rec env a) + _ -> descend (rec env) core + + forLabel env l c | removed info = Fail - | collapsed info = Rule (Just l) asRule + | collapsed info = Label l (Rule asRule) -- !! | otherwise = new where new | hidden info = mapRule minorRule (Label l c) | otherwise = Label l c info = getInfo l - asRule = makeSimpleRuleList (labelName info ++ " (collapsed)") (applyAll new) - forRule (Just l) r - | removed info = Fail - | hidden info = Rule (Just l) (minorRule r) - | otherwise = Rule (Just l) r - where - info = getInfo l - forRule _ r = Rule Nothing r + asRule = makeSimpleRuleList (showId info{- ++ " (collapsed)"-}) + (runCoreWith env new) ----------------------------------------------------------- --- Remaining functions -- | Returns the derivation tree for a strategy and a term, including all -- minor rules -fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a -fullDerivationTree = makeBiasedTree p . processLabelInfo id . toCore . toStrategy +fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a +fullDerivationTree = make . processLabelInfo id . toCore . toStrategy where - p t = endpoint t || any isMajorRule (annotations t) || any p (subtrees t) - + make core = fmap value . parseDerivationTree . makeState core + -- | Returns the derivation tree for a strategy and a term with only major rules derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a -derivationTree s = mergeSteps isMajorRule . fullDerivationTree s - +derivationTree s = mergeMaybeSteps . mapSteps f . fullDerivationTree s + where + f (RuleStep r) | isMajorRule r = Just r + f _ = Nothing + -- | Returns a list of all major rules that are part of a labeled strategy rulesInStrategy :: IsStrategy f => f a -> [Rule a] -rulesInStrategy f = [ r | Rule _ r <- universe (toCore (toStrategy f)), isMajorRule r ] +rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajorRule r ] -- | Apply a function to all the rules that make up a labeled strategy mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b @@ -195,7 +197,7 @@ cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a cleanUpStrategy f (LS n s) = mapRules g (LS n (S core)) where - core = Rule Nothing (doAfter f idRule) :*: toCore s + core = Rule (doAfter f idRule) :*: toCore s g r | isMajorRule r = doAfter f r | otherwise = r @@ -210,9 +212,3 @@ liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a liftCore2 f = liftCore . f . toCore . toStrategy - -fixCore :: (Core l a -> Core l a) -> Core l a -fixCore f = Rec i (f (Var i)) -- disadvantage: function f is applied twice - where - s = coreVars (f (Rule Nothing idRule)) - i = if null s then 0 else maximum s + 1 diff --git a/src/Common/Strategy/BiasedChoice.hs b/src/Common/Strategy/BiasedChoice.hs deleted file mode 100644 --- a/src/Common/Strategy/BiasedChoice.hs +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Strategy.BiasedChoice - ( Bias(..), placeBiasLabels, biasTreeG, makeBiasedTree - ) where - -import Common.Apply --- import Common.View -import Common.Derivation -import Common.Transformation -import Common.Strategy.Core --- import Common.Uniplate - -data Bias f a = TryFirst BiasId | OrElse BiasId | Normal (f a) deriving Show -type BiasId = Int - -instance Apply f => Apply (Bias f) where - applyAll (Normal r) = applyAll r - applyAll _ = return - --- Disabled! -placeBiasLabels :: Core l a -> Core (Either (Bias f a) l) a -placeBiasLabels = {-fst . rec 0 . -}mapLabel Right - where {- - -- Left-biased choice - rec n (a :|>: b) = - let (ra, n1) = rec n a - (rb, n2) = rec n1 b - left = Label (Left (TryFirst n)) ra - right = Label (Left (OrElse n)) rb - in (left :|: right, n2) - -- All other cases - rec n core = - let (cs, f) = uniplate core - in first f (recList n cs) - - recList n [] = ([], n) - recList n (x:xs) = - let (a, n1) = rec n x - (as, n2) = recList n1 xs - in (a:as, n2) -} - -biasTranslation :: (Rule a -> f a) -> Translation (Either (Bias f a) l) a (Bias f a) -biasTranslation f = (either Before (const Skip), Normal . f) - -biasTreeG :: (DerivationTree (f a, info) a -> Bool) -> DerivationTree (Bias f a, info) a -> DerivationTree (f a, info) a -biasTreeG success t = t {branches = f [] (branches t)} - where - f _ [] = [] - f env (((bias, info), st):xs) = - case bias of - TryFirst n - | success new -> branches new ++ f (n:env) xs - | otherwise -> f env xs - where new = biasTreeG success st - OrElse n - | n `elem` env -> f env xs - | otherwise -> branches (biasTreeG success st) ++ f env xs - Normal r -> ((r, info), biasTreeG success st):f env xs - --- success :: DerivationTree s a -> Bool --- success = isJust . derivation - -biasTree :: (DerivationTree (f a) a -> Bool) -> DerivationTree (Bias f a) a -> DerivationTree (f a) a -biasTree success t = t {branches = f [] (branches t)} - where - f _ [] = [] - f env ((bias, st):xs) = - case bias of - TryFirst n - | success new -> branches new ++ f (n:env) xs - | otherwise -> f env xs - where new = biasTree success st - OrElse n - | n `elem` env -> f env xs - | otherwise -> branches (biasTree success st) ++ f env xs - Normal r -> (r, biasTree success st):f env xs -{- - success :: DerivationTree s a -> Bool - success = isJust . derivation -} - -makeBiasedTree :: (DerivationTree (Rule a) a -> Bool) -> Core l a -> a -> DerivationTree (Rule a) a -makeBiasedTree p core = - biasTree p . changeLabel fst . runTree (strategyTree (biasTranslation id) (placeBiasLabels core)) - -------------------------- -{- -test = makeBiasedTree (maybe False (const True) . derivation) myCore 5 - -myCore = (r1 :|>: r2) :|: (r3 :|>: r4) - where - r1 = make "r1" $ \n -> trace "**1**" [n*n] - r2 = make "r2" $ \n -> trace "**2**" [n+1] - r3 = make "r3" $ \n -> trace "**3**" [n*2] - r4 = make "r4" $ \n -> trace "**4**" [n `div` 2] - trace _ = id - make n = Rule Nothing . minorRule . makeSimpleRuleList n -} diff --git a/src/Common/Strategy/Combinators.hs b/src/Common/Strategy/Combinators.hs --- a/src/Common/Strategy/Combinators.hs +++ b/src/Common/Strategy/Combinators.hs @@ -14,12 +14,16 @@ ----------------------------------------------------------------------------- module Common.Strategy.Combinators where +import qualified Prelude import Prelude hiding (not, repeat, fail, sequence) +import Common.Id import Common.Context import Common.Navigator import Common.Transformation import Common.Strategy.Core import Common.Strategy.Abstract +import Common.Strategy.Configuration +import Data.Maybe ----------------------------------------------------------- --- Strategy combinators @@ -32,11 +36,21 @@ -- | Put two strategies in sequence (first do this, then do that) (<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<*>) = liftCore2 (:*:) +(<*>) = liftCore2 $ \x y -> + case (x, y) of + (Succeed, _) -> y + (_, Succeed) -> x + (Fail, _) -> Fail + (_, Fail) -> Fail + _ -> x :*: y -- | Choose between the two strategies (either do this or do that) (<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<|>) = liftCore2 (:|:) +(<|>) = liftCore2 $ \x y -> + case (x, y) of + (Fail, _) -> y + (_, Fail) -> x + _ -> x :|: y -- | The strategy that always succeeds (without doing anything) succeed :: Strategy a @@ -101,6 +115,18 @@ (|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a (|>) = liftCore2 (:|>:) +-- | Repeat the strategy as long as the predicate holds +while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a +while p s = repeat (check p <*> s) + +-- | Repeat the strategy until the predicate holds +until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a +until p = while (Prelude.not . p) + +-- | Apply a strategy at least once, but collapse into a single step +multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a +multi s = collapse . label s . repeat1 + -- | Apply the strategies from the list exhaustively (until this is no longer possible) exhaustive :: IsStrategy f => [f a] -> Strategy a exhaustive = repeat . alternatives @@ -110,19 +136,35 @@ -- | A fix-point combinator on strategies (to model recursion). Powerful -- (but dangerous) combinator fix :: (Strategy a -> Strategy a) -> Strategy a -fix f = fromCore (fixCore (toCore . f . fromCore)) +fix f = fromCore (coreFix (toCore . f . fromCore)) +-- | Apply a strategy on (exactly) one of the term's direct children. The +-- function selects which children are visited. +onceWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a) +onceWith n f s = ruleMoveDown <*> s <*> ruleMoveUp + where + ruleMoveDown = minorRule $ makeSimpleRuleList ("navigation.down." ++ n) $ \a -> + concatMap (`down` a) (f a) + ruleMoveUp = minorRule $ makeSimpleRule "navigation.up" $ \a -> + Just (fromMaybe a (up a)) + +-- | Apply a strategy somewhere in the term. The function selects which +-- children are visited +somewhereWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a) +somewhereWith n f s = fix $ \this -> s <|> onceWith n f this + -- | Apply a strategy on (exactly) one of the term's direct children once :: IsStrategy f => f (Context a) -> Strategy (Context a) -once s = ruleMoveDown <*> s <*> ruleMoveUp - where - ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" allDowns - ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" up +once = onceWith "all" visitAll -- | Apply a strategy somewhere in the term somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a) -somewhere s = fix $ \this -> s <|> once this +somewhere = somewhereWith "all" visitAll +-- local helper +visitAll :: Context a -> [Int] +visitAll a = [ 0 .. arity a-1 ] + -- | Search for a suitable location in the term to apply the strategy using a -- top-down approach topDown :: IsStrategy f => f (Context a) -> Strategy (Context a) @@ -131,8 +173,4 @@ -- | Search for a suitable location in the term to apply the strategy using a -- bottom-up approach bottomUp :: IsStrategy f => f (Context a) -> Strategy (Context a) -bottomUp s = fix $ \this -> once this <|> (not (once (bottomUp s)) <*> s) - -{- The ideal implementation does not yet work: there appears to be a strange - interplay between the fixpoint operator (with variables) and the not combinator - > bottomUp s = fix $ \this -> once this |> s -} +bottomUp s = fix $ \this -> once this |> s diff --git a/src/Common/Strategy/Configuration.hs b/src/Common/Strategy/Configuration.hs --- a/src/Common/Strategy/Configuration.hs +++ b/src/Common/Strategy/Configuration.hs @@ -12,17 +12,18 @@ module Common.Strategy.Configuration ( -- Types and constructors StrategyConfiguration, ConfigItem - , ConfigLocation(..), ConfigAction(..), configActions + , ConfigLocation, byName, byGroup + , ConfigAction(..), configActions -- Configure - , configure + , configure, configureNow -- Combinators , remove, reinsert, collapse, expand, hide, reveal ) where +import Common.Id import Common.Strategy.Abstract import Common.Strategy.Core -import Common.Strategy.Location -import Common.Transformation +import Data.Maybe --------------------------------------------------------------------- -- Types and constructors @@ -31,9 +32,8 @@ type ConfigItem = (ConfigLocation, ConfigAction) data ConfigLocation - = ByName String - | ByGroup String - | ByLocation StrategyLocation + = ByName Id + | ByGroup Id deriving Show data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal @@ -42,31 +42,39 @@ configActions :: [ConfigAction] configActions = [Remove .. ] +byName :: HasId a => a -> ConfigLocation +byName = ByName . getId + +byGroup :: HasId a => a -> ConfigLocation +byGroup = ByGroup . getId + --------------------------------------------------------------------- -- Configure +configureNow :: LabeledStrategy a -> LabeledStrategy a +configureNow = + let lsToCore = toCore . toStrategy + coreToLS = fromMaybe err . toLabeledStrategy . toStrategy + err = error "configureNow: label disappeared" + in coreToLS . processLabelInfo id . lsToCore + configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a configure cfg ls = - label (strategyName ls) (configureCore cfg (toCore (unlabel ls))) + label (showId ls) (configureCore cfg (toCore (unlabel ls))) configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a -configureCore cfg = mapCore f g . addLocation +configureCore cfg = mapLabel (change []) where - f pair a = Label (change pair []) a - g (Just pair) r = Rule (Just (change pair (ruleGroups r))) r - g Nothing r = Rule Nothing r - - change pair@(_, info) groups = - let actions = getActions pair groups cfg + change groups info = + let actions = getActions info groups cfg in foldr doAction info actions -getActions :: (StrategyLocation, LabelInfo) -> [String] +getActions :: LabelInfo -> [String] -> StrategyConfiguration -> [ConfigAction] -getActions (loc, info) groups = map snd . filter (select . fst) +getActions info groups = map snd . filter (select . fst) where - select (ByName s) = labelName info == s - select (ByGroup s) = s `elem` groups - select (ByLocation l) = loc == l + select (ByName a) = getId info == a + select (ByGroup s) = showId s `elem` groups doAction :: ConfigAction -> LabelInfo -> LabelInfo doAction action = diff --git a/src/Common/Strategy/Core.hs b/src/Common/Strategy/Core.hs --- a/src/Common/Strategy/Core.hs +++ b/src/Common/Strategy/Core.hs @@ -15,18 +15,15 @@ ----------------------------------------------------------------------------- module Common.Strategy.Core ( Core(..) - , strategyTree, runTree --, makeTree - , mapRule, coreVars, noLabels, mapCore, mapCoreM --, catMaybeLabel --, , - , mapLabel, Translation, ForLabel(..) --, simpleTranslation + , mapRule, mapLabel, noLabels + , coreMany, coreRepeat, coreOrElse, coreFix + , CoreEnv, emptyCoreEnv, insertCoreEnv, lookupCoreEnv, substCoreEnv ) where -import qualified Common.Strategy.Grammar as Grammar -import Common.Strategy.Grammar (Grammar, (<*>), (<|>), symbol) -import Common.Apply -import Common.Derivation import Common.Transformation import Common.Uniplate -import Control.Monad.Identity +import Data.Maybe +import qualified Data.IntMap as IM ----------------------------------------------------------------- -- Strategy (internal) data structure, containing a selection @@ -42,11 +39,11 @@ | Core l a :|>: Core l a | Many (Core l a) | Repeat (Core l a) - | Not (Core () a) -- proves that there are no labels inside + | Not (Core l a) | Label l (Core l a) | Succeed | Fail - | Rule (Maybe l) (Rule a) + | Rule (Rule a) | Var Int | Rec Int (Core l a) deriving Show @@ -54,9 +51,6 @@ ----------------------------------------------------------------- -- Useful instances -instance Apply (Core l) where - applyAll core = results . makeTree core - instance Uniplate (Core l a) where uniplate core = case core of @@ -67,118 +61,91 @@ Repeat a -> ([a], \[x] -> Repeat x) Label l a -> ([a], \[x] -> Label l x) Rec n a -> ([a], \[x] -> Rec n x) - Not a -> ([noLabels a], \[x] -> Not (noLabels x)) + Not a -> ([a], \[x] -> Not x) _ -> ([], \_ -> core) ----------------------------------------------------------------- --- The strategy tree (static, no term) +-- Core environment -strategyTree :: Translation l a b -> Core l a -> DerivationTree b () -strategyTree t = grammarTree . toGrammar t +newtype CoreEnv l a = CE (IM.IntMap (Core l a)) -grammarTree :: Grammar a -> DerivationTree a () -grammarTree gr = addBranches list node - where - node = singleNode () (Grammar.empty gr) - list = [ (f, grammarTree rest) | (f, rest) <- Grammar.firsts gr ] +emptyCoreEnv :: CoreEnv l a +emptyCoreEnv = CE IM.empty + +insertCoreEnv :: Int -> Core l a -> CoreEnv l a -> CoreEnv l a +insertCoreEnv n a (CE m) = CE (IM.insert n a m) ------------------------------------------------------------------ --- Running a strategy +deleteCoreEnv :: Int -> CoreEnv l a -> CoreEnv l a +deleteCoreEnv n (CE m) = CE (IM.delete n m) -makeTree :: Core l a -> a -> DerivationTree (Rule a) a -makeTree c = changeLabel fst . runTree (strategyTree simpleTranslation c) +lookupCoreEnv :: Int -> CoreEnv l a -> Maybe (Core l a) +lookupCoreEnv n (CE m) = IM.lookup n m -runTree :: Apply f => DerivationTree (f a) info -> a -> DerivationTree (f a, info) a -runTree t a = addBranches list (singleNode a (endpoint t)) - where - list = concatMap make (branches t) - make (f, st) = [ ((f, root st), runTree st b) | b <- applyAll f a ] +substCoreEnv :: CoreEnv l a -> Core l a -> Core l a +substCoreEnv env core = + case core of + Var i -> fromMaybe core (lookupCoreEnv i env) + Rec i a -> Rec i (substCoreEnv (deleteCoreEnv i env) a) + _ -> descend (substCoreEnv env) core ----------------------------------------------------------------- --- Translation to Grammar data type +-- Definitions -type Translation l a b = (l -> ForLabel b, Rule a -> b) +coreMany :: Core l a -> Core l a +coreMany a = Rec n (Succeed :|: (a :*: Var n)) + where n = nextVar a -data ForLabel a = Skip | Before a | After a | Around a a +coreRepeat :: Core l a -> Core l a +coreRepeat a = Many a :*: Not a -simpleTranslation :: Translation l a (Rule a) -simpleTranslation = (const Skip, id) +coreOrElse :: Core l a -> Core l a -> Core l a +coreOrElse a b = a :|: (Not a :*: b) -toGrammar :: Translation l a b -> Core l a -> Grammar b -toGrammar (f, g) = rec - where - rec core = - case core of - a :*: b -> rec a <*> rec b - a :|: b -> rec a <|> rec b - a :|>: b -> rec (a :|: (Not (noLabels a) :*: b)) - Many a -> Grammar.many (rec a) - Repeat a -> rec (Many a :*: Not (noLabels a)) - Succeed -> Grammar.succeed - Fail -> Grammar.fail - Label l a -> forLabel l (rec a) - Rule ml r -> (maybe id forLabel ml) (symbol (g r)) - Var n -> Grammar.var n - Rec n a -> Grammar.rec n (rec a) - Not a -> symbol (g (notRule a)) - - forLabel l g = - case f l of - Skip -> g - Before s -> symbol s <*> g - After t -> g <*> symbol t - Around s t -> symbol s <*> g <*> symbol t +coreFix :: (Core l a -> Core l a) -> Core l a +coreFix f = -- disadvantage: function f is applied twice + let i = nextVar (f (Var (-1))) + in Rec i (f (Var i)) -notRule :: Apply f => f a -> Rule a -notRule f = checkRule (not . applicable f) - +nextVar :: Core l a -> Int +nextVar p + | null xs = 0 + | otherwise = maximum xs + 1 + where xs = coreVars p + +coreVars :: Core l a -> [Int] +coreVars core = + case core of + Var n -> [n] + Rec n a -> n : coreVars a + _ -> concatMap coreVars (children core) + ----------------------------------------------------------------- -- Utility functions mapLabel :: (l -> m) -> Core l a -> Core m a -mapLabel f = mapCore (Label . f) (Rule . fmap f) +mapLabel f = mapCore (Label . f) Rule mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b -mapRule f = mapCore Label (\ml -> Rule ml . f) +mapRule f = mapCore Label (Rule . f) noLabels :: Core l a -> Core m a -noLabels = mapCore (const id) (const (Rule Nothing)) - --- catMaybeLabel :: Core (Maybe l) a -> Core l a --- catMaybeLabel = mapCore (maybe id Label) (Rule . join) +noLabels = mapCore (const id) Rule -mapCore :: (l -> Core m b -> Core m b) -> (Maybe l -> Rule a -> Core m b) +mapCore :: (l -> Core m b -> Core m b) -> (Rule a -> Core m b) -> Core l a -> Core m b -mapCore f g = - let fm l = return . f l . runIdentity - gm l = return . g l - in runIdentity . mapCoreM fm gm - --- The most primitive function that applies functions to the label and --- rule alternatives. Monadic version. -mapCoreM :: Monad m => (k -> m (Core l b) -> m (Core l b)) - -> (Maybe k -> Rule a -> m (Core l b)) - -> Core k a -> m (Core l b) -mapCoreM f g = rec - where +mapCore f g = rec + where rec core = case core of - a :*: b -> liftM2 (:*:) (rec a) (rec b) - a :|: b -> liftM2 (:|:) (rec a) (rec b) - a :|>: b -> liftM2 (:|>:) (rec a) (rec b) - Many a -> liftM Many (rec a) - Repeat a -> liftM Repeat (rec a) - Succeed -> return Succeed - Fail -> return Fail + a :*: b -> rec a :*: rec b + a :|: b -> rec a :|: rec b + a :|>: b -> rec a :|>: rec b + Many a -> Many (rec a) + Repeat a -> Repeat (rec a) + Succeed -> Succeed + Fail -> Fail Label l a -> f l (rec a) - Rule ml r -> g ml r - Var n -> return (Var n) - Rec n a -> liftM (Rec n) (rec a) - Not a -> do - let recNot h = mapCoreM (const id) (const h) - b <- recNot (g Nothing) a - c <- recNot (return . Rule Nothing) b - return (Not c) - -coreVars :: Core l a -> [Int] -coreVars s = [ n | Rec n _ <- universe s ] ++ [ n | Var n <- universe s ] + Rule r -> g r + Var n -> Var n + Rec n a -> Rec n (rec a) + Not a -> Not (rec a) diff --git a/src/Common/Strategy/Grammar.hs b/src/Common/Strategy/Grammar.hs deleted file mode 100644 --- a/src/Common/Strategy/Grammar.hs +++ /dev/null @@ -1,367 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines a set of combinators for context-free grammars. These --- grammars are the basis of the strategies. The fix-point combinator 'fix' --- makes it context-free. The code is based on the RTS'08 paper --- "Recognizing Strategies" --- ------------------------------------------------------------------------------ -module Common.Strategy.Grammar - ( -- * Abstract data type - Grammar - -- * Smart constructor functions - , (<*>), (<|>), (<||>), var, rec, fix, many, succeed, fail, symbol - -- * Elementary operations - , empty, firsts, nonempty - -- * Membership and generated language - , member, language, languageBF - -- * Additional functions - , collectSymbols, join, withIndex - -- * QuickCheck properties - , checks - ) where - -import Common.Uniplate -import Control.Monad (liftM, liftM2) -import Data.List -import Prelude hiding (fail) -import Test.QuickCheck -import qualified Data.Set as S - ----------------------------------------------------------------------- --- Abstract data type - -data Grammar a = Grammar a :*: Grammar a - | Grammar a :|: Grammar a - | Grammar a :||: Grammar a - | Rec Int (Grammar a) - | Symbol a | Var Int | Succeed | Fail deriving Show - -infixr 3 :|:, <|> -infixr 4 :||:, <||> -infixr 5 :*:, <*> - ----------------------------------------------------------------------- --- Smart constructor functions - --- simple constructors -succeed, fail :: Grammar a -var :: Int -> Grammar a -symbol :: a -> Grammar a - -succeed = Succeed -fail = Fail -symbol = Symbol -var = Var - --- | Smart constructor for sequences: removes fails and succeeds in the --- operands -(<*>) :: Grammar a -> Grammar a -> Grammar a -Succeed <*> t = t -s <*> Succeed = s -Fail <*> _ = fail -_ <*> Fail = fail -(s :*: t) <*> u = s :*: (t <*> u) -s <*> t = s :*: t - --- | Smart constructor for alternatives: removes fails in the operands, and --- merges succeeds if present in both arguments -(<|>) :: Grammar a -> Grammar a -> Grammar a -Fail <|> t = t -s <|> Fail = s -(s :|: t) <|> u = s :|: (t <|> u) -Succeed <|> Succeed = Succeed -s <|> t = s :|: t - --- | Smart constructor for parallel execution: removes fails and succeeds in the operands -(<||>) :: Grammar a -> Grammar a -> Grammar a -Succeed <||> t = t -s <||> Succeed = s -Fail <||> _ = fail -_ <||> Fail = fail -(s :||: t) <||> u = s :||: (t <||> u) -s <||> t = s :||: t - --- | For constructing a recursive grammar -rec :: Int -> Grammar a -> Grammar a -rec i s = if i `S.member` freeVars s then Rec i s else s - - --- | Fix-point combinator to model recursion. Be careful: this combinator is --- VERY powerfull, and it is your own responsibility that the result --- is a valid, non-left-recursive grammar -fix :: (Grammar a -> Grammar a) -> Grammar a -fix f = Rec i (f (Var i)) -- disadvantage: function f is applied twice - where - s = allVars (f Succeed) - i = if S.null s then 0 else S.findMax s + 1 - --- | Zero or more occurrences -many :: Grammar a -> Grammar a -many s = rec 0 (succeed <|> (nonempty s <*> var 0)) -{- TODO: deal with free variables? -many s = rec i (succeed <|> (nonempty s <*> var i)) - where - vs = freeVars s - i = if S.null vs then 0 else 1 + S.findMax vs -} - ----------------------------------------------------------------------- --- Elementary operations - --- | Tests whether the grammar accepts the empty string -empty :: Grammar a -> Bool -empty (s :*: t) = empty s && empty t -empty (s :|: t) = empty s || empty t -empty (s :||: t) = empty s && empty t -empty (Rec _ s) = empty s -empty Succeed = True -empty _ = False - --- | Returns the firsts set of the grammar, where each symbol is --- paired with the remaining grammar -firsts :: Grammar a -> [(a, Grammar a)] -firsts (s :*: t) = [ (a, s' <*> t) | (a, s') <- firsts s ] ++ - (if empty s then firsts t else []) -firsts (s :|: t) = firsts s ++ firsts t -firsts (s :||: t) = [ (a, s' <||> t ) | (a, s') <- firsts s ] ++ - [ (a, s <||> t' ) | (a, t') <- firsts t] -firsts (Rec i s) = firsts (replaceVar i (Rec i s) s) -firsts (Symbol a) = [(a, succeed)] -firsts _ = [] - --- | Returns the grammar without the empty string alternative -nonempty :: Grammar a -> Grammar a -nonempty s = foldr (<|>) fail [ symbol a <*> t | (a, t) <- firsts s ] - ----------------------------------------------------------------------- --- Membership and generated language - --- | Checks whether a string is member of the grammar's language -member :: Eq a => [a] -> Grammar a -> Bool -member [] g = empty g -member (a:as) g = not $ null [ () | (b, t) <- firsts g, a==b, member as t ] - --- | Generates the language of the grammar (list can be infinite). The sentences are --- returned sorted by length, thus in a breadth-first order. The integer that is passed --- is the cut-off depth (the maximal length of the sentences) needed to avoid non-termination -language :: Int -> Grammar a -> [[a]] -language n = concat . take n . languageBF - --- | Generates the language of a grammar in a breadth-first manner, which is made explicit --- by the outermost list. Sentences are grouped by their length -languageBF :: Grammar a -> [[[a]]] -languageBF s = [ [] | empty s ] : merge [ map (map (a:)) $ languageBF t | (a, t) <- firsts s ] - where merge = map concat . transpose - ----------------------------------------------------------------------- --- Additional functions - --- | Collect all the symbols of the grammar -collectSymbols :: Grammar a -> [a] -collectSymbols (Symbol a) = [a] -collectSymbols g = compos [] (++) collectSymbols g - --- | The (monadic) join -join :: Grammar (Grammar a) -> Grammar a -join = mapSymbol id - --- | Label all symbols with an index (from left to right) -withIndex :: Grammar a -> Grammar (Int, a) -withIndex = snd . rec 0 - where - rec :: Int -> Grammar a -> (Int, Grammar (Int, a)) - rec n grammar = - case grammar of - p :*: q -> let (n1, a) = rec n p - (n2, b) = rec n1 q - in (n2, a :*: b) - p :|: q -> let (n1, a) = rec n p - (n2, b) = rec n1 q - in (n2, a :|: b) - p :||: q -> let (n1, a) = rec n p - (n2, b) = rec n1 q - in (n2, a :||: b) - Rec i s -> let (n1, a) = rec n s - in (n1, Rec i a) - Var i -> (n, Var i) - Symbol a -> (n+1, Symbol (n, a)) - Succeed -> (n, Succeed) - Fail -> (n, Fail) - ----------------------------------------------------------------------- --- Local helper functions and instances - -instance Uniplate (Grammar a) where - uniplate (s :*: t) = ([s,t], \[a,b] -> a :*: b) - uniplate (s :|: t) = ([s,t], \[a,b] -> a :|: b) - uniplate (s :||: t) = ([s,t], \[a,b] -> a :||: b) - uniplate (Rec i s) = ([s] , \[a] -> Rec i a) - uniplate g = ([] , \[] -> g) - -instance Functor Grammar where - fmap f = mapSymbol (symbol . f) - -freeVars :: Grammar a -> S.Set Int -freeVars (Rec i s) = freeVars s S.\\ S.singleton i -freeVars (Var i) = S.singleton i -freeVars g = compos S.empty S.union freeVars g - -allVars :: Grammar a -> S.Set Int -allVars (Var i) = S.singleton i -allVars g = compos S.empty S.union allVars g - -replaceVar :: Int -> Grammar a -> Grammar a -> Grammar a -replaceVar i new = rec - where - rec g = - case g of - Var j | i==j -> new - Rec j _ | i==j -> g - _ -> f $ map rec cs - where (cs, f) = uniplate g - -mapSymbol :: (a -> Grammar b) -> Grammar a -> Grammar b -mapSymbol f (p :*: q) = mapSymbol f p <*> mapSymbol f q -mapSymbol f (p :|: q) = mapSymbol f p <|> mapSymbol f q -mapSymbol f (p :||: q) = mapSymbol f p <||> mapSymbol f q -mapSymbol f (Rec i p) = Rec i (mapSymbol f p) -mapSymbol _ (Var i) = Var i -mapSymbol f (Symbol a) = f a -mapSymbol _ Succeed = Succeed -mapSymbol _ Fail = Fail - --------------------------------------------------------- --- QuickCheck generator - -instance Arbitrary a => Arbitrary (Grammar a) where - arbitrary = sized (arbGrammar []) -instance CoArbitrary a => CoArbitrary (Grammar a) where - coarbitrary grammar = - case grammar of - p :*: q -> variant 0 . coarbitrary p . coarbitrary q - p :|: q -> variant 1 . coarbitrary p . coarbitrary q - p :||: q -> variant 2 . coarbitrary p . coarbitrary q - Rec i p -> variant 3 . coarbitrary i . coarbitrary p - Var i -> variant 4 . coarbitrary i - Symbol a -> variant 5 . coarbitrary a - Succeed -> variant 6 - Fail -> variant 7 - --- Use smart constructors here -arbGrammar :: Arbitrary a => [Grammar a] -> Int -> Gen (Grammar a) -arbGrammar xs n - | n == 0 = oneof $ - liftM symbol arbitrary : - map return ([succeed, fail] ++ xs) - | otherwise = oneof - [ arbGrammar xs 0 - , liftM2 (<*>) rec rec - , liftM2 (<|>) rec rec - , liftM2 (<||>) rec rec - , liftM many rec --- , liftM fix (promote (\x -> arbGrammar (x:xs) (n `div` 2))) -{- , do i <- oneof $ map return [1::Int ..5] - x <- arbGrammar (Var i:xs) (n `div` 2) - return $ Rec i x -} - ] - where - rec = arbGrammar xs (n `div` 2) - --------------------------------------------------------- --- QuickCheck properties - -propSymbols :: (Int -> Int) -> Grammar Int -> Bool -propSymbols f p = map f (collectSymbols p) == collectSymbols (fmap f p) - -propIndexId :: Grammar Int -> Bool -propIndexId p = fmap snd (withIndex p) === p - -propIndexUnique :: Grammar Int -> Bool -propIndexUnique p = is == nub is - where is = map fst $ collectSymbols $ withIndex p - -propSound :: Grammar Int -> Property -propSound p = not (null xs) ==> all (`member` p) xs - where xs = take 20 $ language 10 p - -propEmpty :: Grammar Int -> Bool -propEmpty s = empty s == member [] s - -propNonEmpty :: Grammar Int -> Bool -propNonEmpty = not . member [] . nonempty - -propSplitSucceed :: Grammar Int -> Bool -propSplitSucceed p = p === if empty p then succeed <|> new else new - where new = nonempty p - -propFirsts :: Grammar Int -> Bool -propFirsts p = nonempty p === foldr op fail (firsts p) - where op (a, q) r = (symbol a <*> q) <|> r - -propJoin :: Grammar Int -> Bool -propJoin p = join (fmap symbol p) === p - -propMap :: (Int -> Int) -> (Int -> Int) -> Grammar Int -> Bool -propMap f g p = fmap (f . g) p === fmap (f . g) p - -propRec :: Grammar Int -> Property -propRec this@(Rec i p) = property (replaceVar i this p === this) -propRec _ = False ==> True - -propSucceed :: Grammar Int -> Bool -propSucceed p = empty p == member [] p - -infixl 1 === - -(===) :: Grammar Int -> Grammar Int -> Bool -p === q = all (`member` p) ys && all (`member` q) xs - where - xs = take 20 $ language 10 p - ys = take 20 $ language 10 q - -associative op p q r = p `op` (q `op` r) === (p `op` q) `op` r -commutative op p q = p `op` q === q `op` p -idempotent op p = p `op` p === p -leftUnit op e p = e `op` p === p -rightUnit op e p = p `op` e === p -unit op e p = leftUnit op e p && rightUnit op e p -absorbe op e p = (e `op` p === e) && (p `op` e === e) -propStar p = many p === succeed <|> (p <*> many p) -propStarStar p = many (many p) === many p - -checks :: IO () -checks = do - putStrLn "** Grammar combinators" - quickCheck propMap - quickCheck propJoin - quickCheck propSymbols - quickCheck propIndexId - quickCheck propIndexUnique - quickCheck propSound - quickCheck propEmpty - quickCheck propNonEmpty - quickCheck propSplitSucceed - quickCheck propFirsts - quickCheck propRec - quickCheck propStar - quickCheck propStarStar - quickCheck propSucceed - quickCheck $ associative (<|>) - quickCheck $ commutative (<|>) - quickCheck $ idempotent (<|>) - quickCheck $ unit (<|>) fail - quickCheck $ associative (<*>) - quickCheck $ unit (<*>) succeed - quickCheck $ absorbe (<*>) fail - quickCheck $ associative (<||>) - quickCheck $ commutative (<||>) - quickCheck $ unit (<||>) succeed - quickCheck $ absorbe (<||>) fail diff --git a/src/Common/Strategy/Location.hs b/src/Common/Strategy/Location.hs --- a/src/Common/Strategy/Location.hs +++ b/src/Common/Strategy/Location.hs @@ -12,109 +12,69 @@ -- ----------------------------------------------------------------------------- module Common.Strategy.Location - ( StrategyLocation, topLocation, nextLocation, downLocation - , locationDepth - , subTaskLocation, nextTaskLocation, parseStrategyLocation - , StrategyOrRule, strategyLocations, subStrategy, addLocation + ( subTaskLocation, nextTaskLocation + , strategyLocations, subStrategy ) where +import Common.Id import Common.Strategy.Abstract import Common.Strategy.Core -import Common.Transformation import Common.Uniplate -import Common.Utils (readM) -import Data.Foldable (toList) -import Data.Sequence hiding (take) -import Control.Monad.State +import Common.Utils (safeHead) +import Data.Maybe ----------------------------------------------------------- --- Strategy locations --- | A strategy location corresponds to a substrategy or a rule -newtype StrategyLocation = SL (Seq Int) - deriving Eq - -instance Show StrategyLocation where - show (SL xs) = show (toList xs) - -type StrategyOrRule a = Either (LabeledStrategy a) (Rule a) - -topLocation :: StrategyLocation -topLocation = SL empty - -nextLocation :: StrategyLocation -> StrategyLocation -nextLocation (SL xs) = - case viewr xs of - EmptyR -> topLocation -- invalid - ys :> a -> SL (ys |> (a+1)) - -downLocation :: StrategyLocation -> StrategyLocation -downLocation (SL xs) = SL (xs |> 0) - -locationDepth :: StrategyLocation -> Int -locationDepth (SL xs) = Data.Sequence.length xs - -- old (current) and actual (next major rule) location -subTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation -subTaskLocation (SL xs) (SL ys) = SL (rec xs ys) +subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id +subTaskLocation s xs ys = g (rec (f xs) (f ys)) where - rec xs ys = - case (viewl xs, viewl ys) of - (i :< is, j :< js) - | i == j -> i <| rec is js - | otherwise -> empty - (_, j :< _) -> singleton j - _ -> empty + f = fromMaybe [] . toLoc s + g = fromMaybe (getId s) . fromLoc s + rec (i:is) (j:js) + | i == j = i : rec is js + | otherwise = [] + rec _ (j:_) = [j] + rec _ _ = [] -- old (current) and actual (next major rule) location -nextTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation -nextTaskLocation (SL xs) (SL ys) = SL (rec xs ys) +nextTaskLocation :: LabeledStrategy a -> Id -> Id -> Id +nextTaskLocation s xs ys = g (rec (f xs) (f ys)) where - rec xs ys = - case (viewl xs, viewl ys) of - (i :< is, j :< js) - | i == j -> i <| rec is js - | otherwise -> singleton j - _ -> empty - -parseStrategyLocation :: String -> Maybe StrategyLocation -parseStrategyLocation = fmap (SL . fromList) . readM + f = fromMaybe [] . toLoc s + g = fromMaybe (getId s) . fromLoc s + rec (i:is) (j:js) + | i == j = i : rec is js + | otherwise = [j] + rec _ _ = [] -- | Returns a list of all strategy locations, paired with the labeled --- substrategy or rule at that location - -strategyLocations :: LabeledStrategy a -> [(StrategyLocation, StrategyOrRule a)] -strategyLocations = collect . addLocation . toCore . toStrategy - where - collect core = +-- substrategy at that location +strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)] +strategyLocations s = ([], s) : rec [] (toCore (unlabel s)) + where + rec is = concat . zipWith make (map (:is) [0..]) . collect + + make is (l, core) = + let ls = makeLabeledStrategy l (toStrategy core) + in (is, ls) : rec is core + + collect core = case core of - Label (loc, info) s -> - let this = makeLabeledStrategy info (mapLabel snd s) - in (loc, Left this) : collect s - Rule (Just (loc, _)) r -> - [(loc, Right r)] - _ -> - concatMap collect (children core) + Label l t -> [(l, t)] + Not _ -> [] + _ -> concatMap collect (children core) -- | Returns the substrategy or rule at a strategy location. Nothing -- indicates that the location is invalid -subStrategy :: StrategyLocation -> LabeledStrategy a -> Maybe (StrategyOrRule a) -subStrategy loc = lookup loc . strategyLocations - --- local helper functions that decorates interesting places with a --- strategy lcations (major rules, and labels) -addLocation :: Core l a -> Core (StrategyLocation, l) a -addLocation = flip evalState topLocation . mapCoreM forLabel forRule - where - forLabel l ma = do - loc <- get - put (downLocation loc) - rest <- ma - put (nextLocation loc) - return (Label (loc, l) rest) - forRule (Just l) r = do - loc <- get - put (nextLocation loc) - return (Rule (Just (loc, l)) r) - forRule Nothing r = - return (Rule Nothing r) +subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a) +subStrategy loc = + fmap snd . safeHead . filter ((==loc) . getId . snd) . strategyLocations + +fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id +fromLoc s loc = fmap getId (lookup loc (strategyLocations s)) + +toLoc :: LabeledStrategy a -> Id -> Maybe [Int] +toLoc s i = + fmap fst (safeHead (filter ((==i) . getId . snd) (strategyLocations s))) diff --git a/src/Common/Strategy/Parsing.hs b/src/Common/Strategy/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Parsing.hs @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Basic machinery for executing a core strategy expression. +-- +----------------------------------------------------------------------------- +module Common.Strategy.Parsing + ( Step(..) + , State, makeState, stack, choices, trace, value + , parseDerivationTree, replay, runCore, runCoreWith + ) where + +import Common.Classes +import Common.Derivation +import Common.Strategy.Core +import Common.Transformation +import Control.Monad + +---------------------------------------------------------------------- +-- Step data type + +data Step l a = Enter l | Exit l | RuleStep (Rule a) + deriving Show + +instance Apply (Step l) where + applyAll (RuleStep r) = applyAll r + applyAll _ = return + +---------------------------------------------------------------------- +-- State data type + +data State l a = S + { stack :: [Either l (Core l a)] + , choices :: [Bool] + , trace :: [Step l a] + , value :: a + } + +makeState :: Core l a -> a -> State l a +makeState core a = push core (S [] [] [] a) + +---------------------------------------------------------------------- +-- Parse derivation tree + +parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a) +parseDerivationTree state = addBranches list node + where + xs = firsts state + empty = not (null [ () | (Ready, _) <- xs ]) + node = singleNode state empty + list = [ (step, parseDerivationTree s) | (Result step, s) <- xs ] + +firsts :: State l a -> [(Result (Step l a), State l a)] +firsts st = + case pop st of + Nothing -> [(Ready, st)] + Just (Left l, s) -> [(Result (Exit l), traceExit l s)] + Just (Right core, s) -> firstsStep core s + where + firstsStep core state = + case core of + a :*: b -> firstsStep a (push b state) + a :|: b -> chooseFor True a ++ chooseFor False b + Rec i a -> firstsStep (substCoreVar i core a) state + Var _ -> freeCoreVar "firsts" + Rule r -> hasStep (RuleStep r) (useRule r state) + Label l a -> hasStep (Enter l) [push a (pushExit l state)] + Not a -> guard (checkNot a state) >> firsts state + a :|>: b -> firstsStep (coreOrElse a b) state + Many a -> firstsStep (coreMany a) state + Repeat a -> firstsStep (coreRepeat a) state + Fail -> [] + Succeed -> firsts state + where + chooseFor b = flip firstsStep (makeChoice b state) + hasStep step xs = [ (Result step, traceStep step s) | s <- xs ] + +-- helper datatype +data Result a = Result a | Ready + +---------------------------------------------------------------------- +-- Running the parser + +runCore :: Core l a -> a -> [a] +runCore core = runState . makeState core + +runCoreWith :: CoreEnv l a -> Core l a -> a -> [a] +runCoreWith env = runCore . substCoreEnv env + +runState :: State l a -> [a] +runState st = + case pop st of + Nothing -> [value st] + Just (Left _, s) -> runState s + Just (Right core, s) -> runStep core s + where + runStep core state = + case core of + a :*: b -> runStep a (push b state) + a :|: b -> runStep a state ++ runStep b state + Rec i a -> runStep (substCoreVar i core a) state + Var _ -> freeCoreVar "runState" + Rule r -> concatMap runState (useRule r state) + Label _ a -> runStep a state + Not a -> guard (checkNot a state) >> runState state + a :|>: b -> let xs = runStep a state + in if null xs then runStep b state else xs + Many a -> runStep (coreMany a) state + Repeat a -> runStep (coreRepeat a) state + Fail -> [] + Succeed -> runState state + +---------------------------------------------------------------------- +-- Replay a parse run + +replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a) +replay n0 bs0 = replayState n0 bs0 . flip makeState noValue + where + noValue = error "no value in replay" + + replayState n bs state = + case pop state of + _ | n==0 -> return state + Nothing -> return state + Just (Left l, s) -> replayState (n-1) bs (traceExit l s) + Just (Right core, s) -> replayStep n bs core s + + replayStep n bs core state = + case core of + _ | n==0 -> return state + a :*: b -> replayStep n bs a (push b state) + a :|: b -> case bs of + [] -> fail "replay failed" + x:xs -> let new = if x then a else b + in replayStep n xs new (makeChoice x state) + Rec i a -> replayStep n bs (substCoreVar i core a) state + Var _ -> freeCoreVar "replay" + Rule r -> replayState (n-1) bs (traceRule r state) + Label l a -> replayStep (n-1) bs a (pushExit l (traceEnter l state)) + Not _ -> replayState n bs state + a :|>: b -> replayStep n bs (coreOrElse a b) state + Many a -> replayStep n bs (coreMany a) state + Repeat a -> replayStep n bs (coreRepeat a) state + Fail -> fail "replay failed" + Succeed -> replayState n bs state + +---------------------------------------------------------------------- +-- Local helper functions and instances + +push :: Core l a -> State l a -> State l a +push core s = s {stack = Right core : stack s} + +pushExit :: l -> State l a -> State l a +pushExit l s = s {stack = Left l : stack s} + +pop :: State l a -> Maybe (Either l (Core l a), State l a) +pop s = case stack s of + [] -> Nothing + x:xs -> Just (x, s {stack = xs}) + +makeChoice :: Bool -> State l a -> State l a +makeChoice b s = s {choices = b : choices s} + +checkNot :: Core l a -> State l a -> Bool +checkNot core = null . runCore core . value + +useRule :: Rule a -> State l a -> [State l a] +useRule r state = [ state {value = b} | b <- applyAll r (value state) ] + +traceEnter, traceExit :: l -> State l a -> State l a +traceEnter = traceStep . Enter +traceExit = traceStep . Exit + +traceRule :: Rule a -> State l a -> State l a +traceRule = traceStep . RuleStep + +traceStep :: Step l a -> State l a -> State l a +traceStep step s = s {trace = step : trace s} + +substCoreVar :: Int -> Core l a -> Core l a -> Core l a +substCoreVar i a = substCoreEnv (insertCoreEnv i a emptyCoreEnv) + +freeCoreVar :: String -> a +freeCoreVar caller = error $ "Free var in core expression: " ++ caller diff --git a/src/Common/Strategy/Prefix.hs b/src/Common/Strategy/Prefix.hs --- a/src/Common/Strategy/Prefix.hs +++ b/src/Common/Strategy/Prefix.hs @@ -14,18 +14,16 @@ ----------------------------------------------------------------------------- module Common.Strategy.Prefix ( Prefix, emptyPrefix, makePrefix - , Step(..), prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix + , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix ) where -import Common.Apply import Common.Utils import Common.Strategy.Abstract -import Common.Strategy.Core +import Common.Strategy.Parsing import Common.Transformation import Common.Derivation -import Common.Strategy.Location -import Common.Strategy.BiasedChoice import Data.Maybe +import Control.Monad ----------------------------------------------------------- --- Prefixes @@ -34,13 +32,22 @@ -- executed rules). A prefix is still "aware" of the labels that appear in the -- strategy. A prefix is encoded as a list of integers (and can be reconstructed -- from such a list: see @makePrefix@). The list is stored in reversed order. -data Prefix a = P [(Int, Bias Step a)] (DerivationTree (Bias Step a) ()) +data Prefix a = P (State LabelInfo a) +prefixPair :: Prefix a -> (Int, [Bool]) +prefixPair (P s) = (length (trace s), reverse (choices s)) + +prefixIntList :: Prefix a -> [Int] +prefixIntList = f . prefixPair + where + f (0, []) = [] + f (n, bs) = n : map (\b -> if b then 0 else 1) bs + instance Show (Prefix a) where - show (P xs _) = show (reverse (map fst xs)) + show = show . prefixIntList instance Eq (Prefix a) where - P xs _ == P ys _ = map fst xs == map fst ys + a == b = prefixPair a == prefixPair b -- | Construct the empty prefix for a labeled strategy emptyPrefix :: LabeledStrategy a -> Prefix a @@ -48,60 +55,28 @@ -- | Construct a prefix for a given list of integers and a labeled strategy. makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a) -makePrefix is ls = rec [] is start +makePrefix [] ls = makePrefix [0] ls +makePrefix (i:is) ls = liftM P $ + replay i (map (==0) is) (mkCore ls) where - mkCore = placeBiasLabels . processLabelInfo snd - . addLocation . toCore . toStrategy - start = strategyTree biasT (mkCore ls) - - rec acc [] t = return (P acc t) - rec acc (n:ns) t = - case drop n (branches t) of - (step, st):_ -> rec ((n, step):acc) ns st - _ -> fail ("invalid prefix: " ++ show is) - - biasT :: Translation (Either (Bias Step a) (StrategyLocation, LabelInfo)) a (Bias Step a) - biasT = (forLabel, Normal . Step) - - forLabel (Left bias) = Before bias - forLabel (Right (loc, i)) = Around (Normal (Begin loc i)) (Normal (End loc i)) - --- | The @Step@ data type can be used to inspect the structure of the strategy -data Step a = Begin StrategyLocation LabelInfo - | Step (Rule a) - | End StrategyLocation LabelInfo - deriving Show - -instance Apply Step where - applyAll (Step r) = applyAll r - applyAll (Begin _ _) = return - applyAll (End _ _) = return - -instance Apply Prefix where - applyAll p = results . prefixTree p + mkCore = processLabelInfo id . toCore . toStrategy -- | Create a derivation tree with a "prefix" as annotation. prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a -prefixTree (P xs t) = changeLabel snd . biasTreeG suc . runTree (decorate xs t) +prefixTree (P s) a = f (parseDerivationTree s {value = a}) where - suc t = endpoint t || any p (annotations t) || any suc (subtrees t) - p (Step r, _) = isMajorRule r - p _ = False - -decorate :: [(Int, Bias Step a)] -> DerivationTree (Bias Step a) () -> DerivationTree (Bias Step a) (Prefix a) -decorate xs t = - let list = zipWith make [0..] (branches t) - make i (s, st) = (s, decorate ((i,s):xs) st) - in addBranches list (singleNode (P xs t) (endpoint t)) - --- | Returns the steps that belong to the prefix -prefixToSteps :: Prefix a -> [Step a] -prefixToSteps (P xs _) = [ step | (_, Normal step) <- reverse xs ] + f t = addBranches list (singleNode (value $ root t) (endpoint t)) + where + list = map g (branches t) + g (_, st) = (P (root st), f st) + +prefixToSteps :: Prefix a -> [Step LabelInfo a] +prefixToSteps (P t) = reverse (trace t) -- | Retrieves the rules from a list of steps -stepsToRules :: [Step a] -> [Rule a] -stepsToRules steps = [ r | Step r <- steps ] +stepsToRules :: [Step l a] -> [Rule a] +stepsToRules xs = [ r | RuleStep r <- xs ] -- | Returns the last rule of a prefix (if such a rule exists) -lastStepInPrefix :: Prefix a -> Maybe (Step a) -lastStepInPrefix (P xs _) = safeHead [ step | (_, Normal step) <- xs ] +lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a) +lastStepInPrefix (P t) = safeHead (trace t) diff --git a/src/Common/StringRef.hs b/src/Common/StringRef.hs new file mode 100644 --- /dev/null +++ b/src/Common/StringRef.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- References to Strings, proving a fast comparison implementation (Eq and +-- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy +-- Virutal Machine (LVM) identifiers. +-- +----------------------------------------------------------------------------- +module Common.StringRef (StringRef, stringRef, toString) where + +import Data.Bits +import Data.IORef +import Data.List +import System.IO.Unsafe +import qualified Data.IntMap as IM + +---------------------------------------------------------------- +-- StringRef datatype and instance declarations + +data StringRef = S !Int + deriving (Eq, Ord) + +instance Show StringRef where + show s@(S i) = '#' : show i ++ toString s + +---------------------------------------------------------------- +-- Hash table + +type HashTable = IM.IntMap [String] + +tableRef :: IORef HashTable +tableRef = unsafePerformIO (newIORef IM.empty) + +---------------------------------------------------------------- +-- Conversion to and from strings + +stringRef :: String -> StringRef +stringRef s = unsafePerformIO $ do + let hash = hashString s + m <- readIORef tableRef + case IM.insertLookupWithKey (\_ -> combine) hash [s] m of + (Nothing, new) -> do + writeIORef tableRef new + return (S (encodeIndexZero hash)) + (Just old, new) -> + case findIndex (==s) old of + Just index -> + return (S (encode hash index)) + Nothing -> do + let index = length old + writeIORef tableRef new + return (S (encode hash index)) + +toString :: StringRef -> String +toString (S i) = unsafePerformIO $ do + m <- readIORef tableRef + case IM.lookup (extractHash i) m of + Just xs -> return (atIndex (extractIndex i) xs) + Nothing -> intErr "id not found" + +---------------------------------------------------------------- +-- Bit encoding + +encode :: Int -> Int -> Int +encode hash index = hash + index `shiftL` 12 + +encodeIndexZero :: Int -> Int +encodeIndexZero hash = hash + +extractHash :: Int -> Int +extractHash i = i `mod` 4096 + +extractIndex :: Int -> Int +extractIndex i = i `shiftR` 12 + +---------------------------------------------------------------- +-- Hash function + +-- simple hash function that performs quite good in practice +hashString :: String -> Int +hashString s = (f s `mod` prime) `mod` maxHash + where + f = foldl' next 0 -- ' strict fold + next n c = n*65599 + fromEnum c + prime = 32537 --65599 -- require: prime < maxHash + +maxHash :: Int +maxHash = 0xFFF -- 12 bits + +---------------------------------------------------------------- +-- Utility functions + +atIndex :: Int -> [a] -> a +atIndex 0 (x:_) = x +atIndex i (_:xs) = atIndex (i-1) xs +atIndex _ _ = intErr "corrupt symbol table" + +combine :: Eq a => [a] -> [a] -> [a] +combine [a] = rec + where + rec [] = [a] + rec this@(x:xs) + | a == x = this + | otherwise = x:rec xs +combine _ = intErr "combine" + +intErr :: String -> a +intErr s = error ("Internal error in Common.StringRef: " ++ s) + +---------------------------------------------------------------- +-- Testing and debugging + +{- +printTable :: IO () +printTable = readIORef tableRef >>= print + +test1 _ = toString (stringRef "bas") == "bas" +test2 _ = stringRef "bas" == stringRef "bas" +test3 _ = stringRef "bas" /= stringRef "je" +test4 _ = stringRef "arith1.unary_minus" /= stringRef "distribute power" +-} diff --git a/src/Common/TestSuite.hs b/src/Common/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/Common/TestSuite.hs @@ -0,0 +1,385 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A lightweight wrapper around the QuickCheck library. It introduces the +-- notion of a test suite, and it stores the test results for later inspection +-- (e.g., for the generation of a test report). A test suite has a monadic +-- interface. +-- +----------------------------------------------------------------------------- +module Common.TestSuite + ( -- * Test Suite Monad + TestSuite, MonadIO(..) + -- * Test suite constructors + , suite, addProperty, addPropertyWith + , assertTrue, assertTrueMsg, assertNull, assertEquals + , assertIO, warn + -- * Running a test suite + , runTestSuite, runTestSuiteResult + -- * Test Suite Result + , TestSuiteResult, subResults + , makeSummary, printSummary + , makeTestLog, makeTestLogWith, printTestLog + -- * Formatting + , FormatLog(..), formatLog, formatTimeDiff + ) where + +import Control.Arrow +import Data.List +import Data.Monoid +import qualified Data.Sequence as S +import Data.Foldable (toList) +import Test.QuickCheck +import Control.Monad.State +import System.Time hiding (formatTimeDiff) + +---------------------------------------------------------------- +-- Test Suite Monad + +-- Integer corresponds to the number of characters on the current line, and +-- is used for formatting +newtype TestSuiteM a = TSM { unTSM :: M a } + +type M a = StateT (Int, ResultTree) IO a +type TestSuite = TestSuiteM () + +instance Monad TestSuiteM where + return = TSM . return + m >>= f = TSM (unTSM m >>= unTSM . f) + fail s = do assertTrueMsg "" s False + return (error "TestSuite.fail: do not bind result") + +instance MonadIO TestSuiteM where + liftIO = TSM . liftIO + +instance Monoid a => Monoid (TestSuiteM a) where + mempty = return mempty + mappend = (>>) + +---------------------------------------------------------------- +-- Test suite constructors + +-- | Construct a (named) test suite containing tests and other suites +suite :: String -> TestSuite -> TestSuite +suite s m = TSM $ do + newline + liftIO $ putStrLn s + reset + (t, td) <- getDiff (withEmptyTree (unTSM m)) + addTree (labeled (s, td) t) + +-- | Add a QuickCheck property to the test suite. The first argument is +-- a label for the property +addProperty :: Testable prop => String -> prop -> TestSuite +addProperty = flip addPropertyWith stdArgs + +-- | Add a QuickCheck property to the test suite, also providing a test +-- configuration (Args) +addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite +addPropertyWith s args p = TSM $ do + newlineIndent + r <- liftIO $ quickCheckWithResult args p + reset + addResult s (toTestResult (maxSuccess args) r) + +assertTrue :: String -> Bool -> TestSuite +assertTrue msg = assertIO msg . return + +assertTrueMsg :: String -> String -> Bool -> TestSuite +assertTrueMsg s msg = addAssertion (Error msg) s . return + +assertNull :: Show a => String -> [a] -> TestSuite +assertNull s xs = addAssertion (f xs) s (return (null xs)) + where f = Error . concat . intersperse "\n" . map show + +assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite +assertEquals s x y = addAssertion msg s (return (x==y)) + where msg = Error ("Not equal: " ++ show x ++ " and " ++ show y) + +assertIO :: String -> IO Bool -> TestSuite +assertIO = addAssertion (Error "Assertion failed") + +warn :: String -> TestSuite +warn msg = addAssertion (Warning msg) "" (return False) + +-- local helpers +addAssertion :: TestResult -> String -> IO Bool -> TestSuite +addAssertion msg s io = TSM $ do + b <- liftIO (io `catch` \_ -> return False) + if b then do + dot + addResult s (Ok 1) + else do + newlineIndent + liftIO $ putStrLn (s ++ ": " ++ show msg) + reset + addResult s msg + +addResult :: String -> TestResult -> M () +addResult s r = addTree (single (s, r)) + +addTree :: ResultTree -> M () +addTree t = modify (second (`mappend` t)) + +withEmptyTree :: M () -> M ResultTree +withEmptyTree m = do + t0 <- gets snd + modify (second (const mempty)) + m + tr <- gets snd + modify (second (const t0)) + return tr + +-- formatting helpers +newline :: M () +newline = do + i <- gets fst + when (i>0) (liftIO $ putChar '\n') + reset + +newlineIndent :: M () +newlineIndent = do + newline + liftIO $ putStr " " + modify (first (const 3)) + +dot :: M () +dot = do + i <- gets fst + unless (i>0 && i<60) newlineIndent + liftIO $ putChar '.' + modify (first (+1)) + +reset :: M () +reset = modify (first (const 0)) + +---------------------------------------------------------------- +-- Running a test suite + +runTestSuite :: TestSuite -> IO () +runTestSuite s = runTestSuiteResult s >> return () + +runTestSuiteResult :: TestSuite -> IO TestSuiteResult +runTestSuiteResult s = liftM TSR $ getDiff $ liftM snd $ + execStateT (unTSM s >> newline) (0, mempty) + +---------------------------------------------------------------- +-- Test Suite Result + +newtype TestSuiteResult = TSR (ResultTree, TimeDiff) + +type ResultTree = Tree (String, TimeDiff) (String, TestResult) + +data TestResult = Ok !Int | Error String | Warning String + +instance Show TestResult where + show (Ok _) = "Ok" + show (Error msg) = "Error: " ++ msg + show (Warning msg) = "Warning: " ++ msg + +-- one-line summary +instance Show TestSuiteResult where + show (TSR (tree, diff)) = + let (n, nf, nw) = collectInfo tree + in "(tests: " ++ show n ++ ", failures: " ++ show nf ++ + ", warnings: " ++ show nw ++ ", " ++ formatTimeDiff diff ++ ")" + +subResults :: TestSuiteResult -> [(String, TestSuiteResult)] +subResults (TSR (tree, _)) = + let f ((s, diff), t) = (s, TSR (t, diff)) + in map f (subtrees tree) + +printSummary :: TestSuiteResult -> IO () +printSummary = putStrLn . makeSummary + +makeSummary :: TestSuiteResult -> String +makeSummary result@(TSR (tree, diff)) = unlines $ + [ line + , "Tests : " ++ show n + , "Failures : " ++ show nf + , "Warnings : " ++ show nw + , "\nTime : " ++ formatTimeDiff diff + , "\nSuites: " + ] ++ map f (subResults result) + ++ [line] + where + line = replicate 75 '-' + (n, nf, nw) = collectInfo tree + f (name, r) = " " ++ name ++ " " ++ show r + +printTestLog :: TestSuiteResult -> IO () +printTestLog = putStrLn . makeTestLog + +makeTestLog :: TestSuiteResult -> String +makeTestLog = unlines . makeTestLogWith formatLog + +makeTestLogWith :: Monoid a => FormatLog a -> TestSuiteResult -> a +makeTestLogWith fm (TSR (tree, diff)) = formatRoot fm diff (make [] tree) + where + make loc = mconcat . map (either forTests forSuite) . treeToList + where + treeToList = + let op (i, ys) y = + case y of + Left b -> (i, Left b:ys) + Right p -> (i+1, Right (loc ++ [i], p):ys) + in reverse . snd . foldl op (1, []) . collectLevel + + forSuite (nl, ((s, d), t)) = + formatSuite fm nl s (collectInfo t) d (make nl t) + + forTests [] = mempty + forTests list@((s, result) : rest) = + case result of + Warning msg -> next (formatWarning fm s msg) + Error msg -> next (formatFailure fm s msg) + Ok _ -> + let (ys, zs) = span (isOk . snd) list + sucs = [ (x, n) | (x, Ok n) <- ys ] + in formatSuccesses fm sucs `mappend` forTests zs + where + next a = a `mappend` forTests rest + +data FormatLog a = FormatLog + { formatRoot :: TimeDiff -> a -> a + , formatSuite :: [Int] -> String -> (Int, Int, Int) -> TimeDiff -> a -> a + , formatSuccesses :: [(String, Int)] -> a + , formatFailure :: String -> String -> a + , formatWarning :: String -> String -> a + } + +formatLog :: FormatLog [String] +formatLog = FormatLog + { formatRoot = \td a -> + a ++ ["\n(Total time: " ++ formatTimeDiff td ++ ")"] + , formatSuite = \loc s _ td a -> + [showLoc loc ++ ". " ++ s] ++ a ++ + [" (" ++ formatTimeDiff td ++ " for " ++ s ++ ")"] + , formatSuccesses = \xs -> + let f (_, n) = if n==1 then "." else "(" ++ show n ++ " tests)" + in [" " ++ concatMap f xs] + , formatFailure = \s msg -> + [" " ++ putLabel s ++ "Error: " ++ msg] + , formatWarning = \s msg -> + [" " ++ putLabel s ++ "Warning: " ++ msg] + } + where + putLabel s = if null s then "" else s ++ ": " + +formatTimeDiff :: TimeDiff -> String +formatTimeDiff d@(TimeDiff z1 z2 z3 h m s p) + | any (/=0) [z1,z2,z3] = timeDiffToString d + | s >= 60 = formatTimeDiff (timeDiff ((h*60+m)*60+s) p) + | h==0 && m==0 = show inSec ++ " secs" + | otherwise = show (60*h+m) ++ ":" ++ digSec ++ " mins" + where + milSec = 1000*toInteger s + p `div` 1000000000 + inSec = fromIntegral milSec / 1000 :: Double + digSec = (if s < 10 then ('0' :) else id) (show s) + timeDiff n pc = + let (rest, sn) = n `divMod` 60 + (hr, mr) = rest `divMod` 60 + in TimeDiff 0 0 0 hr mr sn pc + +----------------------------------------------------- +-- Utility functions + +-- A sequence of leafs (Left) or labeled items (Right) +newtype Tree a b = T { unT :: S.Seq (Either b (a, Tree a b)) } + +instance Monoid (Tree a b) where + mempty = T mempty + mappend (T a) (T b) = T (mappend a b) + +single :: b -> Tree a b +single = T . S.singleton . Left + +labeled :: a -> Tree a b -> Tree a b +labeled a t = T (S.singleton (Right (a, t))) + +toTestResult :: Int -> Result -> TestResult +toTestResult n result = + case result of + Success _ -> Ok n + Failure _ _ msg _ -> Error msg + NoExpectedFailure _ -> Error "no expected failure" + GaveUp i _ -> Warning ("passed only " ++ show i ++ " tests") + +showLoc :: [Int] -> String +showLoc = concat . intersperse "." . map show + +collectInfo :: Tree a (String, TestResult) -> (Int, Int, Int) +collectInfo tree = (length tests, length failures, length warnings) + where + tests = flatten tree + failures = [ msg | (_, Error msg) <- tests ] + warnings = [ msg | (_, Warning msg) <- tests ] + +isOk :: TestResult -> Bool +isOk (Ok _) = True +isOk _ = False + +subtrees :: Tree a b -> [(a, Tree a b)] +subtrees t = [ p | Right p <- collectLevel t ] + +flatten :: Tree a b -> [b] +flatten t = [ b | x <- collectLevel t, b <- either id (flatten . snd) x ] + +collectLevel :: Tree a b -> [Either [b] (a, Tree a b)] +collectLevel = combine [] . toList . unT + where + combine acc [] = f acc + combine acc (Left a:rest) = combine (a:acc) rest + combine acc (Right b:rest) = f acc ++ (Right b : combine [] rest) + + f acc = [ Left (reverse acc) | not (null acc) ] + +getDiff :: MonadIO m => m a -> m (a, TimeDiff) +getDiff action = do + t0 <- liftIO getClockTime + a <- action + t1 <- liftIO getClockTime + return (a, diffClockTimes t1 t0) + +-- Example +{- +main :: IO () +main = do + r <- runTestSuiteResult $ do + suite "A" $ do + addProperty "p1" p1 + addProperty "p1" p1 + suite "A1" $ addProperty "p2" p2 + suite "A2" $ return () + addProperty "p3" p3 + suite "B" $ do + addProperty "p4" p4 + addProperty "W" (\xs -> length (xs::[Int]) > 100 ==> True) + suite "C" $ do + addProperty "p5" p5 + assertTrue "sorted" (sort [3,2,1] == [1,2,3]) + fail "This is a failure" + warn "This is a warning" + assertEquals "eq" (sort [1,2,2]) (nub [1,2,2]) + assertTrue "yes" True + + printSummary r + printTestLog r + --print r + --print (subResults r) + where + p1 xs = sort (xs::[Int]) == sort (sort xs) + p2 xs = reverse (reverse xs) == (xs::[Int]) + p3 xs = head (sort xs) == minimum (xs::[Int]) + p4 xs = sort (nub xs) == nub (sort (xs::[Int])) + p5 xs = reverse (sort xs) == sort (reverse (xs :: [Int])) + +main = runTestSuite $ suite "A" $ assertIO "B" (return True) >> + assertIO "D" (fail "boe") >> assertIO "C" (return True) -} diff --git a/src/Common/Transformation.hs b/src/Common/Transformation.hs --- a/src/Common/Transformation.hs +++ b/src/Common/Transformation.hs @@ -17,29 +17,27 @@ ----------------------------------------------------------------------------- module Common.Transformation ( -- * Transformations - Transformation(RewriteRule), makeTrans, makeTransList + Transformation, makeTrans, makeTransList, makeRewriteTrans -- * Arguments , ArgDescr(..), defaultArgDescr, Argument(..) , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1 , hasArguments, expectedArguments, getDescriptors, useArguments -- * Rules - , Rule, name, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule - , ruleGroups, ruleDescription, ruleSiblings, addRuleToGroup, describe - , rule, ruleList, ruleListF + , Rule, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule + , ruleGroups, ruleSiblings, addRuleToGroup + , rule, ruleList , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList , idRule, checkRule, emptyRule, minorRule, buggyRule, doBefore, doAfter - , transformations, getRewriteRules, doBeforeTrans + , siblingOf, transformations, getRewriteRules, doBeforeTrans + , ruleRecognizer, useRecognizer -- * Lifting - , ruleOnce, ruleOnce2, ruleMulti, ruleMulti2, ruleSomewhere , liftRule, liftTrans, liftRuleIn, liftTransIn -- * QuickCheck - , testRule, testRuleSmart + , testRule, propRuleSmart ) where -import Common.Apply import Common.Rewriting -import Common.Traversable -import Common.Uniplate (Uniplate, somewhereM) +import Common.Classes import Common.Utils import Common.View import Control.Monad @@ -47,6 +45,7 @@ import Data.Maybe import Data.Ratio import Test.QuickCheck +import Common.Id ----------------------------------------------------------- --- Transformations @@ -54,17 +53,19 @@ -- | Abstract data type for representing transformations data Transformation a = Function (a -> [a]) - | RewriteRule (RewriteRule a) + | RewriteRule (RewriteRule a) (a -> [a]) | Transformation a :*: Transformation a -- sequence | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a) | forall b c . LiftView (ViewList a (b, c)) (Transformation b) + | Recognizer (a -> a -> Bool) (Transformation a) instance Apply Transformation where applyAll (Function f) = f - applyAll (RewriteRule r) = rewriteM r + applyAll (RewriteRule _ f) = f applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a) applyAll (LiftView v t) = \a -> [ build v (b, c) | (b0, c) <- match v a, b <- applyAll t b0 ] applyAll (s :*: t) = \a -> applyAll s a >>= applyAll t + applyAll (Recognizer _ t) = applyAll t -- | Turn a function (which returns its result in the Maybe monad) into a transformation makeTrans :: (a -> Maybe a) -> Transformation a @@ -74,6 +75,10 @@ makeTransList :: (a -> [a]) -> Transformation a makeTransList = Function +-- | Turn a rewrite rule into a transformation +makeRewriteTrans :: RewriteRule a -> Transformation a +makeRewriteTrans r = RewriteRule r (rewriteM r) + ----------------------------------------------------------- --- Arguments @@ -158,8 +163,8 @@ -- | Returns a list of argument descriptors getDescriptors :: Rule a -> [Some ArgDescr] -getDescriptors rule = - case transformations rule of +getDescriptors r = + case transformations r of [t] -> rec t _ -> [] where @@ -167,16 +172,17 @@ rec trans = case trans of Abstraction args _ _ -> someArguments args - LiftView _ t -> rec t - s :*: t -> rec s ++ rec t + LiftView _ t -> rec t + Recognizer _ t -> rec t + s :*: t -> rec s ++ rec t _ -> [] -- | Returns a list of pretty-printed expected arguments. Nothing indicates that there are no such arguments expectedArguments :: Rule a -> a -> Maybe [String] -expectedArguments rule a = - case transformations rule of - [t] -> rec t a - _ -> Nothing +expectedArguments r = + case transformations r of + [t] -> rec t + _ -> const Nothing where rec :: Transformation a -> a -> Maybe [String] rec trans a = @@ -188,15 +194,17 @@ rec t b s :*: t -> rec s a `mplus` rec t a + Recognizer _ t -> + rec t a _ -> Nothing -- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are -- invalid (not parsable), or that the wrong number of arguments was supplied useArguments :: [String] -> Rule a -> Maybe (Rule a) -useArguments list rule = - case transformations rule of +useArguments list r = + case transformations r of [t] -> do new <- make t - return rule {transformations = [new]} + return r {transformations = [new]} _ -> Nothing where make :: Transformation a -> Maybe (Transformation a) @@ -204,6 +212,7 @@ case trans of Abstraction args _ g -> fmap g (parseArguments args list) LiftView v t -> fmap (LiftView v) (make t) + Recognizer f t -> fmap (Recognizer f) (make t) s :*: t -> fmap (:*: t) (make s) `mplus` fmap (s :*:) (make t) _ -> Nothing @@ -246,8 +255,8 @@ where showRatio r = show (numerator r) ++ if denominator r == 1 then "" else '/' : show (denominator r) parseRatio s = - let readDivOp s = - case dropWhile isSpace s of + let readDivOp t = + case dropWhile isSpace t of ('/':rest) -> return rest [] -> return "1" _ -> fail "no (/) operator" @@ -264,26 +273,29 @@ -- | Abstract data type for representing rules data Rule a = Rule - { name :: String -- ^ Returns the name of the rule (should be unique) - , ruleDescription :: String -- ^ A short description what the rule is doing + { ruleId :: Id -- ^ Unique identifier of the rule , transformations :: [Transformation a] , isBuggyRule :: Bool -- ^ Inspect whether or not the rule is buggy (unsound) , isMinorRule :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system) - , ruleGroups :: [String] - , ruleSiblings :: [String] + , ruleGroups :: [Id] + , ruleSiblings :: [Id] } instance Show (Rule a) where - show = name + show = showId instance Eq (Rule a) where - r1 == r2 = name r1 == name r2 + r1 == r2 = ruleId r1 == ruleId r2 instance Apply Rule where applyAll r a = do t <- transformations r applyAll t a +instance HasId (Rule a) where + getId = ruleId + changeId f r = r { ruleId = f (ruleId r) } + -- | Returns whether or not the rule is major (i.e., not minor) isMajorRule :: Rule a -> Bool isMajorRule = not . isMinorRule @@ -291,35 +303,34 @@ isRewriteRule :: Rule a -> Bool isRewriteRule = not . null . getRewriteRules -describe :: String -> Rule a -> Rule a -describe txt r = r { ruleDescription = txt ++ "\n" ++ ruleDescription r} - -addRuleToGroup :: String -> Rule a -> Rule a -addRuleToGroup group r = r { ruleGroups = group : ruleGroups r } - -ruleList :: (Builder f a, Rewrite a) => String -> [f] -> Rule a -ruleList s = makeRuleList s . map (RewriteRule . rewriteRule s) +siblingOf :: HasId b => b -> Rule a -> Rule a +siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r } -ruleListF :: (BuilderList f a, Rewrite a) => String -> f -> Rule a -ruleListF s = makeRuleList s . map RewriteRule . rewriteRules s +addRuleToGroup :: HasId b => b -> Rule a -> Rule a +addRuleToGroup g r = r { ruleGroups = getId g : ruleGroups r } -rule :: (Builder f a, Rewrite a) => String -> f -> Rule a -rule s = makeRule s . RewriteRule . rewriteRule s +ruleList :: (IsId n, RuleBuilder f a, Rewrite a) => n -> [f] -> Rule a +ruleList n = makeRuleList a . map (makeRewriteTrans . rewriteRule a) + where a = newId n + +rule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> Rule a +rule n = makeRule a . makeRewriteTrans . rewriteRule a + where a = newId n -- | Turn a transformation into a rule: the first argument is the rule's name -makeRule :: String -> Transformation a -> Rule a +makeRule :: IsId n => n -> Transformation a -> Rule a makeRule n = makeRuleList n . return -- | Turn a list of transformations into a single rule: the first argument is the rule's name -makeRuleList :: String -> [Transformation a] -> Rule a -makeRuleList n ts = Rule n [] ts False False [] [] +makeRuleList :: IsId n => n -> [Transformation a] -> Rule a +makeRuleList n ts = Rule (newId n) ts False False [] [] -- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name -makeSimpleRule :: String -> (a -> Maybe a) -> Rule a +makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a makeSimpleRule n = makeRule n . makeTrans -- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name -makeSimpleRuleList :: String -> (a -> [a]) -> Rule a +makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a makeSimpleRuleList n = makeRule n . makeTransList -- | A special (minor) rule that always returns the identity @@ -363,76 +374,65 @@ f :: Transformation a -> [(Some RewriteRule, Bool)] f trans = case trans of - RewriteRule rr -> [(Some rr, not $ isBuggyRule r)] - LiftView _ t -> f t - s :*: t -> f s ++ f t - _ -> [] - ------------------------------------------------------------ ---- Lifting - --- | Lift a rule using the Once type class -ruleOnce :: Once f => Rule a -> Rule (f a) -ruleOnce r = makeSimpleRuleList (name r) $ onceM $ applyAll r - --- | Apply a rule once (in two functors) -ruleOnce2 :: (Once f, Once g) => Rule a -> Rule (f (g a)) -ruleOnce2 = ruleOnce . ruleOnce + RewriteRule rr _ -> [(Some rr, not $ isBuggyRule r)] + LiftView _ t -> f t + s :*: t -> f s ++ f t + _ -> [] --- | Apply at multiple locations, but at least once -ruleMulti :: (Switch f, Crush f) => Rule a -> Rule (f a) -ruleMulti r = makeSimpleRuleList (name r) $ multi $ applyAll r +ruleRecognizer :: (a -> a -> Bool) -> Rule a -> a -> a -> Bool +ruleRecognizer eq r a b = or + [ transRecognizer eq t a b | t <- transformations r ] --- | Apply at multiple locations, but at least once (in two functors) -ruleMulti2 :: (Switch f, Crush f, Switch g, Crush g) => Rule a -> Rule (f (g a)) -ruleMulti2 = ruleMulti . ruleMulti +transRecognizer :: (a -> a -> Bool) -> Transformation a -> a -> a -> Bool +transRecognizer eq trans a b = + case trans of + Recognizer f t -> f a b || transRecognizer eq t a b + LiftView v t -> + any (`eq` b) (applyAll trans a) || or -- ?? Quick Fix + [ transRecognizer (\x y -> eq (f x) (f y)) t av bv + | (av, c) <- match v a + , (bv, _) <- match v b + , let f z = build v (z, c) + ] + _ -> any (`eq` b) (applyAll trans a) -multi :: (Switch f, Crush f) => (a -> [a]) -> f a -> [f a] -multi f a = - let g a = case f a of - [] -> [(False, a)] - xs -> zip (repeat True) xs - xs = switch (fmap g a) - p = any fst . crush - in map (fmap snd) (filter p xs) +useRecognizer :: (a -> a -> Bool) -> Transformation a -> Transformation a +useRecognizer = Recognizer -ruleSomewhere :: Uniplate a => Rule a -> Rule a -ruleSomewhere r = makeSimpleRuleList (name r) $ somewhereM $ applyAll r +----------------------------------------------------------- +--- Lifting liftTrans :: View a b -> Transformation b -> Transformation a liftTrans v = liftTransIn (v &&& identity) -liftTransIn :: Crush m => ViewM m a (b, c) -> Transformation b -> Transformation a +liftTransIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Transformation b -> Transformation a liftTransIn = LiftView . viewList liftRule :: View a b -> Rule b -> Rule a liftRule v = liftRuleIn (v &&& identity) -liftRuleIn :: Crush m => ViewM m a (b, c) -> Rule b -> Rule a +liftRuleIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Rule b -> Rule a liftRuleIn v r = r - { transformations = map (liftTransIn v) (transformations r) - } + { transformations = map (liftTransIn v) (transformations r) } ----------------------------------------------------------- --- QuickCheck -- | Check the soundness of a rule: the equality function is passed explicitly testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO () -testRule eq rule = - quickCheck (propRule eq rule arbitrary) +testRule eq r = + quickCheck (propRule eq r arbitrary) -- | Check the soundness of a rule and use a "smart generator" for this. The smart generator -- behaves differently on transformations constructed with a (|-), and for these transformations, -- the left-hand side patterns are used (meta variables are instantiated with random terms) -testRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> IO () -testRuleSmart eq rule gen = - let cfg = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100} - in quickCheckWith cfg (propRule eq rule (smartGen rule gen)) +propRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property +propRuleSmart eq r = propRule eq r . smartGen r propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property -propRule eq rule gen = +propRule eq r gen = forAll gen $ \a -> - forAll (smartApplyRule rule a) $ \ma -> + forAll (smartApplyRule r a) $ \ma -> isJust ma ==> (a `eq` fromJust ma) smartGen :: Rule a -> Gen a -> Gen a @@ -444,7 +444,7 @@ smartGenTrans :: a -> Transformation a -> [Gen a] smartGenTrans a trans = case trans of - RewriteRule r -> return (smartGenerator r) + RewriteRule r _ -> return (smartGenerator r) LiftView v t -> do (b, c) <- match v a gen <- smartGenTrans b t diff --git a/src/Common/Traversable.hs b/src/Common/Traversable.hs deleted file mode 100644 --- a/src/Common/Traversable.hs +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Traversable - ( Once(..), Switch(..), Crush(..), OnceJoin(..), useOnceJoin - ) where - -import Control.Monad.Identity -import qualified Data.IntMap as IM -import qualified Data.Map as M - -{- Examples: - -once (^2) [1..3] - ~> [[1,2,3],[1,4,3],[1,2,9]] - -onceM (\x -> [x+1, x^2]) [1..3] - ~> [[2,2,3],[1,2,3],[1,3,3],[1,4,3],[1,2,4],[1,2,9]] - -onceJoin (\x -> [x+1, x^2]) [1..3] - ~> [[2,1,2,3],[1,3,4,3],[1,2,4,9]] - -onceJoinM (\x -> [[x+1], [x^2, x^3]]) [1..3] - ~> [[2,2,3],[1,1,2,3],[1,3,3],[1,4,8,3],[1,2,4],[1,2,9,27]] --} - ------------------------------------------------------------ --- * Type class |Once| - -class Functor f => Once f where - -- | Apply a function once in a given structure - once :: (a -> a) -> f a -> [f a] - -- | Apply a monadic function once in a given structure - onceM :: MonadPlus m => (a -> m a) -> f a -> m (f a) - - -- default definition - once f = onceM (return . f) - -instance Once [] where - onceM = useOnceJoin - -instance Once Maybe where - onceM = useOnceJoin - -instance Once Identity where - onceM = useOnceJoin - -instance Eq a => Once (M.Map a) where - onceM f m = liftM M.fromAscList (onceM g (M.toList m)) - where g (a, b) = liftM (\c -> (a, c)) (f b) - -instance Once IM.IntMap where - onceM f m = liftM IM.fromAscList (onceM g (IM.toList m)) - where g (a, b) = liftM (\c -> (a, c)) (f b) - -useOnceJoin :: (OnceJoin f, MonadPlus m) => (a -> m a) -> f a -> m (f a) -useOnceJoin f = onceJoinM (liftM return . f) - ------------------------------------------------------------ --- * Type class |Switch| - -class Functor f => Switch f where - switch :: Monad m => f (m a) -> m (f a) - -instance Switch [] where - switch = sequence - -instance Switch Maybe where - switch = maybe (return Nothing) (liftM Just) - -instance Switch Identity where - switch (Identity m) = liftM Identity m - -instance Eq a => Switch (M.Map a) where - switch m = do - let (ns, ms) = unzip (M.toList m) - as <- sequence ms - return $ M.fromAscList $ zip ns as - -instance Switch IM.IntMap where - switch m = do - let (ns, ms) = unzip (IM.toList m) - as <- sequence ms - return $ IM.fromAscList $ zip ns as - ------------------------------------------------------------ --- * Type class |Crush| - -class Functor f => Crush f where - crush :: f a -> [a] - -instance Crush [] where - crush = id - -instance Crush Maybe where - crush = maybe [] return - -instance Crush Identity where - crush = return . runIdentity - -instance Crush (M.Map a) where - crush = M.elems - -instance Crush IM.IntMap where - crush = IM.elems - ------------------------------------------------------------ --- * Type class |OnceJoin| - -class (Once f, Monad f) => OnceJoin f where - -- | Apply a function once in a given structure, join the result afterwards - onceJoin :: (a -> f a) -> f a -> [f a] - -- | Apply a monadic function once in a given structure, join the result afterwards - onceJoinM :: MonadPlus m => (a -> m (f a)) -> f a -> m (f a) - - -- default definition - onceJoin f = onceJoinM (return . f) - -instance OnceJoin [] where - onceJoinM _ [] = mzero - onceJoinM f (x:xs) = liftM (++xs) (f x) `mplus` liftM (x:) (onceJoinM f xs) - -instance OnceJoin Maybe where - onceJoinM = maybe mzero - -instance OnceJoin Identity where - onceJoinM f = f . runIdentity diff --git a/src/Common/Uniplate.hs b/src/Common/Uniplate.hs --- a/src/Common/Uniplate.hs +++ b/src/Common/Uniplate.hs @@ -8,26 +8,30 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- This module defines the Uniplate type class, and some utility functions. It --- should be replaced in future by the original Uniplate library. +-- Exports a subset of Data.Generics.Uniplate -- ----------------------------------------------------------------------------- -module Common.Uniplate ( - -- * Uniplate type class and utility functions - Uniplate(..) - , universe, subtermsAt, children, child - , getTermAt, applyTo, applyToM, applyAt, applyAtM - , transform, transformM, transformTD, rewrite, rewriteM - , somewhere, somewhereM - , compos +module Common.Uniplate + ( -- * Uniplate type class and utility functions + Uniplate(..), universe, children, holes + , transform, transformM, descend, descendM, rewrite, rewriteM + -- * Additional functions + , leafs ) where - + +import Data.Generics.Uniplate + +leafs :: Uniplate a => a -> [a] +leafs a = case children a of + [] -> [a] + xs -> concatMap leafs xs + +{- --------------------------------------------------------- -- Uniplate class for generic traversals import Common.Utils (safeHead) import Control.Monad - -- | The Uniplate type class offers some light-weight functions for generic traversals. Only -- a minimal set of operations are supported class Uniplate a where @@ -37,21 +41,50 @@ universe :: Uniplate a => a -> [a] universe a = a : [ c | b <- children a, c <- universe b ] --- | Like universe, but also returns the location of the subterm -subtermsAt :: Uniplate a => a -> [([Int], a)] -subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ] - -- | Returns all the immediate children of a term children :: Uniplate a => a -> [a] children = fst . uniplate --- | Selects one immediate child of a term. Nothing indicates that the child does not exist -child :: Uniplate a => Int -> a -> Maybe a -child n = safeHead . drop n . children - +-- | A bottom-up transformation +transform :: Uniplate a => (a -> a) -> a -> a +transform g a = g $ f $ map (transform g) cs + where + (cs, f) = uniplate a + +-- | Monadic variant of transform +transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a +transformM g a = mapM (transformM g) cs >>= (g . f) + where + (cs, f) = uniplate a + +-- | Applies a function to its immediate children +descend :: Uniplate a => (a -> a) -> a -> a +descend g a = + let (cs, f) = uniplate a + in f (map g cs) + +-- | Applies the function at a position until this is no longer possible +rewrite :: Uniplate a => (a -> Maybe a) -> a -> a +rewrite f = transform g + where g x = maybe x (rewrite f) (f x) + +-- | Monadic variant of rewrite +rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a +rewriteM f = transformM g + where g x = f x >>= maybe (return x) (rewriteM f) + +--------------------------------------------------------- +-- Additional functions + +-- | Like universe, but also returns the location of the subterm +subtermsAt :: Uniplate a => a -> [([Int], a)] +subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ] + -- | Selects a child based on a path. Nothing indicates that the path is invalid getTermAt :: Uniplate a => [Int] -> a -> Maybe a getTermAt is a = foldM (flip child) a is + where + child n = safeHead . drop n . children -- | Apply a function to one immediate child. applyTo :: Uniplate a => Int -> (a -> a) -> a -> a @@ -75,34 +108,6 @@ applyAtM :: (Monad m, Uniplate a) => [Int] -> (a -> m a) -> a -> m a applyAtM is f = foldr applyToM f is --- | A bottom-up transformation -transform :: Uniplate a => (a -> a) -> a -> a -transform g a = g $ f $ map (transform g) cs - where - (cs, f) = uniplate a - --- | Monadic variant of transform -transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a -transformM g a = mapM (transformM g) cs >>= (g . f) - where - (cs, f) = uniplate a - --- | A top-down transformation -transformTD :: Uniplate a => (a -> a) -> a -> a -transformTD g a = - let (cs, f) = uniplate (g a) - in f (map (transformTD g) cs) - --- | Applies the function at a position until this is no longer possible -rewrite :: Uniplate a => (a -> Maybe a) -> a -> a -rewrite f = transform g - where g x = maybe x (rewrite f) (f x) - --- | Monadic variant of rewrite -rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a -rewriteM f = transformM g - where g x = f x >>= maybe (return x) (rewriteM f) - somewhere :: Uniplate a => (a -> a) -> a -> [a] somewhere f = somewhereM (return . f) @@ -111,7 +116,4 @@ where n = length (children a) g i = applyToM i (somewhereM f) a - --- | The compos function -compos :: Uniplate b => a -> (a -> a -> a) -> (b -> a) -> b -> a -compos zero combine f = foldr (combine . f) zero . children +-} diff --git a/src/Common/Utils.hs b/src/Common/Utils.hs --- a/src/Common/Utils.hs +++ b/src/Common/Utils.hs @@ -20,7 +20,6 @@ import Data.Ratio import System.Random import Test.QuickCheck -import qualified Data.Map as M data Some f = forall a . Some (f a) @@ -30,9 +29,6 @@ instance Show ShowString where show = fromShowString -thoroughCheck :: Testable a => a -> IO () -thoroughCheck = quickCheckWith $ stdArgs {maxSize = 500, maxSuccess = 500} - readInt :: String -> Maybe Int readInt xs | null xs = Nothing @@ -47,7 +43,7 @@ stringToHex :: String -> Maybe Int stringToHex = foldl op (Just 0) where - op (Just i) c = fmap (\j -> i*16 + j) (charToHex c) + op (Just i) c = fmap (i*16+) (charToHex c) op Nothing _ = Nothing charToHex :: Char -> Maybe Int @@ -70,6 +66,10 @@ distinct [] = True distinct (x:xs) = all (/=x) xs && distinct xs +allsame :: Eq a => [a] -> Bool +allsame [] = True +allsame (x:xs) = all (==x) xs + safeHead :: [a] -> Maybe a safeHead (x:_) = return x safeHead _ = Nothing @@ -99,56 +99,30 @@ Just (xs, ys) -> xs : splitsWithElem c ys Nothing -> [s] +splitAtSequence :: Eq a => [a] -> [a] -> Maybe ([a], [a]) +splitAtSequence cs = f [] + where + f _ [] = Nothing + f acc list@(x:xs) + | cs `isPrefixOf` list = Just (reverse acc, drop (length cs) list) + | otherwise = f (x:acc) xs + -- | Use a fixed standard "random" number generator. This generator is -- accessible by calling System.Random.getStdGen useFixedStdGen :: IO () useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} +fst3 :: (a, b, c) -> a fst3 (x, _, _) = x + +snd3 :: (a, b, c) -> b snd3 (_, x, _) = x + +thd3 :: (a, b, c) -> c thd3 (_, _, x) = x commaList :: [String] -> String commaList = concat . intersperse ", " - -primes :: [Int] -primes = rec [2..] - where - rec [] = error "Common.Utils: empty list" - rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) - -putLabel :: String -> IO () -putLabel s = - let n = (40 - length s) `max` 3 - in putStr (s ++ replicate n ' ') - -reportTest :: String -> Bool -> IO () -reportTest s b = putLabel s >> putStrLn (if b then "OK" else "FAILED") - -instance Show (a -> b) where - show _ = "" - -{- -instance Arbitrary Char where - arbitrary = let chars = ['a' .. 'z'] ++ ['A' .. 'Z'] - in oneof (map return chars) -instance CoArbitrary Char where - coarbitrary = coarbitrary . ord --} - -instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (M.Map k a) where - arbitrary = liftM M.fromList arbitrary -instance (Ord k, CoArbitrary k, CoArbitrary a) => CoArbitrary (M.Map k a) where - coarbitrary = coarbitrary . M.toList - -{- --- Generating arbitrary random rational numbers -instance Integral a => Arbitrary (Ratio a) where - arbitrary = sized (\n -> ratioGen n (n `div` 4)) -instance Integral a => CoArbitrary (Ratio a) where - coarbitrary r = f (numerator r) . f (denominator r) - where f = variant . fromIntegral --} -- | Prevents a bias towards small numbers ratioGen :: Integral a => Int -> Int -> Gen (Ratio a) diff --git a/src/Common/View.hs b/src/Common/View.hs --- a/src/Common/View.hs +++ b/src/Common/View.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -8,12 +9,13 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- This module defines views on data-types +-- This module defines views on data-types, as described in "Canonical Forms +-- in Interactive Exercise Assistants" -- ----------------------------------------------------------------------------- module Common.View ( -- * Generalized monadic views - ViewM, match, build, makeView, biArr, identity, (>>>) + ViewM, match, build, newView, makeView, biArr, identity, (>>>) , canonical, canonicalWith , Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..) -- * Simple views @@ -21,13 +23,14 @@ , simplify, simplifyWith, viewEquivalent, viewEquivalentWith , isCanonical, isCanonicalWith, matchM, canonicalM, viewList -- * Some combinators - , listView, switchView, ( #> ), associativeView + , swapView, listView, switchView, associativeView -- * Properties on views , propIdempotence, propSoundness, propNormalForm ) where -import Common.Traversable -import Control.Arrow hiding ((>>>)) +import Common.Id +import Common.Classes +import Control.Arrow import Control.Monad import Data.Maybe import Test.QuickCheck @@ -36,81 +39,82 @@ ---------------------------------------------------------------------------------- -- Generalized monadic view --- For all v::View the following should hold: --- 1) simplify v a "is equivalent to" a --- 2) match (build b) equals Just b --- (but only for b that have at least one "a") --- --- Derived property: simplification is idempotent - -data ViewM m a b = ViewM - { match :: a -> m b - , build :: b -> a - } - -makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b -makeView = ViewM - -biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b -biArr f g = makeView (return . f) g - -canonical :: Monad m => ViewM m a b -> a -> m a -canonical = canonicalWith id - -canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a -canonicalWith f view = liftM (build view . f) . match view - ---------------------------------------------------------------- --- Arrow combinators - -identity :: Monad m => ViewM m a a -identity = makeView return id - -(>>>) :: Monad m => ViewM m a b -> ViewM m b c -> ViewM m a c -v >>> w = makeView (\a -> match v a >>= match w) (build v . build w) +data ViewM m a b where + Prim :: Id -> (a -> m b) -> (b -> a) -> ViewM m a b + (:>>>:) :: ViewM m a b -> ViewM m b c -> ViewM m a c + First :: ViewM m a b -> ViewM m (a, c) (b, c) + Second :: ViewM m b c -> ViewM m (a, b) (a, c) + (:***:) :: ViewM m a c -> ViewM m b d -> ViewM m (a, b) (c, d) + (:&&&:) :: ViewM m a b -> ViewM m a c -> ViewM m a (b, c) + VLeft :: ViewM m a b -> ViewM m (Either a c) (Either b c) + VRight :: ViewM m b c -> ViewM m (Either a b) (Either a c) + (:+++:) :: ViewM m a c -> ViewM m b d -> ViewM m (Either a b) (Either c d) + (:|||:) :: ViewM m a c -> ViewM m b c -> ViewM m (Either a b) c instance Monad m => C.Category (ViewM m) where id = identity - v . w = w >>> v - + v . w = w :>>>: v + instance Monad m => Arrow (ViewM m) where - arr f = biArr f (error "Control.View.arr: function is not invertible") + arr f = Prim (newId "views.arr") (return . f) (error "Control.View.arr: function is not invertible") + first = First + second = Second + (***) = (:***:) + (&&&) = (:&&&:) - first v = makeView - (\(a, c) -> match v a >>= \b -> return (b, c)) - (first (build v)) +instance Monad m => ArrowChoice (ViewM m) where + left = VLeft + right = VRight + (+++) = (:+++:) + (|||) = (:|||:) - second v = makeView - (\(a, b) -> match v b >>= \c -> return (a, c)) - (second (build v)) +---------------------------------------------------------------------------------- +-- Operations on a view - v *** w = makeView - (\(a, c) -> liftM2 (,) (match v a) (match w c)) - (build v *** build w) +-- The preferred way of constructing a view +newView :: (IsId n, Monad m) => n -> (a -> m b) -> (b -> a) -> ViewM m a b +newView = Prim . newId - -- left-biased builder - v &&& w = makeView - (\a -> liftM2 (,) (match v a) (match w a)) - (\(b, _) -> build v b) +makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b +makeView = newView "views.makeView" -instance Monad m => ArrowChoice (ViewM m) where - left v = makeView - (either (liftM Left . match v) (return . Right)) - (either (Left . build v) Right) +biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b +biArr f = makeView (return . f) - right v = makeView - (either (return . Left) (liftM Right . match v)) - (either Left (Right . build v)) +match :: Monad m => ViewM m a b -> a -> m b +match view = + case view of + Prim _ f _ -> f + v :>>>: w -> \a -> match v a >>= match w + First v -> \(a, c) -> match v a >>= \b -> return (b, c) + Second v -> \(a, b) -> match v b >>= \c -> return (a, c) + v :***: w -> \(a, c) -> liftM2 (,) (match v a) (match w c) + v :&&&: w -> \a -> liftM2 (,) (match v a) (match w a) + VLeft v -> either (liftM Left . match v) (return . Right) + VRight v -> either (return . Left) (liftM Right . match v) + v :+++: w -> either (liftM Left . match v) (liftM Right . match w) + v :|||: w -> either (match v) (match w) - v +++ w = makeView - (either (liftM Left . match v) (liftM Right . match w)) - (either (Left . build v) (Right . build w)) +build :: ViewM m a b -> b -> a +build view = + case view of + Prim _ _ f -> f + v :>>>: w -> build v . build w + First v -> first (build v) + Second v -> second (build v) + v :***: w -> build v *** build w + v :&&&: _ -> build v . fst -- left-biased + VLeft v -> either (Left . build v) Right + VRight v -> either Left (Right . build v) + v :+++: w -> either (Left . build v) (Right . build w) + v :|||: _ -> Left . build v -- left-biased - -- left-biased builder - v ||| w = makeView - (either (match v) (match w)) - (Left . build v) +canonical :: Monad m => ViewM m a b -> a -> m a +canonical = canonicalWith id +canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a +canonicalWith f view = liftM (build view . f) . match view + --------------------------------------------------------------- -- Simple views (based on a particular monad) @@ -150,23 +154,27 @@ canonicalM :: Monad m => View a b -> a -> m a canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v -viewList :: Crush m => ViewM m a b -> ViewList a b +viewList :: (Crush m, Monad m) => ViewM m a b -> ViewList a b viewList v = makeView (crush . match v) (build v) --------------------------------------------------------------- -- Some combinators +identity :: Monad m => ViewM m a a +identity = newView "views.identity" return id + +swapView :: View (a, b) (b, a) +swapView = + let swap (a, b) = (b, a) + in newView "views.swap" (return . swap) swap + listView :: Monad m => ViewM m a b -> ViewM m [a] [b] listView v = makeView (mapM (match v)) (map (build v)) switchView :: (Monad m, Switch f) => ViewM m a b -> ViewM m (f a) (f b) switchView v = makeView (switch . fmap (match v)) (fmap (build v)) - -( #> ) :: MonadPlus m => (a -> Bool) -> ViewM m a b -> ViewM m a b -p #> v = makeView f (build v) - where f a = guard (p a) >> match v a -associativeView :: View a (a,a) -> ViewList a (a,a) +associativeView :: View a (a, a) -> ViewList a (a, a) associativeView v = makeView (reverse . f) (build v) where f a = case matchM v a of @@ -189,3 +197,21 @@ propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property propNormalForm g v = forAll g $ \a -> a == simplify v a + +{- proving a parameterized view equivalent to one with a "context" + +abstr1 :: (a -> View b c) -> View (a, b) (a, c) +abstr1 fun = makeView f g + where + f (a, b) = do + c <- match (fun a) b + return (a, c) + g (a, c) = (a, build (fun a) c) + +abstr2 :: View (a, b) (a, c) -> (a -> View b c) +abstr2 v a = makeView f g + where + f b = do + (_, c) <- match v (a, b) + return c + g c = snd (build v (a, c)) -} diff --git a/src/Documentation/DefaultPage.hs b/src/Documentation/DefaultPage.hs --- a/src/Documentation/DefaultPage.hs +++ b/src/Documentation/DefaultPage.hs @@ -11,17 +11,14 @@ ----------------------------------------------------------------------------- module Documentation.DefaultPage where -import Common.Context import Common.Exercise -import Common.Transformation import Control.Monad import Service.DomainReasoner -import Service.ServiceList +import Service.Types import System.Directory import System.FilePath import Text.HTML import qualified Text.XML as XML -import Data.Char generatePage :: String -> String -> HTMLBuilder -> DomainReasoner () generatePage = generatePageAt 0 @@ -45,19 +42,18 @@ footer version header :: Int -> HTMLBuilder -header level = center $ do - let f m = text "[" >> space >> m >> space >> text "]" - f $ link (up level ++ exerciseOverviewPageFile) $ text "Exercises" - replicateM_ 5 space - f $ link (up level ++ "services.html") $ text "Services" - replicateM_ 5 space - f $ link (up level ++ "tests.html") $ text "Tests" - replicateM_ 5 space - f $ link (up level ++ "coverage/hpc_index.html") $ text "Coverage" - replicateM_ 5 space - f $ link (up level ++ "api/index.html") $ text "API" +header level = do + divClass "menu" $ do + make exerciseOverviewPageFile "Exercises" + make "services.html" "Services" + make "tests.html" "Tests" + make "coverage/hpc_index.html" "Coverage" + make "api/index.html" "API" hr - + where + make target s = f $ link (up level ++ target) $ text s + f m = spaces 3 >> text "[" >> space >> m >> space >> text "]" >> spaces 3 + footer :: String -> HTMLBuilder footer version = do hr @@ -69,62 +65,33 @@ findTitle :: HTMLBuilder -> String findTitle = maybe "" XML.getData . XML.findChild "h1" . XML.makeXML "page" +filePathId :: HasId a => a -> FilePath +filePathId a = foldr (\x y -> x ++ "/" ++ y) (unqualified a) (qualifiers a) + ------------------------------------------------------------ -- Paths and files -ruleImagePath :: Exercise a -> String -ruleImagePath ex = "exercises/" ++ f (domain (exerciseCode ex)) ++ "/" ++ f (description ex) ++ "/" - where f = filter isAlphaNum . map toLower - -exercisePagePath :: ExerciseCode -> String -exercisePagePath code = "exercises/" ++ domain code ++ "/" - -servicePagePath :: String -servicePagePath = "services/" - -ruleImageFile :: Exercise a -> Rule (Context a) -> String -ruleImageFile ex r = ruleImagePath ex ++ "rule" ++ name r ++ ".png" - -ruleImageFileHere :: Exercise a -> Rule (Context a) -> String -ruleImageFileHere ex r = - filter (not . isSpace) (identifier (exerciseCode ex)) - ++ "/rule" ++ filter isAlphaNum (name r) ++ ".png" - -exerciseOverviewPageFile :: String -exerciseOverviewPageFile = "exercises.html" +exerciseOverviewPageFile, exerciseOverviewAllPageFile, + serviceOverviewPageFile, testsPageFile :: String -exerciseOverviewAllPageFile :: String +exerciseOverviewPageFile = "exercises.html" exerciseOverviewAllPageFile = "exercises-all.html" - -serviceOverviewPageFile :: String -serviceOverviewPageFile = "services.html" - -exercisePageFile :: ExerciseCode -> String -exercisePageFile code = - exercisePagePath code - ++ filter (not . isSpace) (identifier code) - ++ ".html" - -exerciseStrategyFile :: ExerciseCode -> String -exerciseStrategyFile code = - exercisePagePath code - ++ filter (not . isSpace) (identifier code) - ++ "-strategy.html" - -exerciseRulesFile :: ExerciseCode -> String -exerciseRulesFile code = - exercisePagePath code - ++ filter (not . isSpace) (identifier code) - ++ "-rules.html" +serviceOverviewPageFile = "services.html" +testsPageFile = "tests.html" -exerciseDerivationsFile :: ExerciseCode -> String -exerciseDerivationsFile code = - exercisePagePath code - ++ filter (not . isSpace) (identifier code) - ++ "-derivations.html" +exercisePageFile, exerciseDerivationsFile, exerciseStrategyFile, + exerciseDiagnosisFile, ruleFile :: HasId a => a -> FilePath +exercisePageFile a = filePathId a ++ ".html" +exerciseDerivationsFile a = filePathId a ++ "-derivations.html" +exerciseStrategyFile a = filePathId a ++ "-strategy.html" +exerciseDiagnosisFile a = filePathId a ++ "-diagnosis.html" +ruleFile a = filePathId ("rule" # getId a) ++ ".html" servicePageFile :: Service -> String -servicePageFile srv = servicePagePath ++ serviceName srv ++ ".html" +servicePageFile srv = "services/" ++ filePathId srv ++ ".html" + +diagnosisExampleFile :: Id -> String +diagnosisExampleFile a = "examples/" ++ showId a ++ ".txt" ------------------------------------------------------------ -- Utility functions diff --git a/src/Documentation/DerivationUnitTests.hs b/src/Documentation/DerivationUnitTests.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/DerivationUnitTests.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.DerivationUnitTests (main) where + +import Control.Monad +import Common.Exercise +import Text.XML +import Domain.Math.Power.Exercises + +base = "test/dwo-derivations" + +main = make powerOfAExercise + +make :: Exercise a -> IO () +make ex = zipWithM_ (makeTest ex) [1 ..] (examples ex) + +makeTest :: Exercise a -> Int -> a -> IO () +makeTest ex n a = do + let file = base ++ "/" ++ show (exerciseCode ex) ++ show n ++ ".xml" + putStrLn $ "Writing " ++ file + writeFile file $ showXML $ makeRequest a ex + +makeRequest :: a -> Exercise a -> XML +makeRequest a ex = makeXML "request" $ do + "service" .=. "derivation" + "exerciseid" .=. show (exerciseCode ex) + "encoding" .=. "string" + element "state" $ + element "expr" $ + text $ prettyPrinter ex a diff --git a/src/Documentation/ExercisePage.hs b/src/Documentation/ExercisePage.hs --- a/src/Documentation/ExercisePage.hs +++ b/src/Documentation/ExercisePage.hs @@ -11,73 +11,89 @@ ----------------------------------------------------------------------------- module Documentation.ExercisePage (makeExercisePage) where +import Common.Context import Common.Exercise +import Common.Derivation import Common.Strategy hiding (not, replicate) import Common.Transformation -import Service.ExercisePackage -import Service.StrategyInfo -import Service.DomainReasoner -import Service.TypedAbstractService hiding (exercise) +import Common.Utils (Some(..), splitAtSequence) import Control.Monad +import Data.Char import Data.List -import Common.Utils (commaList, Some(..)) import Data.Maybe +import Documentation.DefaultPage +import Documentation.RulePresenter +import Service.BasicServices +import Service.Diagnose +import Service.DomainReasoner +import Service.ExercisePackage +import Service.State +import Service.StrategyInfo +import System.Directory import System.Random -import qualified Data.Map as M -import Service.RulesInfo (rewriteRuleToFMP, collectExamples) import Text.HTML -import Text.OpenMath.Object -import Text.OpenMath.FMP -import qualified Text.XML as XML -import Documentation.DefaultPage makeExercisePage :: String -> ExercisePackage a -> DomainReasoner () makeExercisePage dir pkg = do - let ex = exercise pkg - make = generatePageAt 2 dir . ($ (exerciseCode ex)) - make exercisePageFile (exercisePage pkg) + let ex = exercise pkg + make = makeId pkg + makeId a = generatePageAt (length (qualifiers a)) dir . ($ (getId a)) + exFile = dir ++ "/" ++ diagnosisExampleFile (getId ex) + + exampleFileExists <- liftIO (doesFileExist exFile) + + make exercisePageFile (exercisePage exampleFileExists pkg) make exerciseStrategyFile (strategyPage ex) - make exerciseRulesFile (rulesPage ex) unless (null (examples (exercise pkg))) $ make exerciseDerivationsFile (derivationsPage ex) + when (exampleFileExists) $ do + xs <- liftIO (readFile exFile) + make exerciseDiagnosisFile (diagnosisPage xs pkg) + `catchError` \_ -> return () -exercisePage :: ExercisePackage a -> HTMLBuilder -exercisePage pkg = do - h1 (description ex) +exercisePage :: Bool -> ExercisePackage a -> HTMLBuilder +exercisePage exampleFileExists pkg = do + idboxHTML "strategy" (getId pkg) h2 "1. General information" - table - [ [bold $ text "Code", ttText (show $ exerciseCode ex)] - , [bold $ text "Status", text (show $ status ex)] - , [ bold $ text "OpenMath support" + + let bolds (x:xs) = bold x:xs + bolds [] = [] + + table $ map bolds + [ [ text "Code", ttText (showId ex)] + , [ text "Status", text (show $ status ex)] + , [ text "Strategy" + , link (up level ++ exerciseStrategyFile exid) $ + text (showId $ strategy ex) + ] + , [ text "OpenMath support" , text $ showBool $ withOpenMath pkg ] - , [ bold $ text "Textual feedback" + , [ text "Textual feedback" , text $ showBool $ isJust $ getExerciseText pkg ] - , [ bold $ text "Restartable strategy" + , [ text "Restartable strategy" , text $ showBool $ canBeRestarted ex ] - , [ bold $ text "Exercise generator" + , [ text "Exercise generator" , text $ showBool $ isJust $ randomExercise ex ] - , [ bold $ text "Examples" + , [ text "Examples" , text $ show $ length $ examples ex ] ] - - para $ link (up 2 ++ exerciseStrategyFile code) $ - text "See strategy details" h2 "2. Rules" - let rs = rulesInStrategy (strategy ex) - f r = [ text (name r) + let rs = rulesInStrategy (strategy ex) + ups = up (length (qualifiers pkg)) + f r = [ link (ups ++ ruleFile r) $ ttText (showId r) , text $ showBool $ isBuggyRule r , text $ showBool $ hasArguments r , text $ showBool $ r `elem` rs - , text $ concat $ intersperse "," (ruleGroups r) + , text $ concat $ intersperse "," $ map showId $ ruleGroups r , when (isRewriteRule r) $ - image (ruleImageFileHere ex r) + ruleToHTML (Some ex) r ] table ( [bold $ text "Rule name", bold $ text "Buggy" , bold $ text "Args" @@ -86,95 +102,107 @@ ] : map f (ruleset ex) ) - para $ link (up 2 ++ exerciseRulesFile code) $ - text "See rule details" - - + when exampleFileExists $ do + para $ link (up level ++ exerciseDiagnosisFile exid) $ do + br + text "See diagnosis examples" + h2 "3. Example" - let state = generateWith (mkStdGen 0) ex 5 - preText (showDerivation ex (term state)) - unless (null (examples ex)) $ - link (up 2 ++ exerciseDerivationsFile code) (text "More examples") + let state = generateWith (mkStdGen 0) pkg 5 + derivationHTML ex (stateTerm state) + para $ unless (null (examples ex)) $ + link (up level ++ exerciseDerivationsFile exid) (text "More examples") where - ex = exercise pkg - code = exerciseCode ex + ex = exercise pkg + exid = getId ex + level = length (qualifiers pkg) strategyPage :: Exercise a -> HTMLBuilder strategyPage ex = do h1 title h2 "1. Representation in XML" - preText (XML.showXML (strategyToXML (strategy ex))) + highlightXML True (strategyToXML (strategy ex)) h2 "2. Locations" - let f (loc, e) = [text (show loc), indent (locationDepth loc) >> g e] - g (Left a) = text (strategyName a) - g (Right a) = text (name a ++ " (rule)") - indent n = text (replicate (3*n) '.') + let f (loc, a) = + [text (show loc), indent (length loc) >> text (showId a)] + indent n = text (replicate (3*n) '.') table ( [bold $ text "Location", bold $ text "Label"] : map f (strategyLocations (strategy ex)) ) where - code = exerciseCode ex - title = "Strategy for " ++ show code - -rulesPage :: Exercise a -> HTMLBuilder -rulesPage ex = do - h1 title - -- Groups - let groups = sort (nub (concatMap ruleGroups (ruleset ex))) - unless (null groups) $ do - ul $ flip map groups $ \g -> do - bold $ text $ g ++ ":" - space - let elems = filter ((g `elem`) . ruleGroups) (ruleset ex) - text $ commaList $ map name elems - - -- General info - forM_ (zip [1..] (ruleset ex)) $ \(i, r) -> do - h2 (show i ++ ". " ++ show r) - para $ text (ruleDescription r) - para $ table - [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)] - , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)] - , [bold $ text "Groups", text $ commaList $ ruleGroups r] - , [bold $ text "Siblings", text $ commaList $ ruleSiblings r] - ] - when (isRewriteRule r) $ para $ - image (ruleImageFileHere ex r) - -- Examples - let ys = M.findWithDefault [] (name r) exampleMap - unless (null ys) $ do - h3 "Examples" - forM_ (take 3 ys) $ \(a, b) -> para $ tt $ - preText $ prettyPrinter ex a ++ "\n =>\n" ++ prettyPrinter ex b - - -- FMPS - let xs = getRewriteRules r - unless (null xs) $ do - h3 "Formal Mathematical Properties" - forM_ xs $ \(Some rr, b) -> para $ do - let fmp = rewriteRuleToFMP b rr - ttText $ show $ XML.makeXML "FMP" $ - XML.builder (omobj2xml (toObject fmp)) - where - code = exerciseCode ex - title = "Strategy for " ++ show code - exampleMap = collectExamples ex + title = "Strategy for " ++ showId ex derivationsPage :: Exercise a -> HTMLBuilder derivationsPage ex = do - unless (errs==0) $ - errorLine $ preText $ "Warning: " ++ show errs ++ " example(s) with an incorrect derivation" h1 "Examples" - forM_ (zip [1 ..] ds) $ \(i, d) -> do + forM_ (zip [1::Int ..] (examples ex)) $ \(i, a) -> do h2 (show i ++ ".") - preText d + derivationHTML ex a + +derivationHTML :: Exercise a -> a -> HTMLBuilder +derivationHTML ex a = divClass "derivation" $ do + pre $ derivationM (forStep ups) (forTerm ex) der + unless (ok der) $ + divClass "error" $ text "<>" 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 + ups = length (qualifiers ex) + der = derivationDiffEnv (defaultDerivation ex a) + ok = maybe False (isReady ex) . fromContext . last . terms + +idboxHTML :: String -> Id -> HTMLBuilder +idboxHTML kind i = divClass "idbox" $ do + font "id" $ ttText (showId i) + spaces 3 + text $ "(" ++ kind ++ ")" + unless (null $ description i) $ do + br + italic (text (description i)) + +diagnosisPage :: String -> ExercisePackage a -> HTMLBuilder +diagnosisPage xs pkg = do + h1 ("Diagnosis examples for " ++ showId pkg) + forM_ (zip [1::Int ..] (mapMaybe f (lines xs))) $ \(i, (t0, t1, expl)) -> do + h2 (show i ++ ".") + preText (t0 ++ "\n =>\n" ++ t1) + para $ do + unless (null expl) $ do + bold $ text "Description:" + space + text expl + br + bold $ text "Diagnosis:" + space + text (getDiagnosis t0 t1) + where + ex = exercise pkg + f a = do + (x, b) <- splitAtSequence "==>" a + let (y, z) = fromMaybe (b, "") (splitAtSequence ":::" b) + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + return (trim x, trim y, trim z) + + getDiagnosis t0 t1 = + case (parser ex t0, parser ex t1) of + (Left msg, _) -> "parse error (before): " ++ msg + (_, Left msg) -> "parse error (afterr): " ++ msg + (Right a, Right b) -> show (diagnose (emptyState pkg a) b) + +forStep :: HasId a => Int -> (a, Environment) -> HTMLBuilder +forStep n (i, env) = do + spaces 3 + text "=>" + space + let target = up n ++ ruleFile i + make | null (description i) = link target + | otherwise = linkTitle target (description i) + make (text (unqualified i)) + br + unless (nullEnv env) $ do + spaces 6 + text (show env) + br + +forTerm :: Exercise a -> Context a -> HTMLBuilder +forTerm ex ca = do + text (prettyPrinterContext ex ca) + br diff --git a/src/Documentation/LatexRules.hs b/src/Documentation/LatexRules.hs deleted file mode 100644 --- a/src/Documentation/LatexRules.hs +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.LatexRules (makeLatexRules) where - -import Common.Exercise -import Common.Rewriting -import Common.Transformation -import Common.Utils -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import System.Directory -import System.Time - -makeLatexRules :: String -> Exercise a -> IO () -makeLatexRules dir ex = do - let code = exerciseCode ex - path = dir ++ "/" ++ domain code ++ "/" ++ filter (/= ' ') (identifier code) - -- Exercise document - let rules = concatMap getRewriteRules (ruleset ex) - unless (null rules) $ do - createDirectoryIfMissing True path - doc <- makeDocument ex - let filename = path ++ "/overview.lhs" - putStrLn $ "Creating " ++ filename - writeFile filename doc - -- individual rules - forM_ (ruleset ex) $ \r -> - case makeSingleRule (domain code ++ "/" ++ domain code ++ ".fmt") r of - Nothing -> return () - Just txt -> do - let filename = path ++ "/rule" ++ filter isAlphaNum (name r) ++ ".lhs" - putStrLn $ "Creating " ++ filename - writeFile filename txt - -{- -exerciseRulesToTeX :: Exercise a -> String -exerciseRulesToTeX ex = unlines . map ruleToTeX . concatMap getRewriteRules . ruleset $ ex --} - -ruleToTeX :: (Some RewriteRule, Bool) -> Maybe String -ruleToTeX (Some r, sound) = do - txt <- showRewriteRule sound r - return $ "RewriteRule " ++ withoutDigits (ruleName r) - ++ " (" ++ txt ++ ")" - - ------------------------------------------------------- - -makeSingleRule :: String -> Rule a -> Maybe String -makeSingleRule dom r - | null (getRewriteRules r) = Nothing - | otherwise = Just $ texHeader (Just dom) ++ texBody Nothing content - where - content = unlines $ - [ "\\pagestyle{empty}" - , formatRuleName (name r) - , "\\begin{code}" - ] ++ - map (filter (/= '"') . fromMaybe "" . ruleToTeX) (getRewriteRules r) ++ - [ "\\end{code}" - ] - - -makeDocument :: Exercise a -> IO String -makeDocument ex = do - let code = exerciseCode ex - time <- getClockTime - return $ - texHeader (Just $ domain code ++ "/" ++ domain code ++ ".fmt") ++ - texBody (Just $ show time) (texSectionRules ex) - ------------------------------------------------------- - -texHeader :: Maybe String -> String -texHeader fmt = unlines - [ "\\documentclass{article}" - , "" - , "%include lhs2TeX.fmt" - , "%format RewriteRule (a) (b) = \"\\rewriterule{\"a\"}{\"b\"}\"" - , "%format ~> = \"\\:\\leadsto\\:\"" - , "%format /~> = \"\\:\\not\\leadsto\\:\"" - , maybe "" ("%include "++) fmt - , "" - , "\\newcommand{\\rewriterule}[2]{#1:\\quad #2}" - , "\\newcommand{\\rulename}[1]{\\mbox{\\sc #1}}" - ] - -texBody :: Maybe String -> String -> String -texBody date content = unlines - [ "\\begin{document}" - , content - , maybe "" (\s -> "\\par\\vspace*{5mm}\\noindent\\footnotesize{@(generated on " ++ s ++ ")@}") date - , "\\end{document}" - ] - -texSectionRules :: Exercise a -> String -texSectionRules ex = unlines - [ "\\section{Rewrite rules}" - , formats - , makeGroup Nothing - , unlines $ map (makeGroup . Just) groups - ] - where - rules = concatMap getRewriteRules (ruleset ex) - groups = nub (concatMap ruleGroups (ruleset ex)) - names = let f (Some r, _) = ruleName r - in nub (map f rules) - formats = unlines (map formatRuleName names) - - makeGroup :: Maybe String -> String - makeGroup mgroup = unlines - [ maybe "" (\s -> "\\subsection{" ++ s ++ "}") mgroup - , "\\begin{code}" - , unlines $ map (filter (/= '"')) xs - , "\\end{code}" - ] - where - p x = maybe (null $ ruleGroups x) (`elem` ruleGroups x) mgroup - xs = mapMaybe ruleToTeX $ concatMap getRewriteRules $ filter p $ ruleset ex - -formatRuleName :: String -> String -formatRuleName s = "%format " ++ withoutDigits s ++ " = \"\\rulename{" ++ s ++ "}\"" - -withoutDigits :: String -> String -withoutDigits = concatMap f - where - f c | isAlpha c = [c] - | isDigit c = "QX" ++ [chr (ord c + 49)] - | otherwise = [] diff --git a/src/Documentation/Make.hs b/src/Documentation/Make.hs --- a/src/Documentation/Make.hs +++ b/src/Documentation/Make.hs @@ -11,27 +11,51 @@ ----------------------------------------------------------------------------- module Documentation.Make (DocItem(..), makeDocumentation) where +import Common.TestSuite import Common.Utils (Some(..)) +import Control.Monad +import Data.Maybe import Service.DomainReasoner import Documentation.SelfCheck -import Documentation.LatexRules import Documentation.ExercisePage +import Documentation.RulePage +import Documentation.TestsPage import Documentation.ServicePage import Documentation.OverviewPages -data DocItem = Pages String | LatexRules String | SelfCheck String +data DocItem = Pages | SelfCheck | BlackBox (Maybe String) deriving Eq -makeDocumentation :: DocItem -> DomainReasoner () -makeDocumentation doc = - case doc of - Pages dir -> do - makeOverviewExercises dir - makeOverviewServices dir - getPackages >>= mapM_ (\(Some pkg) -> makeExercisePage dir pkg) - getServices >>= mapM_ (\s -> makeServicePage dir s) - SelfCheck dir -> - performSelfCheck dir - LatexRules dir -> - let f (Some ex) = makeLatexRules dir ex - in getExercises >>= liftIO . mapM_ f +makeDocumentation :: String -> String -> DocItem -> DomainReasoner () +makeDocumentation docDir testDir item = + case item of + Pages -> do + report "Generating overview pages" + makeOverviewExercises docDir + makeOverviewServices docDir + report "Generating exercise pages" + pkgs <- getPackages + forM_ pkgs $ \(Some pkg) -> + makeExercisePage docDir pkg + report "Generating rule pages" + makeRulePages docDir + report "Generating service pages" + getServices >>= mapM_ (makeServicePage docDir) + report "Running tests" + makeTestsPage docDir testDir + SelfCheck -> do + checks <- selfCheck testDir + result <- liftIO (runTestSuiteResult checks) + liftIO (printSummary result) + BlackBox mdir -> do + run <- runWithCurrent + checks <- liftIO $ blackBoxTests run (fromMaybe testDir mdir) + result <- liftIO $ runTestSuiteResult checks + liftIO (printSummary result) + +report :: String -> DomainReasoner () +report s = liftIO $ do + let line = replicate 75 '-' + putStrLn line + putStrLn ("--- " ++ s) + putStrLn line diff --git a/src/Documentation/OverviewPages.hs b/src/Documentation/OverviewPages.hs --- a/src/Documentation/OverviewPages.hs +++ b/src/Documentation/OverviewPages.hs @@ -16,11 +16,12 @@ import Documentation.DefaultPage import Data.Char import Data.List +import Data.Maybe import Control.Monad -import Common.Utils (Some(..)) +import Common.Utils (Some(..), safeHead) import Common.Exercise -import Service.ServiceList import Service.DomainReasoner +import Service.Types import Text.HTML makeOverviewExercises :: String -> DomainReasoner () @@ -47,40 +48,40 @@ text "all exercises" text ", including the ones under development" - forM_ (zip [1..] groupedList) $ \(i, (dom, xs)) -> do + forM_ (zip [1::Int ..] (grouping list)) $ \(i, (dom, xs)) -> do h2 (show i ++ ". " ++ dom) - noBorderTable (map makeRow xs) + table (map makeRow xs) where title | showAll = "All exercises" | otherwise = "Exercises" makeRow (Some ex) = - [ do tt bullet >> space - link (exercisePageFile code) $ ttText (show code) + [ link (exercisePageFile code) $ ttText (show code) , do spaces 10 f (status ex) spaces 10 , text $ description ex ] where - code = exerciseCode ex + code = getId ex f st = italic $ text ("(" ++ map toLower (show st) ++ ")") - groupedList = process list + grouping = map g . groupBy eq . sortBy cmp . filter p where - process = map g . groupBy eq . sortBy cmp . filter p - - cmp (Some a) (Some b) = exerciseCode a `compare` exerciseCode b + cmp (Some a) (Some b) = compareId (exerciseId a) (exerciseId b) eq a b = f a == f b - f (Some ex) = domain (exerciseCode ex) - g xs = (f (head xs), xs) + f (Some ex) = safeHead (qualifiers (exerciseId ex)) + g xs = (fromMaybe "" (f (head xs)), xs) p (Some ex) = showAll || isPublic ex serviceOverviewPage :: [Service] -> HTMLBuilder serviceOverviewPage list = do h1 "Services" - let sorted = sortBy (\x y -> serviceName x `compare` serviceName y) list - ul $ flip map sorted $ \s -> do - link (servicePageFile s) (ttText (serviceName s)) - when (serviceDeprecated s) $ - space >> text "(deprecated)" + let (xs, ys) = partition serviceDeprecated (sortBy compareId list) + make s = link (servicePageFile s) (ttText (showId s)) + ul $ map make ys + unless (null xs) $ do + h2 "Deprecated" + ul $ map make xs + + diff --git a/src/Documentation/RulePage.hs b/src/Documentation/RulePage.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/RulePage.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.RulePage (makeRulePages) where + +import Common.Context +import Common.Exercise +import Common.Transformation +import Common.Utils (commaList, Some(..)) +import Control.Monad +import Data.List +import Documentation.DefaultPage +import Documentation.RulePresenter +import Service.DomainReasoner +import Service.ExercisePackage +import Service.RulesInfo (rewriteRuleToFMP, collectExamples, ExampleMap) +import Text.HTML +import Text.OpenMath.FMP +import Text.OpenMath.Object +import qualified Data.Map as M +import qualified Text.XML as XML + +data ExItem a = EI (ExercisePackage a) (ExampleMap a) + +makeRulePages :: String -> DomainReasoner () +makeRulePages dir = do + pkgs <- getPackages + let exMap = M.fromList + [ (getId pkg, Some (EI pkg (collectExamples (exercise pkg)))) + | Some pkg <- pkgs + ] + ruleMap = M.fromListWith (++) + [ (getId r, [Some pkg]) + | Some pkg <- pkgs + , r <- ruleset (exercise pkg) + ] + forM_ (M.toList ruleMap) $ \(ruleId, list@(Some pkg:_)) -> do + let noExamples = Some (EI pkg M.empty) + level = length (qualifiers ruleId) + 1 + usedIn = sortBy compareId [ getId pkg1 | Some pkg1 <- list ] + case M.findWithDefault noExamples (getId pkg) exMap of + Some (EI pkg1 e) -> do + let ex = exercise pkg1 + forM_ (getRule ex ruleId) $ \r -> + generatePageAt level dir (ruleFile ruleId) $ + rulePage ex e usedIn r + +rulePage :: Exercise a -> ExampleMap a -> [Id] -> Rule (Context a) -> HTMLBuilder +rulePage ex exMap usedIn r = do + idboxHTML "rule" (getId r) + let idList = text . commaList . map showId + para $ table + [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)] + , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)] + , [bold $ text "Groups", idList $ ruleGroups r] + , [bold $ text "Siblings", idList $ ruleSiblings r] + ] + when (isRewriteRule r) $ para $ + ruleToHTML (Some ex) r + + h3 "Used in exercises" + let f a = link (up ups ++ exercisePageFile a) (tt $ text $ show a) + ups = length (qualifiers r) + 1 + ul $ map f usedIn + + -- Examples + let ys = M.findWithDefault [] (getId r) exMap + unless (null ys) $ do + h3 "Examples" + forM_ (take 3 ys) $ \(a, b) -> para $ divClass "step" $ pre $ do + forTerm ex (inContext ex a) + forStep ups (getId r, emptyEnv) + forTerm ex (inContext ex b) + + -- FMPS + let xs = getRewriteRules r + unless (null xs) $ do + h3 "Formal Mathematical Properties" + forM_ xs $ \(Some rr, b) -> para $ do + let fmp = rewriteRuleToFMP b rr + highlightXML False $ XML.makeXML "FMP" $ + XML.builder (omobj2xml (toObject fmp)) + +idboxHTML :: String -> Id -> HTMLBuilder +idboxHTML kind i = divClass "idbox" $ do + para $ do + font "id" $ ttText (showId i) + spaces 3 + text $ "(" ++ kind ++ ")" + unless (null $ description i) $ + para $ italic $ text (description i) + +forStep :: Int -> (Id, Environment) -> HTMLBuilder +forStep n (i, env) = do + spaces 3 + text "=>" + space + let target = up n ++ ruleFile i + make | null (description i) = link target + | otherwise = linkTitle target (description i) + make (text (unqualified i)) + br + unless (nullEnv env) $ do + spaces 6 + text (show env) + br + +forTerm :: Exercise a -> Context a -> HTMLBuilder +forTerm ex ca = do + text (prettyPrinterContext ex ca) + br diff --git a/src/Documentation/RulePresenter.hs b/src/Documentation/RulePresenter.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/RulePresenter.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.RulePresenter (ruleToHTML) where + +import Common.Library +import Control.Monad +import Common.Utils (Some(..), safeHead) +import Common.Rewriting.Term +import Data.List +import Text.HTML + +ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder +ruleToHTML ex r = + forM_ (getRewriteRules r) $ \(Some rr, b) -> + rewriteRuleToHTML b ex rr + +rewriteRuleToHTML :: Bool -> Some Exercise -> RewriteRule a -> HTMLBuilder +rewriteRuleToHTML sound ex r = do + let lhs :~> rhs = ruleSpecTerm r + -- showRuleName (unqualified r) + -- spaces 3 + showTerm ex lhs + spaces 3 + showLeadsTo sound + spaces 3 + showTerm ex rhs + br + +{- +showRuleName :: String -> HTMLBuilder +showRuleName s = text ("[" ++ s ++ "]") +-} + +showLeadsTo :: Bool -> HTMLBuilder +showLeadsTo sound = text (if sound then "\x21D2" else "\x21CF") + +showTerm :: Some Exercise -> Term -> HTMLBuilder +showTerm (Some ex) = text . rec + where + rec term = + case term of + Var s -> s + Num i -> show i + Float a -> show a + Meta n -> showMeta ex n + _ -> concatMap (either id recp) $ + case getSpine term of + (Con s, xs) -> + case specialSymbol s xs of + Just ys -> ys + Nothing -> spaced (Left (show s) : map Right xs) + (x, xs) -> spaced (map Right (x:xs)) + + recp term = parIf (isApply term) (rec term) + spaced = intersperse (Left " ") + + isApply (Apply _ _) = True + isApply _ = False + + parIf b s = if b then "(" ++ s ++ ")" else s + +specialSymbol :: Symbol -> [Term] -> Maybe [Either String Term] +-- constants +specialSymbol s [] + | sameSymbol s "logic1.true" = con "T" + | sameSymbol s "logic1.false" = con "F" + | sameSymbol s "relalg.universe" = con "V" -- universe + | sameSymbol s "relalg.ident" = con "I" -- identity + where + con x = return [Left x] +-- unary symbols +specialSymbol s [a] + | sameSymbol s "logic1.not" = pref "\172" -- "~" + | sameSymbol s "arith1.unary_minus" = pref "-" + | sameSymbol s "relalg.not" = post "\x203E" + | sameSymbol s "relalg.inv" = post "~" + where + pref x = return [Left x, Right a] + post x = return [Right a, Left x] +-- binary symbols +specialSymbol s [a, b] + | sameSymbol s "logic1.or" = bin " \8744 " -- "||" + | sameSymbol s "logic1.and" = bin " \8743 " -- "&&" + | sameSymbol s "logic1.implies" = bin " \8594 " -- "->" + | sameSymbol s "logic1.equivalent" = bin " \8596 " -- "<->" + | sameSymbol s "relation1.eq" = bin " = " + | sameSymbol s "arith1.plus" = bin "+" + | sameSymbol s "arith1.minus" = bin "-" + | sameSymbol s "arith1.power" = bin "^" + | sameSymbol s "arith1.times" = bin "\x00B7" -- "*" + | sameSymbol s "arith1.divide" = bin "/" + | sameSymbol s "relalg.conj" = bin " \x2229 " -- intersect + | sameSymbol s "relalg.disj" = bin " \x222A " -- union + | sameSymbol s "relalg.comp" = bin " ; " -- composition + | sameSymbol s "relalg.add" = bin " \x2020 " -- relative addition/dagger + where + bin x = return [Right a, Left x, Right b] +specialSymbol s1 [Apply (Apply (Con s2) x) a] + | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" = + return [Left "D(", Right x, Left ") ", Right a] +specialSymbol _ _ = Nothing + +sameSymbol :: Symbol -> String -> Bool +sameSymbol = (==) . show + +showMeta :: Exercise a -> Int -> String +showMeta ex n + | safeHead (qualifiers ex) == Just "logic" = [ [c] | c <- ['p'..] ] !! n + | safeHead (qualifiers ex) == Just "relationalgebra" = [ [c] | c <- ['r'..] ] !! n + | otherwise = [ [c] | c <- ['a'..] ] !! n diff --git a/src/Documentation/SelfCheck.hs b/src/Documentation/SelfCheck.hs --- a/src/Documentation/SelfCheck.hs +++ b/src/Documentation/SelfCheck.hs @@ -9,87 +9,87 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Documentation.SelfCheck (performSelfCheck) where +module Documentation.SelfCheck (selfCheck, blackBoxTests) where -import Control.Monad.Trans import System.Directory -import Common.Utils (reportTest, useFixedStdGen, Some(..), snd3) +import Common.TestSuite +import Common.Utils (useFixedStdGen, Some(..), snd3) import Common.Exercise import Service.ExercisePackage -import qualified Common.Strategy.Grammar as Grammar import Control.Monad import Service.Request import Service.DomainReasoner - -import qualified Domain.LinearAlgebra.Checks as LA import Service.ModeJSON import Service.ModeXML - -import qualified Domain.Math.Numeric.Tests as MathNum -import qualified Domain.Math.Polynomial.Tests as MathPoly -import qualified Domain.Math.SquareRoot.Tests as MathSqrt -import qualified Domain.Math.Data.Interval as MathInterval - +import qualified Text.OpenMath.Tests as OpenMath import qualified Text.UTF8 as UTF8 import qualified Text.JSON as JSON import Data.List -import System.Time -performSelfCheck :: String -> DomainReasoner () -performSelfCheck dir = totalDiff $ do - timeDiff $ liftIO $ do - putStrLn "* 1. Domain checks" - Grammar.checks - MathNum.main - MathPoly.tests - MathSqrt.tests - MathInterval.testMe - LA.checks - UTF8.testEncoding - JSON.testMe - - liftIO $ putStrLn "* 2. Exercise checks" - pkgs <- getPackages - forM_ pkgs $ \(Some pkg) -> - timeDiff $ liftIO $ checkExercise (exercise pkg) - - timeDiff $ do - liftIO $ putStrLn "* 3. Unit tests" - n <- unitTests dir - liftIO $ putStrLn $ "** Number of unit tests: " ++ show n +selfCheck :: String -> DomainReasoner TestSuite +selfCheck dir = do + pkgs <- getPackages + domainSuite <- getTestSuite + run <- runWithCurrent + return $ do + suite "Framework checks" $ do + suite "Text encodings" $ do + addProperty "UTF8 encoding" UTF8.propEncoding + addProperty "JSON encoding" JSON.propEncoding + addProperty "OpenMath encoding" OpenMath.propEncoding + + suite "Domain checks" domainSuite + + suite "Exercise checks" $ + forM_ pkgs $ \(Some pkg) -> + exerciseTestSuite (exercise pkg) + + suite "Black box tests" $ do + liftIO (blackBoxTests run dir) >>= id + -- Returns the number of tests performed -unitTests :: String -> DomainReasoner Int -unitTests = visit 0 - where - visit i path = do - valid <- liftIO $ doesDirectoryExist path - if not valid then return 0 else do - -- analyse content - xs <- liftIO $ getDirectoryContents path - let xml = filter (".xml" `isSuffixOf`) xs - json = filter (".json" `isSuffixOf`) xs - liftIO $ putStrLn $ replicate (i+1) '*' ++ " " ++ simplerDirectory path - -- perform tests - forM json $ \x -> - performUnitTest JSON (path ++ "/" ++ x) - forM xml $ \x -> - performUnitTest XML (path ++ "/" ++ x) - -- recursively visit subdirectories - is <- forM (filter ((/= ".") . take 1) xs) $ \x -> - visit (i+1) (path ++ "/" ++ x) - return (length (xml ++ json) + sum is) +blackBoxTests :: (DomainReasoner Bool -> IO Bool) -> String -> IO TestSuite +blackBoxTests run path = do + putStrLn ("Scanning " ++ path) + -- analyse content + xs0 <- getDirectoryContents path + let (xml, xs1) = partition (".xml" `isSuffixOf`) xs0 + (json, xs2) = partition (".json" `isSuffixOf`) xs1 + -- perform tests + ts1 <- forM json $ \x -> + doBlackBoxTest run JSON (path ++ "/" ++ x) + ts2 <- forM xml $ \x -> + doBlackBoxTest run XML (path ++ "/" ++ x) + -- recursively visit subdirectories + ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do + let p = path ++ "/" ++ x + valid <- doesDirectoryExist p + if not valid + then return (return ()) + else liftM (suite $ "Directory " ++ simplerDirectory p) + (blackBoxTests run p) + return $ + sequence_ (ts1 ++ ts2 ++ ts3) -performUnitTest :: DataFormat -> FilePath -> DomainReasoner () -performUnitTest format path = do - liftIO useFixedStdGen -- fix the random number generator - txt <- liftIO $ readFile path - exp <- liftIO $ readFile expPath - out <- case format of - JSON -> liftM snd3 (processJSON txt) - XML -> liftM snd3 (processXML txt) - `catchError` \_ -> return "Error" - liftIO $ reportTest (stripDirectoryPart path) (out ~= exp) +doBlackBoxTest :: (DomainReasoner Bool -> IO Bool) -> DataFormat -> FilePath -> IO TestSuite +doBlackBoxTest run format path = do + b <- doesFileExist expPath + return $ if not b + then warn $ expPath ++ " does not exist" + else assertIO (stripDirectoryPart path) $ run $ do + -- Comparing output with expected output + liftIO useFixedStdGen -- fix the random number generator + txt <- liftIO $ readFile path + expt <- liftIO $ readFile expPath + out <- case format of + JSON -> liftM snd3 (processJSON txt) + XML -> liftM snd3 (processXML txt) + -- Conditional forces evaluation of the result, to make sure that + -- all file handles are closed afterwards. + if out ~= expt then return True else return False + `catchError` + \_ -> return False where expPath = baseOf path ++ ".exp" baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse @@ -118,33 +118,3 @@ rs = [ r | RewriteRule r <- concatMap transformations rwrs ] -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] -} - --- Helper functions -showDiffWith :: MonadIO m => (TimeDiff -> IO ()) -> m a -> m a -showDiffWith f action = do - t0 <- liftIO getClockTime - a <- action - t1 <- liftIO getClockTime - liftIO (f (diffClockTimes t1 t0)) - return a - -totalDiff :: MonadIO m => m a -> m a -totalDiff = showDiffWith (putStrLn . ("*** Total time: "++) . formatDiff) - -timeDiff :: MonadIO m => m a -> m a -timeDiff = showDiffWith (putStrLn . ("+++ Time: "++) . formatDiff) - -formatDiff :: TimeDiff -> String -formatDiff d@(TimeDiff z1 z2 z3 h m s p) - | any (/=0) [z1,z2,z3] = timeDiffToString d - | s >= 60 = formatDiff (timeDiff ((h*60+m)*60+s) p) - | h==0 && m==0 = show inSec ++ " secs" - | otherwise = show (60*h+m) ++ ":" ++ digSec ++ " mins" - where - milSec = 1000*toInteger s + p `div` 1000000000 - inSec = fromIntegral milSec / 1000 - digSec = (if s < 10 then ('0' :) else id) (show s) - timeDiff n p = - let (rest, s) = n `divMod` 60 - (h, m) = rest `divMod` 60 - in TimeDiff 0 0 0 h m s p diff --git a/src/Documentation/ServicePage.hs b/src/Documentation/ServicePage.hs --- a/src/Documentation/ServicePage.hs +++ b/src/Documentation/ServicePage.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -XRankNTypes #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -13,29 +14,25 @@ import Documentation.DefaultPage import Service.ExercisePackage -import Service.ServiceList import Service.TypedExample import Service.Types import Service.DomainReasoner -import Service.TypedAbstractService (emptyState) +import Service.State import Text.HTML import qualified Text.XML as XML -import Text.XML (XML, showXML) -import Domain.Logic -import Domain.Math.Polynomial.Exercises -import Domain.Math.Data.Relation -import Domain.Math.Expr.Symbolic +import Text.XML (XML) import Control.Monad -import Common.Utils (ShowString(..)) +import Common.Exercise +import Common.Utils (Some(..)) makeServicePage :: String -> Service -> DomainReasoner () makeServicePage dir s = do - xs <- examplesFor (serviceName s) + xs <- examplesFor (showId s) generatePageAt 1 dir (servicePageFile s) (servicePage xs s) servicePage :: [Example] -> Service -> HTMLBuilder -servicePage examples s = do - h1 (serviceName s) +servicePage xs s = do + h1 (showId s) para $ do bold $ text "Signature:" @@ -45,20 +42,20 @@ para $ do bold $ text "Description: " br - text $ serviceDescription s + text $ description s when (serviceDeprecated s) $ para $ bold $ text "Warning: this service is deprecated!" - unless (null examples) $ do - h2 $ "XML examples (" ++ show (length examples) ++ ")" - forM_ (zip [1..] examples) $ + unless (null xs) $ do + h2 $ "XML examples (" ++ show (length xs) ++ ")" + forM_ (zip [1::Int ..] xs) $ \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do h2 $ show i ++ ". " ++ msg bold $ text "Request:" - preText $ showXML xmlRequest + highlightXML True xmlRequest bold $ text "Reply:" - preText $ showXML xmlReply + highlightXML True xmlReply unless xmlTest $ XML.element "font" $ do "color" XML..=. "red" @@ -70,30 +67,53 @@ type Example = (String, (XML, XML, Bool)) examplesFor :: String -> DomainReasoner [Example] -examplesFor s = sequence [ m | (t, m) <- list, s == t ] +examplesFor s = tryAll [ f t | (t, f) <- list, s == t ] where list = - [ logic "derivation" [Nothing ::: Maybe StrategyCfg, stLogic1] - , lineq "derivation" [Nothing ::: Maybe StrategyCfg, stLineq1] - , logic "allfirsts" [stLogic2] - , lineq "allfirsts" [stLineq2] - , logic "onefirst" [stLogic2] - , lineq "onefirst" [stLineq2] --- , logic "applicable" [[] ::: Location, stLogic1] - , lineq "rulesinfo" [] - , lineq "rulelist" [linearExercise ::: Exercise] - , lineq "strategyinfo" [linearExercise ::: Exercise] + [ ("derivation", makeExample "logic.dnf" (noCfg +++ logic1)) + , ("derivation", makeExample "math.lineq" (noCfg +++ lineq1)) + , ("allfirsts", makeExample "logic.dnf" logic2) + , ("allfirsts", makeExample "math.lineq" lineq2) + , ("onefirst", makeExample "logic.dnf" logic2) + , ("onefirst", makeExample "math.lineq" lineq2) + , ("rulesinfo", makeExample "math.lineq" noArgs) + , ("rulelist", makeExample "math.lineq" exArgs) + , ("strategyinfo", makeExample "math.lineq" exArgs) + , ("examples", makeExample "math.lineq" exArgs) ] - strVar = Var . ShowString - stLogic1 = emptyState dnfExercise (Not (strVar "p" :&&: Not (strVar "q"))) ::: State - stLogic2 = emptyState dnfExercise (Not (Not (strVar "p")) :&&: Not T) ::: State - stLineq1 = emptyState linearExercise (5*(variable "x"+1) :==: 11) ::: State - stLineq2 = emptyState linearExercise (5*(variable "x"+1) :==: (variable "x"-1)/2) ::: State - logic = make "Logic" (package dnfExercise) - lineq = make "Linear equation" (termPackage linearExercise) + logic1, logic2 :: Args + logic1 pkg = newState pkg "~(p /\\ ~q)" + logic2 pkg = newState pkg "~~p /\\ T" + + lineq1, lineq2 :: Args + lineq1 pkg = newState pkg "5*(x+1) == 11" + lineq2 pkg = newState pkg "5*(x+1) == (x-1)/2" + + (f +++ g) pkg = f pkg ++ g pkg + + noCfg _ = [Nothing ::: maybeTp StrategyCfg] + noArgs _ = [] + exArgs pkg = [pkg ::: ExercisePkg] + +tryAll :: [DomainReasoner a] -> DomainReasoner [a] +tryAll xs = + let f m = liftM return m `catchError` const (return []) + in liftM concat (mapM f xs) - make msg pkg fs args = (fs, do - srv <- findService fs - tr <- typedExample pkg srv args - return (msg, tr)) +newState :: Monad m => ExercisePackage a -> String -> m (TypedValue a) +newState pkg s = do + let ex = exercise pkg + case parser ex s of + Left msg -> fail ("newState: " ++ msg) + Right a -> return (emptyState pkg a ::: stateTp) + +type Args = forall a . ExercisePackage a -> [TypedValue a] + +makeExample :: String -> Args -> String -> DomainReasoner Example +makeExample pkgName f srvName = do + let a = newId pkgName + Some pkg <- findPackage a + srv <- findService srvName + tr <- typedExample pkg srv (f pkg) + return (showId pkg, tr) diff --git a/src/Documentation/TestsPage.hs b/src/Documentation/TestsPage.hs --- a/src/Documentation/TestsPage.hs +++ b/src/Documentation/TestsPage.hs @@ -9,80 +9,68 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Documentation.TestsPage (main) where +module Documentation.TestsPage (makeTestsPage) where -import Control.Monad -import Data.Char -import Data.List +import Common.TestSuite import Documentation.DefaultPage +import Documentation.SelfCheck import Service.DomainReasoner -import System.Environment -import Main.Revision import Text.HTML import qualified Text.XML as XML -main :: IO () -main = do - args <- getArgs - case args of - [fileIn, fileOut] -> do - input <- readFile fileIn - runDomainReasoner $ do - setFullVersion fullVersion - generatePage "docs" (up 1 ++ fileOut) (testsPage input) - _ -> fail "Invalid invocation" - -fullVersion :: String -fullVersion = "version " ++ version ++ " (revision " ++ show revision ++ ", " ++ lastChanged ++ ")" +makeTestsPage :: String -> String -> DomainReasoner () +makeTestsPage docDir testDir = do + checks <- selfCheck testDir + result <- liftIO (runTestSuiteResult checks) + generatePage docDir testsPageFile (testsPage result) -testsPage :: String -> HTMLBuilder -testsPage input = do +testsPage :: TestSuiteResult -> HTMLBuilder +testsPage result = do + h1 "Summary" + preText (makeSummary result) h1 "Tests" - let (hs, bs) = unzip (map format (lines input)) - bold (text "Failures: ") - text $ show $ length $ filter not bs - brs hs - where - format :: String -> (HTMLBuilder, Bool) - format s - | any (`elem` ws) ["failed", "error", "error:", "falsifiable"] = - (errorLine (ttText s), False) - | "* " `isPrefixOf` s = - (h2 (drop 2 s), True) - | "** " `isPrefixOf` s = - (br >> bold (text (drop 3 s)), True) - | "*** " `isPrefixOf` s = - (br >> bold (text (drop 4 s)), True) - | otherwise = - (fromString s, True) - where - ws = map (map toLower . filter isAlpha) (words s) - - -brs :: [HTMLBuilder] -> HTMLBuilder -brs = mapM_ (>> br) + makeTestLogWith formatHTML result + +formatHTML :: FormatLog HTMLBuilder +formatHTML = FormatLog + { formatRoot = \_ -> id + , formatSuite = \loc s _ _ a -> + showHeader loc s >> a + , formatSuccesses = \xs -> + let f (_, n) = if n==1 then "." else "(passed " ++ show n ++ " tests)" + in mapM_ (\s -> ttText s >> br) (breakLine (concatMap f xs)) + , formatFailure = \s msg -> colorRed $ do + bold (ttText ("Error" ++ putLabel s)) + tt space + ttText msg + br + , formatWarning = \s msg -> colorOrange $ do + ttText ("Warning" ++ putLabel s) + tt space + ttText msg + br + } + where + putLabel s = if null s then ":" else " (" ++ s ++ "):" -fromString :: String -> HTMLBuilder -fromString = f [] +breakLine :: String -> [String] +breakLine xs + | null xs = [] + | otherwise = ys : breakLine zs where - f acc [] = ttText (reverse acc) - f acc list@(x:xs) - | "+++" `isPrefixOf` list = do - f acc [] - unless (null acc) (spaces 3) - okLine (ttText (drop 3 list)) - | "*** Gave up!" `isPrefixOf` list = do - f acc [] - unless (null acc) (spaces 3) - ttText (drop 3 list) - | otherwise = f (x:acc) xs + (ys, zs) = splitAt 80 xs -errorLine :: HTMLBuilder -> HTMLBuilder -errorLine b = XML.element "font" $ do +showHeader :: [Int] -> String -> HTMLBuilder +showHeader [a] s = h2 (show a ++ ". " ++ s) +showHeader [a,b] s = h3 (show a ++ "." ++ show b ++ ". " ++ s) +showHeader _ s = para (bold (text s)) + +colorRed :: HTMLBuilder -> HTMLBuilder +colorRed body = XML.element "font" $ do "color" XML..=. "red" - bold b + body -okLine :: HTMLBuilder -> HTMLBuilder -okLine b = XML.element "font" $ do - "color" XML..=. "gray" - b +colorOrange :: HTMLBuilder -> HTMLBuilder +colorOrange body = XML.element "font" $ do + "color" XML..=. "#FE9A2E" + body 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 @@ -11,10 +11,10 @@ ----------------------------------------------------------------------------- module Domain.LinearAlgebra.Checks (checks) where -import Common.Apply +import Common.Classes import Common.Context import Common.Exercise -import Common.Utils +import Common.TestSuite import Domain.LinearAlgebra hiding (getSolution) import Domain.Math.Expr import Domain.Math.Simplification (simplify) @@ -23,13 +23,13 @@ ----------------------------------------------------------- --- QuickCheck properties -checks :: IO () -checks = do - putStrLn "** Linear algebra" - thoroughCheck propEchelon - thoroughCheck propReducedEchelon - thoroughCheck propSound - thoroughCheck propSolution +checks :: TestSuite +checks = suite "Linear algebra" $ do + let thorough = stdArgs {maxSize = 500, maxSuccess = 500} + addPropertyWith "echelon" thorough propEchelon + addPropertyWith "reduced echelon" thorough propReducedEchelon + addPropertyWith "sound" thorough propSound + addPropertyWith "solution" thorough propSolution propEchelon :: Matrix Rational -> Bool propEchelon = 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 @@ -16,6 +16,7 @@ import Common.Transformation import Common.Utils import Common.Navigator +import Common.Id import Common.View hiding (simplify) import Control.Monad import Data.List hiding (repeat) @@ -37,7 +38,8 @@ ] ruleExchangeEquations :: Rule (Context (LinearSystem Expr)) -ruleExchangeEquations = simplifySystem $ makeRule "Exchange" $ +ruleExchangeEquations = describe "Exchange two equations" $ + simplifySystem $ makeRule "linearalgebra.linsystem.exchange" $ supplyLabeled2 descr args (\x y -> liftTransContext $ exchange x y) where descr = ("equation 1", "equation 2") @@ -49,7 +51,8 @@ return (cov, cov + i) ruleEliminateVar :: Rule (Context (LinearSystem Expr)) -ruleEliminateVar = simplifySystem $ makeRule "Eliminate variable" $ +ruleEliminateVar = describe "Eliminate a variable (using addition)" $ + simplifySystem $ makeRule "linearalgebra.linsystem.eliminate" $ supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z) where descr = ("equation 1", "equation 2", "scale factor") @@ -64,20 +67,23 @@ return (i + cov + 1, cov, v) ruleDropEquation :: Rule (Context (LinearSystem Expr)) -ruleDropEquation = simplifySystem $ makeSimpleRule "Drop (0=0) equation" $ withCM $ \ls -> do - i <- findIndexM (fromMaybe False . testConstants (==)) ls - modifyVar covered (\n -> if i < n then n-1 else n) - return (deleteIndex i ls) +ruleDropEquation = describe "Drop trivial equations (such as 0=0)" $ + simplifySystem $ makeSimpleRule "linearalgebra.linsystem.trivial" $ withCM $ \ls -> do + i <- findIndexM (fromMaybe False . testConstants (==)) ls + modifyVar covered (\n -> if i < n then n-1 else n) + return (deleteIndex i ls) ruleInconsistentSystem :: Rule (Context (LinearSystem Expr)) -ruleInconsistentSystem = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ withCM $ \ls -> do - let stop = [0 :==: 1] - guard (invalidSystem ls && ls /= stop) - writeVar covered 1 - return stop +ruleInconsistentSystem = describe "Inconsistent system (0=1)" $ + simplifySystem $ makeSimpleRule "linearalgebra.linsystem.inconsistent" $ withCM $ \ls -> do + let stop = [0 :==: 1] + guard (invalidSystem ls && ls /= stop) + writeVar covered 1 + return stop ruleScaleEquation :: Rule (Context (LinearSystem Expr)) -ruleScaleEquation = simplifySystem $ makeRule "Scale equation to one" $ +ruleScaleEquation = describe "Scale equation to one" $ + simplifySystem $ makeRule "linearalgebra.linsystem.scale" $ supplyLabeled2 descr args (\x y -> liftTransContext $ scaleEquation x y) where descr = ("equation", "scale factor") @@ -91,7 +97,8 @@ return (cov, coef) ruleBackSubstitution :: Rule (Context (LinearSystem Expr)) -ruleBackSubstitution = simplifySystem $ makeRule "Back substitution" $ +ruleBackSubstitution = describe "Back substitution" $ + simplifySystem $ makeRule "linearalgebra.linsystem.subst" $ supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z) where descr = ("equation 1", "equation 2", "scale factor") @@ -99,29 +106,33 @@ cov <- readVar covered eq <- maybeCM $ safeHead $ drop cov ls let expr = leftHandSide eq - mv <- maybeCM $ safeHead (getVars expr) + mv <- maybeCM $ safeHead (vars expr) i <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls) let coef = negate $ coefficientOf mv (leftHandSide (ls !! i)) return (i, cov, coef) ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a)) -ruleIdentifyFreeVariables = minorRule $ makeSimpleRule "Identify free variables" $ withCM $ \ls -> - let vars = [ head ys | ys <- map (getVars . leftHandSide) ls, not (null ys) ] - change eq = - let (e1, e2) = splitLinearExpr (`notElem` vars) (leftHandSide eq) -- constant ends up in e1 +ruleIdentifyFreeVariables = describe "Identify free variables" $ + minorRule $ makeSimpleRule "linearalgebra.linsystem.freevars" $ withCM $ \ls -> + let vs = [ head ys | ys <- map (vars . leftHandSide) ls, not (null ys) ] + f eq = + let (e1, e2) = splitLinearExpr (`notElem` vs) (leftHandSide eq) -- constant ends up in e1 in e2 :==: rightHandSide eq - e1 - in return (map change ls) + in return (map f ls) ruleCoverUpEquation :: Rule (Context (LinearSystem a)) -ruleCoverUpEquation = minorRule $ makeRule "Cover up first equation" $ changeCover (+1) +ruleCoverUpEquation = describe "Cover up first equation" $ + minorRule $ makeRule "linearalgebra.linsystem.coverup" $ changeCover succ ruleUncoverEquation :: Rule (Context (LinearSystem a)) -ruleUncoverEquation = minorRule $ makeRule "Uncover one equation" $ changeCover (\x -> x-1) +ruleUncoverEquation = describe "Uncover one equation" $ + minorRule $ makeRule "linearalgebra.linsystem.uncover" $ changeCover pred ruleCoverAllEquations :: Rule (Context (LinearSystem a)) -ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ withCM $ \ls -> do - writeVar covered (length ls) - return ls +ruleCoverAllEquations = describe "Cove all equations" $ + minorRule $ makeSimpleRule "linearalgebra.linsystem.coverall" $ withCM $ \ls -> do + writeVar covered (length ls) + return ls -- local helper functions deleteIndex :: Int -> [a] -> [a] @@ -130,7 +141,7 @@ testConstants :: IsLinear a => (a -> a -> Bool) -> Equation a -> Maybe Bool testConstants f (lhs :==: rhs) - | isConstant lhs && isConstant rhs = Just (f lhs rhs) + | hasNoVar lhs && hasNoVar rhs = Just (f lhs rhs) | otherwise = Nothing -- simplify a linear system 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 @@ -14,7 +14,7 @@ , gaussianElimExercise, systemWithMatrixExercise ) where -import Common.Apply +import Common.Classes import Common.Context import Common.Exercise import Common.Transformation @@ -34,8 +34,8 @@ gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr)) gramSchmidtExercise = makeExercise - { description = "Gram-Schmidt" - , exerciseCode = makeCode "linalg" "gramschmidt" + { exerciseId = describe "Gram-Schmidt" $ + newId "linearalgebra.gramschmidt" , status = Alpha , parser = \s -> case parseVectorSpace s of Right a -> Right (fmap simplified a) @@ -52,8 +52,8 @@ linearSystemExercise :: Exercise (Equations Expr) linearSystemExercise = makeExercise - { description = "Solve Linear System" - , exerciseCode = makeCode "linalg" "linsystem" + { exerciseId = describe "Solve Linear System" $ + newId "linearalgebra.linsystem" , status = Stable , parser = \s -> case parseSystem s of Right a -> Right (simplify a) @@ -65,6 +65,7 @@ (Just a, Just b) -> getSolution a == getSolution b _ -> False , extraRules = equationsRules + , ruleOrdering = ruleOrderingWithId [getId ruleScaleEquation] , isReady = inSolvedForm , strategy = linearSystemStrategy , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix) @@ -72,8 +73,8 @@ gaussianElimExercise :: Exercise (Matrix Expr) gaussianElimExercise = makeExercise - { description = "Gaussian Elimination" - , exerciseCode = makeCode "linalg" "gaussianelim" + { exerciseId = describe "Gaussian Elimination" $ + newId "linearalgebra.gaussianelim" , status = Stable , parser = \s -> case parseMatrix s of Right a -> Right (simplify a) @@ -88,8 +89,8 @@ systemWithMatrixExercise :: Exercise Expr systemWithMatrixExercise = makeExercise - { description = "Solve Linear System with Matrix" - , exerciseCode = makeCode "linalg" "systemwithmatrix" + { exerciseId = describe "Solve Linear System with Matrix" $ + newId "linearalgebra.systemwithmatrix" , status = Provisional , parser = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of (Right ok, _) -> Right $ toExpr ok @@ -106,7 +107,7 @@ in case (f x, f y) of (Just a, Just b) -> equivalence linearSystemExercise a b _ -> False - , extraRules = map liftExpr equationsRules ++ map liftExpr (matrixRules :: [Rule (Context (Matrix Expr))]) + , extraRules = map useC equationsRules ++ map useC (matrixRules :: [Rule (Context (Matrix Expr))]) , isReady = inSolvedForm . (fromExpr :: Expr -> Equations Expr) , strategy = systemWithMatrixStrategy , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr))) @@ -115,36 +116,10 @@ -------------------------------------------------------------- -- Other stuff (to be cleaned up) - -instance Arbitrary a => Arbitrary (Vector a) where - arbitrary = liftM fromList $ oneof $ map vector [0..2] -instance CoArbitrary a => CoArbitrary (Vector a) where - coarbitrary = coarbitrary . toList -instance Arbitrary a => Arbitrary (VectorSpace a) where - arbitrary = do - i <- choose (0, 3) -- too many vectors "disables" prime factorization - j <- choose (0, 10 `div` i) - xs <- replicateM i (liftM fromList $ replicateM j arbitrary) - return $ makeVectorSpace xs -instance CoArbitrary a => CoArbitrary (VectorSpace a) where - coarbitrary = coarbitrary . vectors - arbMatrix :: Num a => Gen (Matrix a) arbMatrix = fmap (fmap fromInteger) arbNiceMatrix - -instance Arbitrary a => Arbitrary (Matrix a) where - arbitrary = do - (i, j) <- arbitrary - arbSizedMatrix (i `mod` 5, j `mod` 5) -instance CoArbitrary a => CoArbitrary (Matrix a) where - coarbitrary = coarbitrary . rows -arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a) -arbSizedMatrix (i, j) = - do rows <- replicateM i (vector j) - return (makeMatrix rows) - arbUpperMatrix :: (Enum a, Num a) => Gen (Matrix a) arbUpperMatrix = do a <- oneof $ map return [-5 .. 5] 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 @@ -16,41 +16,44 @@ import Domain.LinearAlgebra.LinearView import Data.List import Data.Maybe +import Common.Classes import Control.Monad import Common.Utils import Common.Uniplate +import Common.Rewriting +import qualified Data.Set as S type LinearSystem a = Equations a getVarsSystem :: IsLinear a => LinearSystem a -> [String] -getVarsSystem = foldr (\(lhs :==: rhs) xs -> getVars lhs `union` getVars rhs `union` xs) [] +getVarsSystem = S.toList . S.unions . map varSet . concatMap crush evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool evalSystem f = - let eval (x :==: y) = x==y - in all (eval . fmap (evalLinearExpr f)) + let evalEq (x :==: y) = x==y + in all (evalEq . fmap (evalLinearExpr f)) invalidSystem :: IsLinear a => LinearSystem a -> Bool invalidSystem = any invalidEquation invalidEquation :: IsLinear a => Equation a -> Bool -invalidEquation (lhs :==: rhs) = null (getVars lhs ++ getVars rhs) && getConstant lhs /= getConstant rhs +invalidEquation (lhs :==: rhs) = hasNoVar lhs && hasNoVar rhs && getConstant lhs /= getConstant rhs getSolution :: IsLinear a => LinearSystem a -> Maybe [(String, a)] getSolution xs = do - guard (distinct vars) - guard (null (vars `intersect` frees)) + guard (distinct vs) + guard (null (vs `intersect` frees)) mapM make xs where - vars = concatMap (getVars . leftHandSide) xs - frees = concatMap (getVars . rightHandSide) xs + vs = concatMap (vars . leftHandSide) xs + frees = concatMap (vars . rightHandSide) xs make (lhs :==: rhs) = do - v <- isVar lhs + v <- getVariable lhs return (v, rhs) -- No constant on the left, no variables on the right inStandardForm :: IsLinear a => Equation a -> Bool -inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && null (getVars rhs) +inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && hasNoVar rhs toStandardForm :: IsLinear a => Equation a -> Equation a toStandardForm (lhs :==: rhs) = @@ -66,11 +69,11 @@ -- Conversions systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String]) -systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vars) +systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vs) where - vars = getVarsSystem system + vs = getVarsSystem system makeRow (lhs :==: rhs) = - map (`coefficientOf` lhs) vars ++ [getConstant rhs] + map (`coefficientOf` lhs) vs ++ [getConstant rhs] matrixToSystem :: IsLinear a => Matrix a -> LinearSystem a matrixToSystem = matrixToSystemWith variables @@ -81,7 +84,7 @@ varList = vs ++ (variables \\ vs) makeEquation [] = 0 :==: 0 makeEquation xs = - let lhs = sum (zipWith (\v a -> a * var v) varList (init xs)) + let lhs = sum (zipWith (\v a -> a * variable v) varList (init xs)) rhs = last xs in lhs :==: rhs 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 @@ -10,16 +10,16 @@ -- ----------------------------------------------------------------------------- module Domain.LinearAlgebra.LinearView - ( IsLinear(..), var, isVar, isConstant, renameVariables + ( IsLinear(..), LinearMap, renameVariables , splitLinearExpr, evalLinearExpr, linearView - , LinearMap ) where import Control.Monad import Data.List +import Common.Rewriting import Common.Uniplate -import Common.View hiding (simplify) -import Domain.Math.Expr hiding (isVariable) +import Common.View +import Domain.Math.Expr import qualified Data.Map as M data LinearMap a = LM { lmMap :: M.Map String a, lmConstant :: a } @@ -73,73 +73,35 @@ guard (M.null m) return $ LM M.empty (sqrt c) -symLM :: Symbolic a => Symbol -> [LinearMap a] -> Maybe (LinearMap a) +symLM :: WithFunctions a => Symbol -> [LinearMap a] -> Maybe (LinearMap a) symLM f ps = do guard (all (M.null . lmMap) ps) return $ LM M.empty (function f (map lmConstant ps)) -class (Fractional a, Symbolic a) => IsLinear a where - isLinear :: a -> Bool - isVariable :: a -> Maybe String - getVars :: a -> [String] - getConstant :: a -> a - coefficientOf :: String -> a -> a +class (Fractional a, Uniplate a, WithVars a) => IsLinear a where + isLinear :: a -> Bool + getConstant :: a -> a + coefficientOf :: String -> a -> a instance IsLinear Expr where - - isLinear expr = belongsTo expr linearView - - isVariable expr = - case expr of - Var s -> Just s - _ -> Nothing - - getVars = collectVars - - getConstant expr = - case match linearView expr of - Just (LM _ c) -> c - _ -> 0 - - coefficientOf s expr = - case match linearView expr of - Just (LM m _) -> M.findWithDefault 0 s m - _ -> 0 - -{- instance IsLinear SExpr where - isLinear = isLinear . toExpr - isVariable = isVariable . toExpr - getVars = getVars . toExpr - getConstant = simplifyExpr . getConstant . toExpr - coefficientOf s = simplifyExpr . coefficientOf s . toExpr -} + isLinear = (`belongsTo` linearView) + getConstant = maybe 0 lmConstant . match linearView + coefficientOf s = maybe 0 (M.findWithDefault 0 s . lmMap) . match linearView splitLinearExpr :: IsLinear a => (String -> Bool) -> a -> (a, a) splitLinearExpr f a = (make (getConstant a) xs, make 0 ys) where - (xs, ys) = partition f (getVars a) - make = foldr (\v r -> coefficientOf v a * var v + r) + (xs, ys) = partition f (vars a) + make = foldr (\v r -> coefficientOf v a * variable v + r) -evalLinearExpr :: (IsLinear a, Uniplate a) => (String -> a) -> a -> a +evalLinearExpr :: IsLinear a => (String -> a) -> a -> a evalLinearExpr f a = - case isVariable a of + case getVariable a of Just s -> f s - Nothing -> g $ map (evalLinearExpr f) cs - where - (cs, g) = uniplate a + Nothing -> descend (evalLinearExpr f) a -renameVariables :: (IsLinear a, Uniplate a) => (String -> String) -> a -> a +renameVariables :: IsLinear a => (String -> String) -> a -> a renameVariables f a = - case isVariable a of + case getVariable a of Just s -> variable (f s) - Nothing -> g $ map (renameVariables f) cs - where - (cs, g) = uniplate a - -isConstant :: IsLinear a => a -> Bool -isConstant = null . getVars - -var :: IsLinear a => String -> a -var = variable - -isVar :: IsLinear a => a -> Maybe String -isVar = isVariable + Nothing -> descend (renameVariables f) a 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 @@ -21,10 +21,15 @@ , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular ) where +import Common.Classes +import Common.Rewriting hiding (inverse) import Control.Monad -import Data.Maybe import Data.List hiding (transpose) -import Common.Traversable +import Data.Maybe +import Domain.Math.Simplification +import Domain.Math.Expr.Symbols (openMathSymbol) +import Test.QuickCheck +import qualified Text.OpenMath.Dictionary.Linalg2 as OM import qualified Data.List as L import qualified Data.Map as M @@ -36,16 +41,42 @@ type Column a = [a] instance Functor Matrix where - fmap f (M rows) = M (map (map f) rows) - -instance Once Matrix where - onceM f (M xss) = do - yss <- onceM (onceM f) xss - return (M yss) + fmap f (M rs) = M (map (map f) rs) instance Switch Matrix where switch (M xss) = liftM M (mapM sequence xss) +instance IsTerm a => IsTerm (Matrix a) where + toTerm = + let f = function matrixrowSymbol . map toTerm + in function matrixSymbol . map f . rows + fromTerm a = do + rs <- isFunction matrixSymbol a + xss <- mapM (isFunction matrixrowSymbol) rs + yss <- mapM (mapM fromTerm) xss + guard (isRectangular yss) + return (makeMatrix yss) + +instance Arbitrary a => Arbitrary (Matrix a) where + arbitrary = do + (i, j) <- arbitrary + arbSizedMatrix (i `mod` 5, j `mod` 5) + +instance CoArbitrary a => CoArbitrary (Matrix a) where + coarbitrary = coarbitrary . rows + +arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a) +arbSizedMatrix (i, j) = + do rs <- replicateM i (vector j) + return (makeMatrix rs) + +matrixSymbol, matrixrowSymbol :: Symbol +matrixSymbol = openMathSymbol OM.matrixSymbol +matrixrowSymbol = openMathSymbol OM.matrixrowSymbol + +instance Simplify a => Simplify (Matrix a) where + simplifyWith opt = fmap (simplifyWith opt) + -- Check whether the table is rectangular isRectangular :: [[a]] -> Bool isRectangular xss = @@ -55,10 +86,10 @@ -- Constructor function that checks whether the table is rectangular makeMatrix :: [Row a] -> Matrix a -makeMatrix rows - | null (concat rows) = M [] - | isRectangular rows = M rows - | otherwise = error "makeMatrix: not rectangular" +makeMatrix rs + | null (concat rs) = M [] + | isRectangular rs = M rs + | otherwise = error "makeMatrix: not rectangular" identity :: Num a => Int -> Matrix a identity n = M $ map f [0..n-1] @@ -68,7 +99,7 @@ isEmpty (M xs) = null xs rows :: Matrix a -> [Row a] -rows (M rows) = rows +rows (M rs) = rs row :: Int -> Matrix a -> Row a row n = (!!n) . rows @@ -86,7 +117,7 @@ entry (i, j) m = row i m !! j mapWithPos :: ((Int, Int) -> a -> b) -> Matrix a -> Matrix b -mapWithPos f (M rows) = M $ zipWith g [0..] rows +mapWithPos f (M rs) = M $ zipWith g [0..] rs where g y = zipWith (\x -> f (y, x)) [0..] changeEntries :: M.Map (Int, Int) (a -> a) -> Matrix a -> Matrix a @@ -176,7 +207,7 @@ ------------------------------------------------------- transpose :: Matrix a -> Matrix a -transpose (M rows) = M (L.transpose rows) +transpose (M rs) = M (L.transpose rs) ------------------------------------------------------- @@ -195,30 +226,30 @@ checkRow i m = i >= 0 && i < fst (dimensions m) switchRows :: Int -> Int -> Matrix a -> Matrix a -switchRows i j m@(M rows) +switchRows i j m@(M rs) | i == j = m | i > j = switchRows j i m | checkRow i m && checkRow j m = - let (before, r1:rest) = splitAt i rows + let (before, r1:rest) = splitAt i rs (middle, r2:after) = splitAt (j-i-1) rest in M $ before ++ [r2] ++ middle ++ [r1] ++ after | otherwise = error "switchRows: invalid rows" scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a -scaleRow i a m@(M rows) +scaleRow i a m@(M rs) | checkRow i m = let f y = if y==i then map (*a) else id - in M $ zipWith f [0..] rows + in M $ zipWith f [0..] rs | otherwise = error "scaleRow: invalid row" addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a -addRow i j a m@(M rows) +addRow i j a m@(M rs) | checkRow i m && checkRow j m = let rj = map (*a) (row j m) f y = if y==i then zipWith (+) rj else id - in M $ zipWith f [0..] rows + in M $ zipWith f [0..] rs | otherwise = error "addRow: invalid row" @@ -233,9 +264,9 @@ where check n = all (==0) . take n inRowEchelonForm :: Num a => Matrix a -> Bool -inRowEchelonForm (M rows) = - null (filter nonZero (dropWhile nonZero rows)) && - increasing (map (length . takeWhile (==0)) (filter nonZero rows)) +inRowEchelonForm (M rs) = + null (filter nonZero (dropWhile nonZero rs)) && + increasing (map (length . takeWhile (==0)) (filter nonZero rs)) where increasing (x:ys@(y:_)) = x < y && increasing ys increasing _ = True @@ -245,10 +276,10 @@ -- or row canonical form inRowReducedEchelonForm :: Num a => Matrix a -> Bool -inRowReducedEchelonForm m@(M rows) = +inRowReducedEchelonForm m@(M rs) = inRowEchelonForm m && - all (==1) (mapMaybe pivot rows) && - all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rows) + all (==1) (mapMaybe pivot rs) && + all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs) pivot :: Num a => Row a -> Maybe a pivot r = case dropWhile (==0) r of 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 @@ -13,7 +13,6 @@ import Domain.Math.Simplification import Domain.LinearAlgebra.Matrix -import Domain.LinearAlgebra.Symbols () import Common.Context import Common.Navigator import Common.Transformation @@ -29,7 +28,7 @@ ] ruleFindColumnJ :: Num a => Rule (Context (Matrix a)) -ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ withCM $ \m -> do +ruleFindColumnJ = minorRule $ makeSimpleRule "linearalgebra.gaussianelim.FindColumnJ" $ withCM $ \m -> do cols <- liftM columns (subMatrix m) i <- findIndexM nonZero cols writeVar columnJ i @@ -76,24 +75,24 @@ return (k, cov, v) ruleCoverRow :: Rule (Context (Matrix a)) -ruleCoverRow = minorRule $ makeRule "CoverRow" $ changeCover (+1) +ruleCoverRow = minorRule $ makeRule "linearalgebra.gaussianelim.CoverRow" $ changeCover succ ruleUncoverRow :: Rule (Context (Matrix a)) -ruleUncoverRow = minorRule $ makeRule "UncoverRow" $ changeCover (\x -> x-1) +ruleUncoverRow = minorRule $ makeRule "linearalgebra.gaussianelim.UncoverRow" $ changeCover pred --------------------------------------------------------------------------------- -- Parameterized rules ruleScaleRow :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, a)) -> Rule (Context (Matrix a)) -ruleScaleRow f = makeRule "Scale" (supplyLabeled2 descr f rowScale) +ruleScaleRow f = makeRule "linearalgebra.gaussianelim.scale" (supplyLabeled2 descr f rowScale) where descr = ("row", "scale factor") ruleExchangeRows :: Num a => (Context (Matrix a) -> Maybe (Int, Int)) -> Rule (Context (Matrix a)) -ruleExchangeRows f = makeRule "Exchange" (supplyLabeled2 descr f rowExchange) +ruleExchangeRows f = makeRule "linearalgebra.gaussianelim.exchange" (supplyLabeled2 descr f rowExchange) where descr = ("row 1", "row 2") ruleAddMultiple :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, Int, a)) -> Rule (Context (Matrix a)) -ruleAddMultiple f = makeRule "Add" (supplyLabeled3 descr f rowAdd) +ruleAddMultiple f = makeRule "linearalgebra.gaussianelim.add" (supplyLabeled3 descr f rowAdd) where descr = ("row 1", "row2", "scale factor") --------------------------------------------------------------------------------- @@ -141,7 +140,7 @@ subMatrix :: Matrix a -> ContextMonad (Matrix a) subMatrix m = do cov <- readVar covered - return $ makeMatrix $ drop cov $ rows $ m + return $ makeMatrix $ drop cov $ rows m findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int findIndexM p = maybe mzero return . findIndex p 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 @@ -13,24 +13,20 @@ ( gaussianElimStrategy, linearSystemStrategy , gramSchmidtStrategy, systemWithMatrixStrategy , forwardPass - , liftExpr ) where import Prelude hiding (repeat) import Domain.Math.Expr -import Common.Rewriting import Domain.Math.Simplification import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.MatrixRules import Domain.LinearAlgebra.EquationsRules import Domain.LinearAlgebra.GramSchmidtRules import Domain.LinearAlgebra.LinearSystem -import Domain.LinearAlgebra.Symbols () -import Common.Apply -import Common.Navigator import Common.Strategy hiding (not) import Common.Transformation import Common.Context +import Common.Id import Domain.LinearAlgebra.Vector gaussianElimStrategy :: LabeledStrategy (Context (Matrix Expr)) @@ -92,11 +88,11 @@ systemWithMatrixStrategy :: LabeledStrategy (Context Expr) systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $ - repeat (mapRules liftExpr dropEquation) + repeat (mapRules useC dropEquation) <*> conv1 - <*> mapRules liftExpr gaussianElimStrategy + <*> mapRules useC gaussianElimStrategy <*> conv2 - <*> repeat (mapRules liftExpr dropEquation) + <*> repeat (mapRules useC dropEquation) gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr))) gramSchmidtStrategy = @@ -105,29 +101,24 @@ <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal)) <*> label "Normalize" (try ruleNormalize) -vars :: Var [String] -vars = newVar "variables" [] +varVars :: Var [String] +varVars = newVar "variables" [] simplifyFirst :: Rule (Context (LinearSystem Expr)) simplifyFirst = simplifySystem idRule conv1 :: Rule (Context Expr) -conv1 = makeSimpleRule "Linear system to matrix" $ withCM $ \expr -> do - ls <- fromExpr expr - let (m, vs) = systemToMatrix ls - writeVar vars vs - return (toExpr (simplify (m :: Matrix Expr))) +conv1 = describe "Convert linear system to matrix" $ + makeSimpleRule "linearalgebra.linsystem.tomatrix" $ withCM $ \expr -> do + ls <- fromExpr expr + let (m, vs) = systemToMatrix ls + writeVar varVars vs + return (toExpr (simplify (m :: Matrix Expr))) conv2 :: Rule (Context Expr) -conv2 = makeSimpleRule "Matrix to linear system" $ withCM $ \expr -> do - vs <- readVar vars - m <- fromExpr expr - let linsys = matrixToSystemWith vs (m :: Matrix Expr) - a <- fromContext $ applyD simplifyFirst $ newContext emptyEnv (noNavigator linsys) -- !! - return $ toExpr a - -liftExpr :: IsTerm a => Rule (Context a) -> Rule (Context Expr) -liftExpr r = makeSimpleRuleList (name r) $ \a -> do - b <- castT exprView a - c <- applyAll r b - castT exprView c +conv2 = describe "Convert matrix to linear system" $ + makeSimpleRule "linearalgebra.linsystem.frommatrix" $ withCM $ \expr -> do + vs <- readVar varVars + m <- fromExpr expr + let linsys = matrixToSystemWith vs (m :: Matrix Expr) + return $ simplify $ toExpr linsys diff --git a/src/Domain/LinearAlgebra/Symbols.hs b/src/Domain/LinearAlgebra/Symbols.hs deleted file mode 100644 --- a/src/Domain/LinearAlgebra/Symbols.hs +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.LinearAlgebra.Symbols () where - -import Domain.Math.Expr.Symbolic -import Domain.Math.Simplification -import Domain.LinearAlgebra.Matrix -import Domain.LinearAlgebra.Vector -import Control.Monad -import qualified Text.OpenMath.Dictionary.Linalg2 as Linalg2 -import Common.Rewriting.Term - -vectorSymbol, matrixSymbol, matrixrowSymbol :: Symbol -vectorSymbol = toSymbol Linalg2.vectorSymbol -matrixSymbol = toSymbol Linalg2.matrixSymbol -matrixrowSymbol = toSymbol Linalg2.matrixrowSymbol - -------------------------------------------------------- --- Conversion to the Expr data type - -instance IsTerm a => IsTerm (Matrix a) where - toTerm = - let f = function matrixrowSymbol . map toTerm - in function matrixSymbol . map f . rows - fromTerm a = do - rs <- isSymbol matrixSymbol a - xss <- mapM (isSymbol matrixrowSymbol) rs - yss <- mapM (mapM fromTerm) xss - guard (isRectangular yss) - return (makeMatrix yss) - -instance IsTerm a => IsTerm (Vector a) where - toTerm = function vectorSymbol . map toTerm . toList - fromTerm a = do - xs <- isSymbol vectorSymbol a - ys <- mapM fromTerm xs - return (fromList ys) - -instance IsTerm a => IsTerm (VectorSpace a) where - toTerm = toTerm . vectors - fromTerm a = do - xs <- fromTerm a - guard (sameDimension xs) - return (makeVectorSpace xs) - -------------------------------------------------------- --- Simplification - -instance Simplify a => Simplify (Matrix a) where - simplify = fmap simplify - -instance Simplify a => Simplify (Vector a) where - simplify = fmap simplify - -instance Simplify a => Simplify (VectorSpace a) where - simplify = fmap simplify 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 @@ -18,8 +18,13 @@ ) where import Control.Monad -import Common.Traversable +import Common.Classes +import Common.Rewriting import Data.List +import Domain.Math.Simplification +import Domain.Math.Expr.Symbols (openMathSymbol) +import Test.QuickCheck +import qualified Text.OpenMath.Dictionary.Linalg2 as OM ------------------------------------------------------------------------------- -- Data types @@ -36,9 +41,6 @@ instance Functor Vector where fmap f (V xs) = V (map f xs) -instance Once Vector where - onceM f (V xs) = liftM V (onceM f xs) - instance Switch Vector where switch (V xs) = liftM V (switch xs) @@ -54,12 +56,50 @@ signum = liftV signum fromInteger = fromList . return . fromInteger +instance IsTerm a => IsTerm (Vector a) where + toTerm = function vectorSymbol . map toTerm . toList + fromTerm a = do + xs <- isFunction vectorSymbol a + ys <- mapM fromTerm xs + return (fromList ys) + +instance Arbitrary a => Arbitrary (Vector a) where + arbitrary = liftM fromList $ oneof $ map vector [0..2] + +instance CoArbitrary a => CoArbitrary (Vector a) where + coarbitrary = coarbitrary . toList + +vectorSymbol :: Symbol +vectorSymbol = openMathSymbol OM.vectorSymbol + +instance Simplify a => Simplify (Vector a) where + simplifyWith opt = fmap (simplifyWith opt) + instance Functor VectorSpace where fmap f (VS xs) = VS (map (fmap f) xs) instance Show a => Show (VectorSpace a) where show = show . vectors +instance IsTerm a => IsTerm (VectorSpace a) where + toTerm = toTerm . vectors + fromTerm a = do + xs <- fromTerm a + guard (sameDimension xs) + return (makeVectorSpace xs) + +instance Simplify a => Simplify (VectorSpace a) where + simplifyWith opt = fmap (simplifyWith opt) + +instance Arbitrary a => Arbitrary (VectorSpace a) where + arbitrary = do + i <- choose (0, 3) -- too many vectors "disables" prime factorization + j <- choose (0, 10 `div` i) + xs <- replicateM i (liftM fromList $ replicateM j arbitrary) + return $ makeVectorSpace xs +instance CoArbitrary a => CoArbitrary (VectorSpace a) where + coarbitrary = coarbitrary . vectors + ------------------------------------------------------------------------------- -- Vector Space operations @@ -125,7 +165,7 @@ orthonormalList :: Floating a => [Vector a] -> Bool orthonormalList xs = all isUnit xs && all (uncurry orthogonal) pairs where - pairs = [ (a, b) | (i, a) <- zip [0..] xs, (j, b) <- zip [0..] xs, i < j ] + pairs = [ (a, b) | (i, a) <- zip [0::Int ..] xs, (j, b) <- zip [0..] xs, i < j ] -- length of the vector (also called norm) norm :: Floating a => Vector a -> a diff --git a/src/Domain/Logic.hs b/src/Domain/Logic.hs --- a/src/Domain/Logic.hs +++ b/src/Domain/Logic.hs @@ -10,22 +10,21 @@ -- ----------------------------------------------------------------------------- module Domain.Logic - ( module Domain.Logic.Formula + ( module Domain.Logic.BuggyRules + , module Domain.Logic.Exercises + , module Domain.Logic.Formula + , module Domain.Logic.GeneralizedRules , module Domain.Logic.Generator , module Domain.Logic.Parser - , module Domain.Logic.Strategies , module Domain.Logic.Rules - , module Domain.Logic.BuggyRules - , module Domain.Logic.GeneralizedRules - , module Domain.Logic.Exercises + , module Domain.Logic.Strategies ) where - + +import Domain.Logic.BuggyRules hiding (rule, ruleList) +import Domain.Logic.Exercises import Domain.Logic.Formula +import Domain.Logic.GeneralizedRules import Domain.Logic.Generator import Domain.Logic.Parser -import Domain.Logic.Strategies -import Domain.Logic.Rules -import Domain.Logic.BuggyRules -import Domain.Logic.GeneralizedRules -import Domain.Logic.Exercises - +import Domain.Logic.Rules hiding (rule, ruleList) +import Domain.Logic.Strategies 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 @@ -15,13 +15,15 @@ import Domain.Logic.Formula import Domain.Logic.Generator() -import Domain.Logic.Rules (makeGroup) +import Domain.Logic.Rules (makeGroup, logic) +import Common.Id import Common.Rewriting -import Common.Transformation +import Common.Transformation (Rule, buggyRule) +import qualified Common.Transformation as Rule -- Collection of all known buggy rules buggyRules :: [Rule SLogic] -buggyRules = makeGroup "Common misconceptions" +buggyRules = snd $ makeGroup "Common misconceptions" [ buggyRuleCommImp, buggyRuleAssImp, buggyRuleIdemImp, buggyRuleIdemEqui , buggyRuleEquivElim1, buggyRuleImplElim2, buggyRuleEquivElim2, buggyRuleEquivElim3 , buggyRuleImplElim, buggyRuleImplElim1, buggyRuleDeMorgan1, buggyRuleDeMorgan2, buggyRuleDeMorgan3 @@ -31,6 +33,12 @@ , buggyRuleTrueProp, buggyRuleFalseProp, buggyRuleDistr, buggyRuleDistrNot ] +rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +rule = Rule.rule . logic . ( "buggy" # ) + +ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +ruleList = Rule.ruleList . logic . ( "buggy" # ) + ----------------------------------------------------------------------------- -- Buggy rules @@ -39,7 +47,7 @@ \x -> x :&&: x :~> T buggyRuleAndCompl :: Rule SLogic -buggyRuleAndCompl = buggyRule $ ruleList "AndComplBuggy" +buggyRuleAndCompl = buggyRule $ ruleList "AndCompl" [ \x -> x :&&: Not x :~> T , \x -> Not x :&&: x :~> T , \x -> x :&&: Not x :~> x @@ -51,7 +59,7 @@ \x -> x :||: x :~> T buggyRuleOrCompl :: Rule SLogic -buggyRuleOrCompl = buggyRule $ ruleList "OrComplBuggy" +buggyRuleOrCompl = buggyRule $ ruleList "OrCompl" [ \x -> x :||: Not x :~> F , \x -> Not x :||: x :~> F , \x -> x :||: Not x :~> x @@ -93,7 +101,7 @@ \x -> x :<->: x :~> x buggyRuleEquivElim1 :: Rule SLogic -buggyRuleEquivElim1 = buggyRule $ ruleList "BuggyEquivElim1" +buggyRuleEquivElim1 = buggyRule $ ruleList "EquivElim1" [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y) , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&: y) , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y) @@ -102,7 +110,7 @@ ] buggyRuleEquivElim2 :: Rule SLogic -buggyRuleEquivElim2 = buggyRule $ ruleList "BuggyEquivElim2" +buggyRuleEquivElim2 = buggyRule $ ruleList "EquivElim2" [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y) , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y) , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y) @@ -113,22 +121,22 @@ \x y -> x :<->: y :~> Not x :||: y buggyRuleImplElim :: Rule SLogic -buggyRuleImplElim = buggyRule $ ruleList "BuggyImplElim" +buggyRuleImplElim = buggyRule $ ruleList "ImplElim" [\x y -> x :->: y :~> Not (x :||: y) ,\x y -> x :->: y :~> (x :||: y) ,\x y -> x :->: y :~> Not (x :&&: y) ] buggyRuleImplElim1 :: Rule SLogic -buggyRuleImplElim1 = buggyRule $ rule "BuggyImplElim1" $ +buggyRuleImplElim1 = buggyRule $ rule "ImplElim1" $ \x y -> x :->: y :~> Not x :&&: y buggyRuleImplElim2 :: Rule SLogic -buggyRuleImplElim2 = buggyRule $ rule "BuggyImplElim2" $ +buggyRuleImplElim2 = buggyRule $ rule "ImplElim2" $ \x y -> x :->: y :~> (x :&&: y) :||: (Not x :&&: Not y) buggyRuleDeMorgan1 :: Rule SLogic -buggyRuleDeMorgan1 = buggyRule $ ruleList "BuggyDeMorgan1" +buggyRuleDeMorgan1 = buggyRule $ ruleList "DeMorgan1" [ \x y -> Not (x :&&: y) :~> Not x :||: y , \x y -> Not (x :&&: y) :~> x :||: Not y , \x y -> Not (x :&&: y) :~> x :||: y @@ -138,20 +146,20 @@ ] buggyRuleDeMorgan2 :: Rule SLogic -buggyRuleDeMorgan2 = buggyRule $ ruleList "BuggyDeMorgan2" +buggyRuleDeMorgan2 = buggyRule $ ruleList "DeMorgan2" [ \x y -> Not (x :&&: y) :~> Not (Not x :||: Not y) , \x y -> Not (x :||: y) :~> Not (Not x :&&: Not y) --note the firstNot in both formulas! ] buggyRuleDeMorgan3 :: Rule SLogic -buggyRuleDeMorgan3 = buggyRule $ rule "BuggyDeMorgan3" $ +buggyRuleDeMorgan3 = buggyRule $ rule "DeMorgan3" $ \x y -> Not (x :&&: y) :~> Not x :&&: Not y buggyRuleDeMorgan4 :: Rule SLogic -buggyRuleDeMorgan4 = buggyRule $ rule "BuggyDeMorgan4" $ +buggyRuleDeMorgan4 = buggyRule $ rule "DeMorgan4" $ \x y -> Not (x :||: y) :~> Not x :||: Not y buggyRuleDeMorgan5 :: Rule SLogic -buggyRuleDeMorgan5 = buggyRule $ ruleList "BuggyDeMorgan5" +buggyRuleDeMorgan5 = buggyRule $ ruleList "DeMorgan5" [ \x y z -> Not (Not (x :&&: y) :||: z) :~> Not (Not x :||: Not y):||: z , \x y z -> Not (Not (x :&&: y) :&&: z) :~> Not (Not x :||: Not y):&&: z , \x y z -> Not (Not (x :||: y) :||: z) :~> Not (Not x :&&: Not y):||: z @@ -159,21 +167,21 @@ ] buggyRuleNotOverImpl :: Rule SLogic -buggyRuleNotOverImpl = buggyRule $ rule "BuggyNotOverImpl" $ +buggyRuleNotOverImpl = buggyRule $ rule "NotOverImpl" $ \x y -> Not (x :->: y) :~> Not x :->: Not y buggyRuleParenth1 :: Rule SLogic -buggyRuleParenth1 = buggyRule $ ruleList "BuggyParenth1" +buggyRuleParenth1 = buggyRule $ ruleList "Parenth1" [ \x y -> Not (x :&&: y) :~> Not x :&&: y , \x y -> Not (x :||: y) :~> Not x :||: y ] buggyRuleParenth2 :: Rule SLogic -buggyRuleParenth2 = buggyRule $ rule "BuggyParenth2" $ +buggyRuleParenth2 = buggyRule $ rule "Parenth2" $ \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y) buggyRuleParenth3 :: Rule SLogic -buggyRuleParenth3 = buggyRule $ ruleList "BuggyParenth3" +buggyRuleParenth3 = buggyRule $ ruleList "Parenth3" [ \x y -> Not (Not x :&&: y) :~> x :&&: y , \x y -> Not (Not x :||: y) :~> x :||: y , \x y -> Not (Not x :->: y) :~> x :->: y @@ -182,7 +190,7 @@ buggyRuleAssoc :: Rule SLogic -buggyRuleAssoc = buggyRule $ ruleList "BuggyAssoc" +buggyRuleAssoc = buggyRule $ ruleList "Assoc" [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z) , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z) @@ -190,7 +198,7 @@ ] buggyRuleAbsor :: Rule SLogic -buggyRuleAbsor = buggyRule $ ruleList "BuggyAbsor" +buggyRuleAbsor = buggyRule $ ruleList "Absor" [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y) , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y) , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y) @@ -198,7 +206,7 @@ ] buggyRuleDistr :: Rule SLogic -buggyRuleDistr = buggyRule $ ruleList "BuggyDistr" +buggyRuleDistr = buggyRule $ ruleList "Distr" [ \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :&&: (x :&&: z) , \x y z -> (x :||: y) :&&: z :~> (x :&&: z) :&&: (y :&&: z) , \x y z -> x :&&: (y :||: z) :~> (x :||: y) :&&: (x :||: z) @@ -210,7 +218,7 @@ ] buggyRuleDistrNot :: Rule SLogic -buggyRuleDistrNot = buggyRule $ ruleList "BuggyDistrNot" +buggyRuleDistrNot = buggyRule $ ruleList "DistrNot" [ \x y z -> Not x :&&: (y :||: z) :~> (Not x :&&: y) :||: (x :&&: z) , \x y z -> Not x :&&: (y :||: z) :~> (x :&&: y) :||: (Not x :&&: z) , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: Not z) :||: (y :&&: z) diff --git a/src/Domain/Logic/Examples.hs b/src/Domain/Logic/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Examples.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : josje.lodder@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A set of example proofs +-- +----------------------------------------------------------------------------- +module Domain.Logic.Examples + ( exampleProofs + ) where + + +import Domain.Logic.Formula +import Common.Utils (ShowString(..)) + + + + + +exampleProofs :: [(SLogic, SLogic)] +exampleProofs = [(Not(p :||: (Not p :&&: q)), Not(p :||: q)), + ((p :->:q):||: Not p, (p :->: q) :||: q), + ((p :&&: Not q):||:(q :&&: Not p), (p :||:q):&&:Not(p :&&: q)), + (Not(p :||: Not(p :||: Not q)), Not(p :||: q)), + (p :<->: q, (p :->: q) :&&: (q :->: p)), + ((p :&&: q) :->: p, T), + ((p :->: q) :||: (q :->: p), T), + ((q :->: (Not p :->: q)) :->: p, Not p :->: (q :&&: ((p :&&: q) :&&: q))), + ((p :->: Not q):->:q, (s :||:(s :->:(q :||: p))) :&&: q), + (p :->: (q :->: r), (p :->: q) :->: (p :->:r)), + (Not((p :->: q) :->: Not(q :->: p)), p :<->: q), + ((p :->: q):->: (p :->: s), (Not q :->: Not p) :->: (Not s :->: Not p)), + (Not((p :->:q) :->: (p:&&:q)), (p :->: q) :&&: (Not p :||: Not q)), + (Not((p :<->: q) :->: (p :||: (p :<->: q))), F)] + + where + p = Var (ShowString "p") + q = Var (ShowString "q") + s = Var (ShowString "s") + r = Var (ShowString "r") + + + 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 @@ -34,8 +34,8 @@ -- Currently, we use the DWA strategy dnfExercise :: Exercise SLogic dnfExercise = makeExercise - { description = "Proposition to DNF" - , exerciseCode = makeCode "logic" "dnf" + { exerciseId = describe "Proposition to DNF" $ + newId "logic.propositional.dnf" , status = Stable , parser = parseLogicPars , prettyPrinter = ppLogicPars @@ -54,8 +54,8 @@ -- Direct support for unicode characters dnfUnicodeExercise :: Exercise SLogic dnfUnicodeExercise = dnfExercise - { description = description dnfExercise ++ " (unicode support)" - , exerciseCode = makeCode "logic" "dnf-unicode" + { exerciseId = describe "Proposition to DNF (unicode support)" $ + newId "logic.propositional.dnf.unicode" , parser = parseLogicUnicodePars , prettyPrinter = ppLogicUnicodePars } @@ -66,8 +66,8 @@ | n == 1 = generateLevel Easy | n == 3 = generateLevel Difficult | otherwise = generateLevel Normal - ok p = let n = fromMaybe maxBound (stepsRemaining maxStep p) - in countEquivalences p <= 2 && n >= minStep && n <= maxStep + ok p = let i = fromMaybe maxBound (stepsRemaining maxStep p) + in countEquivalences p <= 2 && i >= minStep && i <= maxStep in restrictGenerator ok gen suitable :: SLogic -> Bool 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 @@ -16,13 +16,14 @@ import Data.List import Data.Maybe +import Common.Id import Common.Transformation import Domain.Logic.Rules import Domain.Logic.BuggyRules feedbackSyntaxError :: String -> String feedbackSyntaxError msg - | take 1 msg == "(" = "Syntax error at " ++ msg + | "(" `isPrefixOf` msg = "Syntax error at " ++ msg | "Syntax error" `isPrefixOf` msg = msg | otherwise = "Syntax error: " ++ msg @@ -104,7 +105,7 @@ feedbackDetour :: Bool -> Maybe (Rule a) -> [Rule a] -> (String, Bool) feedbackDetour True _ [one] = (appliedRule one ++ " " ++ feedbackFinished, True) feedbackDetour True _ _ = (feedbackMultipleSteps ++ " " ++ feedbackFinished, True) -feedbackDetour _ _ [one] | one `inGroup`"Commutativity" = +feedbackDetour _ _ [one] | one `inGroup` groupCommutativity = ("You have applied one of the commutativity rules correctly. This step is not mandatory, but sometimes helps to simplify the formula.", True) feedbackDetour _ mexp [one] = let however = case mexp >>= ruleText of @@ -134,15 +135,15 @@ | r ~= ruleNotNot = return "double negation" | r ~= ruleDefImpl = return "implication elimination" | r ~= ruleDefEquiv = return "equivalence elimination" - | r `inGroup`"Commutativity" = return "commutativity" - | r `inGroup`"Aasociativity" = return "associativity" - | r `inGroup`"DistributionOrOverAnd" = return "distribution of or over and" - | r `inGroup`"DistributionAndOverOr" = return "distribution of and over or" - | r `inGroup`"Idempotency" = return "idempotency" - | r `inGroup`"Absorption" = return "absorption" - | r `inGroup`"De Morgan" = return "De Morgan" - | r `inGroup`"InverseDeMorgan" = return "De Morgan" - | r `inGroup`"InverseDistr" = return "distributivity" + | r `inGroup` groupCommutativity = return "commutativity" + | r `inGroup` groupAssociativity = return "associativity" + | r `inGroup` groupDistributionOrOverAnd = return "distribution of or over and" + | r `inGroup` groupDistributionAndOverOr = return "distribution of and over or" + | r `inGroup` groupIdempotency = return "idempotency" + | r `inGroup` groupAbsorption = return "absorption" + | r `inGroup` groupDeMorgan = return "De Morgan" + | r `inGroup` groupInverseDeMorgan = return "De Morgan" + | r `inGroup` groupInverseDistr = return "distributivity" -- TODO Josje: aanvullen met alle regels (ook die ook in de DWA strategie voorkomen) | otherwise = Nothing ------------------------------------------------------------------------- @@ -162,10 +163,10 @@ -- Helper functions (~=) :: Rule a -> Rule b -> Bool -r1 ~= r2 = name r1 == name r2 +r1 ~= r2 = getId r1 == getId r2 -- Quick and dirty fix! -inGroup :: Rule a -> String -> Bool +inGroup :: Rule a -> (Id, b) -> Bool inGroup r n = let rs = filter (~= r) (logicRules ++ buggyRules) - in n `elem` concatMap ruleGroups rs + in fst n `elem` concatMap ruleGroups rs 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 @@ -11,14 +11,17 @@ ----------------------------------------------------------------------------- module Domain.Logic.Formula where -import Domain.Math.Expr.Symbolic -import Text.OpenMath.Dictionary.Logic1 -import Common.Uniplate (Uniplate(..), universe) +import Common.Classes +import Common.Id import Common.Rewriting -import Common.Traversable +import Common.Uniplate (Uniplate(..), universe) import Common.Utils (ShowString, subsets) -import Data.List +import Common.View import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.Expr.Symbols (openMathSymbol) +import qualified Text.OpenMath.Dictionary.Logic1 as OM infixr 2 :<->: infixr 3 :->: @@ -61,16 +64,16 @@ -- | foldLogic is the standard fold for Logic. foldLogic :: LogicAlg b a -> Logic b -> a -foldLogic (var, impl, equiv, and, or, not, true, false) = rec +foldLogic (var, impl, equiv, conj, disj, neg, true, false) = rec where rec logic = case logic of Var x -> var x p :->: q -> rec p `impl` rec q p :<->: q -> rec p `equiv` rec q - p :&&: q -> rec p `and` rec q - p :||: q -> rec p `or` rec q - Not p -> not (rec p) + p :&&: q -> rec p `conj` rec q + p :||: q -> rec p `disj` rec q + Not p -> neg (rec p) T -> true F -> false @@ -79,8 +82,10 @@ ppLogic = ppLogicPrio 0 ppLogicPrio :: Show a => Int -> Logic a -> String -ppLogicPrio n p = foldLogic (pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\", binop 1 "||", nott, pp "T", pp "F") p n "" +ppLogicPrio = (\f s -> f s "") . flip (foldLogic alg) where + alg = ( pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\" + , binop 1 "||", nott, pp "T", pp "F") binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio) pp s = const (s++) nott p _ = ("~"++) . p 4 @@ -105,13 +110,6 @@ xs = varsLogic p `union` varsLogic q fs = map (flip elem) (subsets xs) --- | Functions noNot, noOr, and noAnd determine whether or not a Logic --- | expression contains a not, or, and and constructor, respectively. -noNot, noOr, noAnd :: Logic a -> Bool -noNot = foldLogic (const True, (&&), (&&), (&&), (&&), const False, True, True) -noOr = foldLogic (const True, (&&), (&&), (&&), \_ _ -> False, id, True, True) -noAnd = foldLogic (const True, (&&), (&&), \_ _ -> False, (&&), id, True, True) - -- | A Logic expression is atomic if it is a variable or a constant True or False. isAtomic :: Logic a -> Bool isAtomic logic = @@ -131,56 +129,30 @@ -- | Function disjunctions returns all Logic expressions separated by an or -- | operator at the top level. disjunctions :: Logic a -> [Logic a] -disjunctions = collectWithOperator orOperator +disjunctions p = fromMaybe [p] $ match (magmaListView orMonoid) p -- | Function conjunctions returns all Logic expressions separated by an and -- | operator at the top level. conjunctions :: Logic a -> [Logic a] -conjunctions = collectWithOperator andOperator - --- | Count the number of implicationsations :: Logic -> Int -countImplications :: Logic a -> Int -countImplications p = length [ () | _ :->: _ <- universe p ] +conjunctions p = fromMaybe [p] $ match (magmaListView andMonoid) p -- | Count the number of equivalences countEquivalences :: Logic a -> Int countEquivalences p = length [ () | _ :<->: _ <- universe p ] --- | Count the number of binary operators -countBinaryOperators :: Logic a -> Int -countBinaryOperators = foldLogic (const 0, binop, binop, binop, binop, id, 0, 0) - where binop x y = x + y + 1 - --- | Count the number of double negations -countDoubleNegations :: Logic a -> Int -countDoubleNegations p = length [ () | Not (Not _) <- universe p ] - -- | Function varsLogic returns the variables that appear in a Logic expression. varsLogic :: Eq a => Logic a -> [a] varsLogic p = nub [ s | Var s <- universe p ] instance Uniplate (Logic a) where - uniplate p = - case p of + uniplate this = + case this of p :->: q -> ([p, q], \[a, b] -> a :->: b) p :<->: q -> ([p, q], \[a, b] -> a :<->: b) p :&&: q -> ([p, q], \[a, b] -> a :&&: b) p :||: q -> ([p, q], \[a, b] -> a :||: b) Not p -> ([p], \[a] -> Not a) - _ -> ([], \[] -> p) - -instance Eq a => ShallowEq (Logic a) where - shallowEq expr1 expr2 = - case (expr1, expr2) of - (Var a, Var b) -> a==b - (_ :->: _ , _ :->: _ ) -> True - (_ :<->: _, _ :<->: _) -> True - (_ :&&: _ , _ :&&: _ ) -> True - (_ :||: _ , _ :||: _ ) -> True - (Not _ , Not _ ) -> True - (T , T ) -> True - (F , F ) -> True - _ -> False + _ -> ([], \[] -> this) instance Different (Logic a) where different = (T, F) @@ -189,7 +161,7 @@ toTerm = foldLogic ( toTerm, binary impliesSymbol, binary equivalentSymbol , binary andSymbol, binary orSymbol, unary notSymbol - , nullary trueSymbol, nullary falseSymbol + , symbol trueSymbol, symbol falseSymbol ) fromTerm a = @@ -203,23 +175,57 @@ f s [x, y] | s == impliesSymbol = return (x :->: y) | s == equivalentSymbol = return (x :<->: y) - | s == andSymbol = return (x :&&: y) - | s == orSymbol = return (x :||: y) + f s xs@(_:_) + | s == andSymbol = return (foldr1 (:&&:) xs) + | s == orSymbol = return (foldr1 (:||:) xs) f _ _ = fail "fromTerm" -logicOperators :: Operators (Logic a) -logicOperators = [andOperator, orOperator] +trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol, + andSymbol, orSymbol :: Symbol + +trueSymbol = openMathSymbol OM.trueSymbol +falseSymbol = openMathSymbol OM.falseSymbol +notSymbol = openMathSymbol OM.notSymbol +impliesSymbol = openMathSymbol OM.impliesSymbol +equivalentSymbol = openMathSymbol OM.equivalentSymbol +andSymbol = openMathSymbol OM.andSymbol +orSymbol = openMathSymbol OM.orSymbol + +logicOperators :: [Magma (Logic a)] +logicOperators = map toMagma [andMonoid, orMonoid] + +andMonoid :: Monoid (Logic a) +andMonoid = monoid andOperator (makeConstant (getId trueSymbol) T isT) + where + isT T = True + isT _ = False --- The "and" operator is also commutative, but not (yet) in the equational theory -andOperator :: Operator (Logic a) -andOperator = associativeOperator (:&&:) isAnd +orMonoid :: Monoid (Logic a) +orMonoid = monoid orOperator (makeConstant (getId falseSymbol) F isF) where + isF F = True + isF _ = False + +andOperator:: BinaryOp (Logic a) +andOperator = makeBinary (getId andSymbol) (:&&:) isAnd + where isAnd (p :&&: q) = Just (p, q) isAnd _ = Nothing --- The "or" operator is also commutative, but not (yet) in the equational theory -orOperator :: Operator (Logic a) -orOperator = associativeOperator (:||:) isOr +orOperator :: BinaryOp (Logic a) +orOperator = makeBinary (getId orSymbol) (:||:) isOr where isOr (p :||: q) = Just (p, q) isOr _ = Nothing + +implOperator :: BinaryOp (Logic a) +implOperator = makeBinary (getId impliesSymbol) (:->:) isImpl + where + isImpl (p :->: q) = Just (p, q) + isImpl _ = Nothing + +equivOperator :: BinaryOp (Logic a) +equivOperator = makeBinary (getId equivalentSymbol) (:<->:) isEquiv + where + isEquiv (p :<->: q) = Just (p, q) + isEquiv _ = Nothing 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 @@ -22,7 +22,8 @@ -- Note: the generalized rules do not take AC-unification into account, -- and perhaps they should. import Domain.Logic.Formula -import Common.Transformation +import Common.Transformation (Rule) +import qualified Common.Transformation as Rule import Control.Monad generalRules :: [Rule SLogic] @@ -36,6 +37,9 @@ [ inverseDeMorganOr, inverseDeMorganAnd , inverseAndOverOr, inverseOrOverAnd ] + +makeSimpleRule :: String -> (a -> Maybe a) -> Rule a +makeSimpleRule s = Rule.makeSimpleRule ("logic.propositional." ++ s) ----------------------------------------------------------------------------- -- Inverse rules 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 @@ -21,20 +21,24 @@ import Test.QuickCheck import Common.Rewriting import Common.Uniplate -import Domain.Math.Expr.Symbolic -import Text.OpenMath.Dictionary.Logic1 +import Common.View ------------------------------------------------------------- -- Code that doesn't belong here, but the arbitrary instance -- is needed for the Rewrite instance. instance Rewrite SLogic where - operators = logicOperators - associativeOps = const $ map toSymbol [andSymbol, orSymbol] + operators = logicOperators -- | Equality modulo associativity of operators equalLogicA:: SLogic -> SLogic -> Bool -equalLogicA = equalWith operators +equalLogicA p q = rec p == rec q + where + make = simplifyWith (map rec) . magmaListView + rec a = case a of + _ :&&: _ -> make andMonoid a + _ :||: _ -> make orMonoid a + _ -> descend rec a ----------------------------------------------------------- -- Logic generator @@ -61,18 +65,16 @@ -- Use the propositions with 4-12 steps normalGenerator :: Gen SLogic normalGenerator = do - n <- return 4 -- oneof [return 4, return 8] - p0 <- sizedGen False varGen n + p0 <- sizedGen False varGen 4 p1 <- preventSameVar varList p0 return (removePartsInDNF p1) -- Use the propositions with 7-18 steps difficultGenerator :: Gen SLogic difficultGenerator = do - let vars = ShowString "s" : varList - n <- return 4 -- oneof [return 4, return 8] - p0 <- sizedGen False (oneof $ map return vars) n - p1 <- preventSameVar vars p0 + let vs = ShowString "s" : varList + p0 <- sizedGen False (oneof $ map return vs) 4 + p1 <- preventSameVar vs p0 return (removePartsInDNF p1) varList :: [ShowString] @@ -104,12 +106,13 @@ -- Simple tricks for creating for "nice" logic propositions preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a) -preventSameVar xs = transformM $ \p -> - case uniplate p of - ([Var a, Var b], f) | a==b -> do - c <- oneof $ map return $ filter (/=a) xs - return $ f [Var a, Var c] - _ -> return p +preventSameVar xs = rec + where + rec p = case holes p of + [(Var a, _), (Var b, update)] | a==b -> do + c <- oneof $ map return $ filter (/=a) xs + return $ update (Var c) + _ -> descendM rec p removePartsInDNF :: SLogic -> SLogic removePartsInDNF = buildOr . filter (not . simple) . disjunctions @@ -127,14 +130,15 @@ instance Arbitrary SLogic where arbitrary = sized (\i -> sizedGen True varGen (i `min` 4)) + instance CoArbitrary SLogic where coarbitrary logic = case logic of - Var x -> variant 0 . coarbitrary (map ord (fromShowString x)) - p :->: q -> variant 1 . coarbitrary p . coarbitrary q - p :<->: q -> variant 2 . coarbitrary p . coarbitrary q - p :&&: q -> variant 3 . coarbitrary p . coarbitrary q - p :||: q -> variant 4 . coarbitrary p . coarbitrary q - Not p -> variant 5 . coarbitrary p - T -> variant 6 - F -> variant 7 + Var x -> variant (0 :: Int) . coarbitrary (map ord (fromShowString x)) + p :->: q -> variant (1 :: Int) . coarbitrary p . coarbitrary q + p :<->: q -> variant (2 :: Int) . coarbitrary p . coarbitrary q + p :&&: q -> variant (3 :: Int) . coarbitrary p . coarbitrary q + p :||: q -> variant (4 :: Int) . coarbitrary p . coarbitrary q + Not p -> variant (5 :: Int) . coarbitrary p + T -> variant (6 :: Int) + F -> variant (7 :: Int) 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 @@ -10,11 +10,12 @@ -- ----------------------------------------------------------------------------- module Domain.Logic.Parser - ( parseLogic, parseLogicPars, parseLogicUnicodePars + ( parseLogic, parseLogicPars, parseLogicUnicodePars, parseLogicProof , ppLogicPars, ppLogicUnicodePars ) where import Common.Utils (ShowString(..)) +import Control.Monad.Error (liftM2) import Text.Parsing import Control.Arrow import Domain.Logic.Formula @@ -75,18 +76,20 @@ | [c] == equivUSym = equivASym | otherwise = [c] -pLogicGen (impl, equiv, and, or, nt, tr, fl) = pLogic +pLogicGen :: SymbolTuple -> TokenParser SLogic +pLogicGen (impl, equiv, conj, disj, neg, tr, fl) = pLogic where pLogic = flip ($) <$> basic <*> optional composed id - basic = basicWithPosGen (nt, tr, fl) pLogic + basic = basicWithPosGen (neg, tr, fl) pLogic composed = flip (:<->:) <$ pKey equiv <*> basic <|> flip (:->:) <$ pKey impl <*> basic - <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey and *> basic) - <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey or *> basic) + <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey conj *> basic) + <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey disj *> basic) -basicWithPos :: Parser Token SLogic -> Parser Token SLogic +basicWithPos :: TokenParser SLogic -> TokenParser SLogic basicWithPos = basicWithPosGen ("~", "T", "F") +basicWithPosGen :: (String, String, String) -> TokenParser SLogic -> TokenParser SLogic basicWithPosGen t@(nt, tr, fl) p = (Var . ShowString) <$> pVarid <|> pParens p @@ -94,11 +97,23 @@ <|> F <$ pKey fl <|> Not <$ pKey nt <*> basicWithPosGen t p +parseLogicProof :: String -> Either String (SLogic, SLogic) +parseLogicProof s + = either Left susp + $ left (ambiguousOperators parseLogic s) + $ analyseAndParse pProof + $ scanWith extScanner s + where + pProof = (,) <$> pLogicGen asciiTuple <* pKey "==" <*> pLogicGen asciiTuple + susp (p, q) = liftM2 (,) (suspiciousVariable p) (suspiciousVariable q) + extScanner = logicScanner + {keywordOperators = "==" : keywordOperators logicScanner} + ----------------------------------------------------------- --- Helper-functions for syntax warnings -- analyze parentheses -analyseAndParse :: Parser Token a -> [Token] -> Either String a +analyseAndParse :: TokenParser a -> [Token] -> Either String a analyseAndParse p ts = case checkParentheses ts of Just err -> Left (show err) @@ -133,21 +148,27 @@ ppLogicUnicodePars :: SLogic -> String ppLogicUnicodePars = ppLogicParsGen unicodeTuple -ppLogicParsGen (impl, equiv, and, or, nt, tr, fl) p = foldLogic alg p 0 "" +ppLogicParsGen :: SymbolTuple -> SLogic -> String +ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) = + (\f -> f 0 "") . foldLogic alg where - alg = (pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 and, binop 2 or, nott, pp tr, pp fl) - binop prio op p q n = parIf (n/=0 && (n==3 || prio/=n)) - (p prio . ((" "++op++" ")++) . q prio) + alg = ( pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 conj + , binop 2 disj, nott, pp tr, pp fl + ) + binop :: Int -> String -> (Int -> String -> String) -> (Int -> String -> String) -> Int -> String -> String + binop prio op p q n = + parIf (n/=0 && (n==3 || prio/=n)) + (p prio . ((" "++op++" ")++) . q prio) pp s = const (s++) - nott p _ = (nt++) . p 3 + nott p _ = (neg++) . p 3 parIf b f = if b then ("("++) . f . (")"++) else f ----------------------------------------------------------- --- Ascii symbols ---asciiSyms :: [String] ---asciiSyms = [implASym, equivASym, andASym, orASym, notASym] +type SymbolTuple = (String, String, String, String, String, String, String) +asciiTuple :: SymbolTuple asciiTuple = (implASym, equivASym, andASym, orASym, notASym, "T", "F") implASym, equivASym, andASym, orASym, notASym :: String @@ -163,6 +184,7 @@ unicodeSyms :: [String] unicodeSyms = [implUSym, equivUSym, andUSym, orUSym, notUSym] +unicodeTuple :: SymbolTuple unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F") implUSym, equivUSym, andUSym, orUSym, notUSym :: String diff --git a/src/Domain/Logic/Proofs.hs b/src/Domain/Logic/Proofs.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Proofs.hs @@ -0,0 +1,319 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exercise for the logic domain: to prove two propositions equivalent +-- +----------------------------------------------------------------------------- +module Domain.Logic.Proofs (proofExercise) where + +import Prelude hiding (repeat) +import Common.Context +import Common.Rewriting +import Common.Rewriting.AC +import Common.Strategy hiding (fail, not) +import Common.Exercise +import Common.Utils +import Common.View +import Common.Transformation +import Common.Navigator +import Data.List hiding (repeat) +import Control.Monad +import Data.Maybe +import Domain.Logic.Formula +import Domain.Logic.Generator (equalLogicA) +import Domain.Logic.Parser +import Domain.Logic.Rules +import Domain.Logic.GeneralizedRules +import Domain.Logic.Strategies (somewhereOr) +import Domain.Logic.Examples +import Domain.Math.Expr () +import Common.Uniplate + +see :: Int -> IO () +see n = printDerivation proofExercise (examples proofExercise !! n) + +-- Currently, we use the DWA strategy +proofExercise :: Exercise [(SLogic, SLogic)] +proofExercise = makeExercise + { exerciseId = describe "Prove two propositions equivalent" $ + newId "logic.proof" + , status = Experimental +-- , parser = parseLogicProof + , prettyPrinter = let f (p, q) = ppLogicPars p ++ " == " ++ ppLogicPars q + in commaList . map f +-- , equivalence = \(p, _) (r, s) -> eqLogic p r && eqLogic r s +-- , similarity = \(p, q) (r, s) -> equalLogicA p r && equalLogicA q s + , isSuitable = all (uncurry eqLogic) + , isReady = all (uncurry equalLogicA) + , strategy = proofStrategy + , navigation = termNavigator + , examples = map return $ exampleProofs ++ + let p = Var (ShowString "p") + q = Var (ShowString "q") + in [(q :&&: p, p :&&: (q :||: q))] + } + +instance (IsTerm a, IsTerm b) => IsTerm (a, b) where + toTerm (a, b) = binary tupleSymbol (toTerm a) (toTerm b) + fromTerm term = do + (a, b) <- isBinary tupleSymbol term + liftM2 (,) (fromTerm a) (fromTerm b) + +tupleSymbol :: Symbol +tupleSymbol = newSymbol "basic.tuple" + +proofStrategy :: LabeledStrategy (Context [(SLogic, SLogic)]) +proofStrategy = label "proof equivalent" $ + repeat ( + somewhere (useC commonExprAtom) + |> somewhere splitTop + |> somewhere rest + ) <*> + repeat (somewhere (use normLogicRule)) + where + splitTop = use topIsNot <|> use topIsAnd <|> use topIsOr + <|> use topIsImpl <|> use topIsEquiv + rest = use notDNF <*> mapRulesS useC (repeat dnfStrategyDWA) + <|> simpler + + simpler :: Strategy (Context [(SLogic, SLogic)]) + simpler = + use tautologyOr <|> use idempotencyAnd <|> use contradictionAnd + <|> use absorptionSubset <|> use fakeAbsorption <|> use fakeAbsorptionNot + <|> alternatives (map use list) + + list = [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr + , ruleAbsorpOr, ruleComplOr + ] + + notDNF :: Rule SLogic + notDNF = minorRule $ makeSimpleRule "not-dnf" $ \p -> + if isDNF p then Nothing else Just p + +----------------------------------------------------------------------------- +-- To DNF, with priorities (the "DWA" approach) + +dnfStrategyDWA :: Strategy (Context SLogic) +dnfStrategyDWA = + toplevel <|> somewhereOr + ( label "Simplify" simplify + |> label "Eliminate implications/equivalences" eliminateImplEquiv + |> label "Eliminate nots" eliminateNots + |> label "Move ors to top" orToTop + ) + where + toplevel = useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr + , ruleAbsorpOr, ruleComplOr + ] + simplify = somewhere $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse + , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd + , ruleComplOr, ruleComplAnd + ] + eliminateImplEquiv = somewhere $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = somewhere $ useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr + , ruleDeMorganAnd, ruleDeMorganOr + ] + orToTop = somewhere $ useRules + [ generalRuleAndOverOr, ruleAndOverOr ] + +useRules :: [Rule SLogic] -> Strategy (Context SLogic) +useRules = alternatives . map liftToContext + +onceLeft :: IsStrategy f => f (Context a) -> Strategy (Context a) +onceLeft s = ruleMoveDown <*> s <*> ruleMoveUp + where + ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 1) + ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" safeUp + + safeUp a = Just (fromMaybe a (up a)) + +onceRight :: IsStrategy f => f (Context a) -> Strategy (Context a) +onceRight s = ruleMoveDown <*> s <*> ruleMoveUp + where + ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 2) + ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" safeUp + + safeUp a = Just (fromMaybe a (up a)) + +testje :: Rule (Context SLogic) +testje = makeSimpleRule "testje" $ \a -> error $ show a + +go n = printDerivation proofExercise [exampleProofs !! n] --(p :||: Not p, Not F) + --where p = Var (ShowString "p") + +normLogicRule :: Rule (SLogic, SLogic) +normLogicRule = makeSimpleRule "Normalize" $ \tuple@(p, q) -> do + guard (p /= q) + let xs = sort (varsLogic p `union` varsLogic q) + new = (normLogicWith xs p, normLogicWith xs q) + guard (tuple /= new) + return new + +-- Find a common subexpression that can be treated as a box +commonExprAtom :: Rule (Context (SLogic, SLogic)) +commonExprAtom = makeSimpleRule "commonExprAtom" $ withCM $ \(p, q) -> do + let f = filter same . filter ok . nub . sort . universe + xs = f p `intersect` f q -- todo: only largest common sub expr + ok (Var _) = False + ok T = False + ok F = False + ok (Not a) = ok a + ok _ = True + same cse = eqLogic (sub cse p) (sub cse q) + new = head (logicVars \\ (varsLogic p `union` varsLogic q)) + sub a this + | a == this = Var new + | otherwise = descend (sub a) this + case xs of + hd:_ -> do modifyVar substVar ((show new, show hd):) + return (sub hd p, sub hd q) + _ -> fail "not applicable" + +substVar :: Var [(String, String)] +substVar = newVar "subst" [] + +logicVars :: [ShowString] +logicVars = [ ShowString [c] | c <- ['a'..] ] + +normLogic :: Ord a => Logic a -> Logic a +normLogic p = normLogicWith (sort (varsLogic p)) p + +normLogicWith :: Eq a => [a] -> Logic a -> Logic a +normLogicWith xs p = make (filter keep (subsets xs)) + where + keep ys = evalLogic (`elem` ys) p + make = makeOrs . map atoms + atoms ys = makeAnds [ f (x `elem` ys) (Var x) | x <- xs ] + f b = if b then id else Not + +makeOrs xs = if null xs then F else foldr1 (:||:) xs +makeAnds xs = if null xs then T else foldr1 (:&&:) xs + + +-- p \/ q \/ ~p ~> T (propageren) +tautologyOr :: Rule SLogic +tautologyOr = makeSimpleRule "tautologyOr" $ \p -> do + let xs = disjunctions p + guard (any (\x -> Not x `elem` xs) xs) + return T + +-- p /\ q /\ p ~> p /\ q +idempotencyAnd :: Rule SLogic +idempotencyAnd = makeSimpleRule "idempotencyAnd" $ \p -> do + let xs = conjunctions p + ys = nub xs + guard (length ys < length xs) + return (makeAnds ys) + +-- p /\ q /\ ~p ~> F (propageren) +contradictionAnd :: Rule SLogic +contradictionAnd = makeSimpleRule "contradictionAnd" $ \p -> do + let xs = conjunctions p + guard (any (\x -> Not x `elem` xs) xs) + return F + +-- (p /\ q) \/ ... \/ (p /\ q /\ r) ~> (p /\ q) \/ ... +-- (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes) +absorptionSubset :: Rule SLogic +absorptionSubset = makeSimpleRule "absorptionSubset" $ \p -> do + let xss = map conjunctions (disjunctions p) + yss = nub $ filter (\xs -> all (ok xs) xss) xss + ok xs ys = not (ys `isSubsetOf` xs) || xs == ys + guard (length yss < length xss) + return $ makeOrs (map makeAnds yss) + +-- p \/ ... \/ (~p /\ q /\ r) ~> p \/ ... \/ (q /\ r) +-- (p is hier een losse variabele) +fakeAbsorption :: Rule SLogic +fakeAbsorption = makeSimpleRuleList "fakeAbsorption" $ \p -> do + let xs = disjunctions p + v <- [ a | a@(Var _) <- xs ] + let ys = map (makeAnds . filter (/= Not v) . conjunctions) xs + new = makeOrs ys + guard (p /= new) + return new + +-- ~p \/ ... \/ (p /\ q /\ r) ~> ~p \/ ... \/ (q /\ r) +-- (p is hier een losse variabele) +fakeAbsorptionNot :: Rule SLogic +fakeAbsorptionNot = makeSimpleRuleList "fakeAbsorptionNot" $ \p -> do + let xs = disjunctions p + v <- [ a | Not a@(Var _) <- xs ] + let ys = map (makeAnds . filter (/= v) . conjunctions) xs + new = makeOrs ys + guard (p /= new) + return new + +topIsNot :: Rule (SLogic, SLogic) +topIsNot = makeSimpleRule "top-is-not" f + where + f (Not p, Not q) = Just (p, q) + f _ = Nothing + +acTopRuleFor :: IsId a => a -> BinaryOp SLogic -> Rule [(SLogic, SLogic)] +acTopRuleFor s op = makeSimpleRuleList s f + where + f [(lhs, rhs)] = do + let myView = magmaListView (semiGroup op) + make = build myView + xs <- matchM myView lhs + ys <- matchM myView rhs + guard (length xs > 1 && length ys > 1) + list <- liftM (map (make *** make)) (pairingsAC False xs ys) + guard (all (uncurry eqLogic) list) + return list + f _ = [] + +topIsAnd :: Rule [(SLogic, SLogic)] +topIsAnd = acTopRuleFor "top-is-and" andOperator + +topIsOr :: Rule [(SLogic, SLogic)] +topIsOr = acTopRuleFor "top-is-or" orOperator + +topIsEquiv :: Rule [(SLogic, SLogic)] +topIsEquiv = acTopRuleFor "top-is-equiv" equivOperator + +topIsImpl :: Rule [(SLogic, SLogic)] +topIsImpl = makeSimpleRule "top-is-impl" f + where + f [(p :->: q, r :->: s)] = do + guard (eqLogic p r && eqLogic q s) + return [(p, r), (q, s)] + f _ = Nothing + +{- Strategie voor sterke(?) normalisatie + +(prioritering) + +1. p \/ q \/ ~p ~> T (propageren) + p /\ q /\ p ~> p /\ q + p /\ q /\ ~p ~> F (propageren) + +2. (p /\ q) \/ ... \/ (p /\ q /\ r) ~> (p /\ q) \/ ... + (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes) + p \/ ... \/ (~p /\ q /\ r) ~> p \/ ... \/ (q /\ r) + (p is hier een losse variabele) + ~p \/ ... \/ (p /\ q /\ r) ~> ~p \/ ... \/ (q /\ r) + (p is hier een losse variabele) + +3. a) elimineren wat aan een kant helemaal niet voorkomt (zie regel hieronder) + b) rijtjes sorteren + c) rijtjes aanvullen + +Twijfelachtige regel bij stap 3: samennemen in plaats van aanvullen: + (p /\ q /\ r) \/ ... \/ (~p /\ q /\ r) ~> q /\ r + (p is hier een losse variable) +-} 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 @@ -15,13 +15,15 @@ module Domain.Logic.Rules where import Domain.Logic.Formula -import Common.Transformation +import Common.Id +import Common.Transformation (Rule, addRuleToGroup, minorRule) import Common.Rewriting import Domain.Logic.Generator() import Domain.Logic.GeneralizedRules +import qualified Common.Transformation as Rule logicRules :: [Rule SLogic] -logicRules = concat +logicRules = concatMap snd [ groupCommutativity, groupAssociativity, groupIdempotency , groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation , groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, groupAdditional @@ -29,21 +31,33 @@ , groupInverseDeMorgan,groupInverseDistr ] +logic :: IsId a => a -> Id +logic = ( # ) "logic.propositional" + +rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +rule = Rule.rule . logic + +ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +ruleList = Rule.ruleList . logic + ----------------------------------------------------------------------------- -- Grouping DWA rules -makeGroup :: String -> [Rule SLogic] -> [Rule SLogic] -makeGroup = map . addRuleToGroup +makeGroup :: String -> [Rule SLogic] -> (Id, [Rule SLogic]) +makeGroup s rs = + let a = logic s + in (a, map (addRuleToGroup a) rs) -groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, groupDistributionAndOverOr,groupIdempotency, - groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation, - groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination :: [Rule SLogic] +groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, + groupDistributionAndOverOr,groupIdempotency, groupAbsorption, + groupTrueProperties, groupFalseProperties, groupDoubleNegation, + groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, + groupInverseDeMorgan, groupInverseDistr :: (Id, [Rule SLogic]) groupCommutativity = makeGroup "Commutativity" [ruleCommOr, ruleCommAnd] groupAssociativity = makeGroup "Associativity" [ruleAssocOr, ruleAssocAnd] - groupIdempotency = makeGroup "Idempotency" [ruleIdempOr, ruleIdempAnd] groupAbsorption = makeGroup "Absorption" @@ -65,9 +79,9 @@ groupDistributionAndOverOr = makeGroup "DistributionAndOverOr" [generalRuleAndOverOr, ruleAndOverOr ] groupInverseDeMorgan = makeGroup "InverseDeMorgan" - [ inverseDeMorganOr, inverseDeMorganAnd] + [inverseDeMorganOr, inverseDeMorganAnd] groupInverseDistr = makeGroup "InverseDistr" - [ inverseAndOverOr, inverseOrOverAnd] + [inverseAndOverOr, inverseOrOverAnd] ----------------------------------------------------------------------------- -- Commutativity @@ -218,7 +232,7 @@ ----------------------------------------------------------------------------- -- Additional rules, not in the DWA course -groupAdditional :: [Rule SLogic] +groupAdditional :: (Id, [Rule SLogic]) groupAdditional = makeGroup "Additional rules" [ ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame 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,101 +1,103 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Logic.Strategies - ( dnfStrategy, dnfStrategyDWA) where - -import Prelude hiding (repeat) -import Domain.Logic.Rules -import Domain.Logic.GeneralizedRules -import Domain.Logic.Formula -import Common.Context (Context, liftToContext) -import Common.Rewriting (isOperator) -import Common.Transformation -import Common.Strategy -import Common.Navigator - ------------------------------------------------------------------------------ --- To DNF, with priorities (the "DWA" approachs) - -dnfStrategyDWA :: LabeledStrategy (Context SLogic) -dnfStrategyDWA = label "Bring to dnf (DWA)" $ - repeat $ toplevel <|> somewhereOr - ( label "Simplify" simplify - |> label "Eliminate implications/equivalences" eliminateImplEquiv - |> label "Eliminate nots" eliminateNots - |> label "Move ors to top" orToTop - ) - where - toplevel = useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr - , ruleAbsorpOr, ruleComplOr - ] - simplify = somewhere $ useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd - , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse - , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd - , ruleComplOr, ruleComplAnd - ] - eliminateImplEquiv = somewhere $ useRules - [ ruleDefImpl, ruleDefEquiv - ] - eliminateNots = somewhere $ useRules - [ generalRuleDeMorganAnd, generalRuleDeMorganOr - , ruleDeMorganAnd, ruleDeMorganOr - ] - orToTop = somewhere $ useRules - [ generalRuleAndOverOr, ruleAndOverOr ] - --- A specialized variant of the somewhere traversal combinator. Apply --- the strategy only at (top-level) disjuncts -somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic) -somewhereOr s = - let isOr = maybe False (isOperator orOperator) . current - in fix $ \this -> check (Prelude.not . isOr) <*> s - <|> check isOr <*> once this - ---check1, check2 :: (a -> Bool) -> Rule a ---check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing ---check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing - - ------------------------------------------------------------------------------ --- To DNF, in four steps - -dnfStrategy :: LabeledStrategy (Context SLogic) -dnfStrategy = label "Bring to dnf" - $ label "Eliminate constants" eliminateConstants - <*> label "Eliminate implications/equivalences" eliminateImplEquiv - <*> label "Eliminate nots" eliminateNots - <*> label "Move ors to top" orToTop - where - eliminateConstants = repeat $ topDown $ useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd - , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv - , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl - ] - eliminateImplEquiv = repeat $ bottomUp $ useRules - [ ruleDefImpl, ruleDefEquiv - ] - eliminateNots = repeat $ topDown $ - useRules - [ generalRuleDeMorganAnd, generalRuleDeMorganOr ] - |> useRules - [ ruleDeMorganAnd, ruleDeMorganOr - , ruleNotNot - ] - orToTop = repeat $ somewhere $ - liftToContext generalRuleAndOverOr |> - liftToContext ruleAndOverOr - --- local helper function -useRules :: [Rule SLogic] -> Strategy (Context SLogic) +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Strategies + ( dnfStrategy, dnfStrategyDWA, somewhereOr + ) where + +import Prelude hiding (repeat) +import Domain.Logic.Rules +import Domain.Logic.GeneralizedRules +import Domain.Logic.Formula +import Common.Context (Context, liftToContext) +import Common.Transformation +import Common.Strategy +import Common.Navigator + +----------------------------------------------------------------------------- +-- To DNF, with priorities (the "DWA" approach) + +dnfStrategyDWA :: LabeledStrategy (Context SLogic) +dnfStrategyDWA = label "Bring to dnf (DWA)" $ + repeat $ toplevel <|> somewhereOr + ( label "Simplify" simplify + |> label "Eliminate implications/equivalences" eliminateImplEquiv + |> label "Eliminate nots" eliminateNots + |> label "Move ors to top" orToTop + ) + where + toplevel = useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr + , ruleAbsorpOr, ruleComplOr + ] + simplify = somewhere $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse + , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd + , ruleComplOr, ruleComplAnd + ] + eliminateImplEquiv = somewhere $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = somewhere $ useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr + , ruleDeMorganAnd, ruleDeMorganOr + ] + orToTop = somewhere $ useRules + [ generalRuleAndOverOr, ruleAndOverOr ] + +-- A specialized variant of the somewhere traversal combinator. Apply +-- the strategy only at (top-level) disjuncts +somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic) +somewhereOr s = + let isOr a = case current a of + Just (_ :||: _) -> True + _ -> False + in fix $ \this -> check (Prelude.not . isOr) <*> s + <|> check isOr <*> once this + +--check1, check2 :: (a -> Bool) -> Rule a +--check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing +--check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing + + +----------------------------------------------------------------------------- +-- To DNF, in four steps + +dnfStrategy :: LabeledStrategy (Context SLogic) +dnfStrategy = label "Bring to dnf" + $ label "Eliminate constants" eliminateConstants + <*> label "Eliminate implications/equivalences" eliminateImplEquiv + <*> label "Eliminate nots" eliminateNots + <*> label "Move ors to top" orToTop + where + eliminateConstants = repeat $ topDown $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv + , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl + ] + eliminateImplEquiv = repeat $ bottomUp $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = repeat $ topDown $ + useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr ] + |> useRules + [ ruleDeMorganAnd, ruleDeMorganOr + , ruleNotNot + ] + orToTop = repeat $ somewhere $ + liftToContext generalRuleAndOverOr |> + liftToContext ruleAndOverOr + +-- local helper function +useRules :: [Rule SLogic] -> Strategy (Context SLogic) useRules = alternatives . map liftToContext diff --git a/src/Domain/Logic/Views.hs b/src/Domain/Logic/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Views.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Views where + +import Common.View +import Domain.Logic.Formula + +------------------------------------------------------------ +-- Smart constructors + +infixr 2 .<->. +infixr 3 .->. +infixr 4 .||. +infixr 5 .&&. + +(.<->.) :: Logic a -> Logic a -> Logic a +T .<->. q = q +F .<->. q = nott q +p .<->. T = p +p .<->. F = nott p +p .<->. q = p :<->: q + +(.->.) :: Logic a -> Logic a -> Logic a +T .->. q = q +F .->. _ = T +_ .->. T = T +p .->. F = nott p +p .->. q = p :->: q + +(.||.) :: Logic a -> Logic a -> Logic a +T .||. _ = T +F .||. q = q +_ .||. T = T +p .||. F = p +p .||. q = p :||: q + +(.&&.) :: Logic a -> Logic a -> Logic a +T .&&. q = q +F .&&. _ = F +p .&&. T = p +_ .&&. F = F +p .&&. q = p :&&: q + +nott :: Logic a -> Logic a +nott (Not p) = p +nott p = Not p + +------------------------------------------------- +-- Views and transformations + +simplify :: Logic a -> Logic a +simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F) + +pushNotWith :: (a -> Logic a) -> Logic a -> Logic a +pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F) + where + rec logic = + case logic of + Not p :<->: q -> p .<->. q + p :<->: Not q -> p .<->. q + p :<->: q -> rec p .<->. q + p :->: q -> p .&&. rec q + p :||: q -> rec p .&&. rec q + p :&&: q -> rec p .||. rec q + Not p -> p + T -> F + F -> T + Var a -> f a + +pushNot :: Logic a -> Logic a +pushNot = pushNotWith (nott . Var) + +orView :: View (Logic a) [a] +orView = newView "logic.orView" (($ []) . f) (foldr ((.||.). Var) F) + where + f (p :||: q) = (>>= f p) . f q + f (Var a) = return . (a:) + f F = return + f _ = const Nothing + +andView :: View (Logic a) [a] +andView = newView "logic.andView" (($ []) . f) (foldr ((.&&.). Var) T) + where + f (p :&&: q) = (>>= f p) . f q + f (Var a) = return . (a:) + f T = return + f _ = const Nothing 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 @@ -23,8 +23,8 @@ -- Precision of a floating-point number precision :: Int -> Double -> Double -precision n = (/a) . fromIntegral . round . (*a) - where a = 10 Prelude.^ (max 0 n) +precision n = (/a) . fromInteger . round . (*a) + where a = 10 Prelude.^ max 0 n ------------------------------------------------------------ -- Stop criteria diff --git a/src/Domain/Math/Clipboard.hs b/src/Domain/Math/Clipboard.hs --- a/src/Domain/Math/Clipboard.hs +++ b/src/Domain/Math/Clipboard.hs @@ -18,12 +18,12 @@ -- generalized interface , addToClipboardG, addListToClipboardG , lookupClipboardG, lookupListClipboardG + , maybeOnClipboardG ) where import Common.Context import Control.Monad import Common.Rewriting -import Common.Rewriting.Term (Term) import Data.Maybe import Domain.Math.Data.Relation import Domain.Math.Expr @@ -47,7 +47,7 @@ modifyExprVar :: IsTerm a => ExprVar a -> (a -> a) -> ContextMonad () modifyExprVar (ExprVar var) f = - let safe f a = fromMaybe a (f a) + let safe h a = fromMaybe a (h a) g = fmap (toTerm . f) . fromTerm in modifyVar var (safe g) @@ -104,6 +104,11 @@ m <- readExprVar clipboard expr <- maybeCM (M.lookup (Key s) m) fromExpr expr - + +maybeOnClipboardG :: IsTerm a => String -> ContextMonad (Maybe a) +maybeOnClipboardG s = do + m <- readExprVar clipboard + return (M.lookup (Key s) m >>= fromExpr) + lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a] lookupListClipboardG = mapM lookupClipboardG diff --git a/src/Domain/Math/Data/Interval.hs b/src/Domain/Math/Data/Interval.hs --- a/src/Domain/Math/Data/Interval.hs +++ b/src/Domain/Math/Data/Interval.hs @@ -30,6 +30,7 @@ , testMe ) where +import Common.TestSuite import Common.Utils (commaList) import Control.Monad import Data.Maybe @@ -69,8 +70,8 @@ fmap f (IS xs) = IS (map (fmap f) xs) showLeft, showRight :: Show a => Endpoint a -> String -showLeft (Excluding a) = "(" ++ show a -showLeft (Including a) = "[" ++ show a +showLeft (Excluding a) = '(' : show a +showLeft (Including a) = '[' : show a showLeft Unbounded = "(-inf" showRight (Excluding a) = show a ++ ")" showRight (Including a) = show a ++ "]" @@ -203,11 +204,11 @@ isInInterval :: Ord a => a -> Interval a -> Bool isInInterval _ Empty = False -isInInterval a (I b c) = f GT b && f LT c +isInInterval a (I x y) = f GT x && f LT y where - f value x = - let g c = (c==EQ && isIncluding x) || c==value - in maybe True (g . compare a) (getPoint x) + f value b = + let g c = (c==EQ && isIncluding b) || c==value + in maybe True (g . compare a) (getPoint b) --------------------------------------------------------------------- -- Local helper functions @@ -269,9 +270,9 @@ , (1, return Unbounded) ] instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where - coarbitrary (Excluding a) = variant 0 . coarbitrary a - coarbitrary (Including a) = variant 1 . coarbitrary a - coarbitrary Unbounded = variant 2 + coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a + coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a + coarbitrary Unbounded = variant (2 :: Int) instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where arbitrary = frequency @@ -279,8 +280,8 @@ , (5, liftM2 makeInterval arbitrary arbitrary) ] instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where - coarbitrary Empty = variant 0 - coarbitrary (I a b) = variant 1 . coarbitrary a . coarbitrary b + coarbitrary Empty = variant (0 :: Int) + coarbitrary (I a b) = variant (1 :: Int) . coarbitrary a . coarbitrary b instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where arbitrary = do @@ -290,42 +291,42 @@ instance (CoArbitrary a, Ord a) => CoArbitrary (Intervals a) where coarbitrary (IS xs) = coarbitrary xs -testMe :: IO () -testMe = do - putStrLn "** Intervals" - -- Constructor functions - quickCheck $ op0 empty (const False) - quickCheck $ op0 unbounded (const True) +testMe :: TestSuite +testMe = suite "Intervals" $ do + + suite "Constructor functions" $ do + addProperty "empty" $ op0 empty (const False) + addProperty "unbounded" $ op0 unbounded (const True) - quickCheck $ op1 greaterThan (>) - quickCheck $ op1 greaterThanOrEqualTo (>=) - quickCheck $ op1 lessThan (<) - quickCheck $ op1 lessThanOrEqualTo (<=) - quickCheck $ op1 singleton (==) + addProperty "greater than" $ op1 greaterThan (>) + addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=) + addProperty "less than" $ op1 lessThan (<) + addProperty "less than or equal to" $ op1 lessThanOrEqualTo (<=) + addProperty "singleton" $ op1 singleton (==) - quickCheck $ op2 open (<) (<) - quickCheck $ op2 closed (<=) (<=) - quickCheck $ op2 leftOpen (<) (<=) - quickCheck $ op2 rightOpen (<=) (<) + addProperty "open" $ op2 open (<) (<) + addProperty "closed" $ op2 closed (<=) (<=) + addProperty "left open" $ op2 leftOpen (<) (<=) + addProperty "right open" $ op2 rightOpen (<=) (<) - -- From/to lists - quickCheck fromTo1 - quickCheck fromTo2 + suite "From/to lists" $ do + addProperty "" fromTo1 + addProperty "" fromTo2 - -- Combinators - quickCheck defExcept - quickCheck defUnion - quickCheck defIntersect - quickCheck defComplement + suite "Combinators" $ do + addProperty "except" defExcept + addProperty "union" defUnion + addProperty "intersect" defIntersect + addProperty "complement" defComplement - -- Combinator properties - quickCheck $ selfInverse complement - quickCheck $ transitive union - quickCheck $ commutative union - quickCheck $ absorption union - quickCheck $ transitive intersect - quickCheck $ commutative intersect - quickCheck $ absorption intersect + suite "Combinator properties" $ do + addProperty "inverse complement" $ selfInverse complement + addProperty "transitive union" $ transitive union + addProperty "commutative union" $ commutative union + addProperty "absorption union" $ absorption union + addProperty "transitive intersect" $ transitive intersect + addProperty "commutative intersect" $ commutative intersect + addProperty "absorption intersect" $ absorption intersect fromTo1, fromTo2 :: Intervals Int -> Bool fromTo1 a = fromList (toList a) == a 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 @@ -13,14 +13,14 @@ ( OrList , orList, (\/), true, false , isTrue, isFalse - , disjunctions, normalize, idempotent - , orView + , disjunctions, normalize, idempotent, fromBool + , oneDisjunct, orListView ) where import Common.View import Control.Monad -import Common.Traversable -import Common.Rewriting.Term +import Common.Classes +import Common.Rewriting import qualified Domain.Logic.Formula as Logic import Domain.Logic.Formula (Logic((:||:))) import Test.QuickCheck @@ -67,6 +67,15 @@ idempotent T = T idempotent (OrList xs) = OrList (nub xs) +oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a) +oneDisjunct f xs = + case disjunctions xs of + Just [a] -> f a + _ -> fail "oneDisjunct" + +fromBool :: Bool -> OrList a +fromBool b = if b then true else false + ------------------------------------------------------------ -- Instances @@ -74,6 +83,8 @@ joinOr :: OrList (OrList a) -> OrList a joinOr = maybe T (foldr (\/) false) . disjunctions +instance Rewrite a => Rewrite (OrList a) + instance Functor OrList where fmap _ T = T fmap f (OrList xs) = OrList (map f xs) @@ -82,9 +93,6 @@ return = OrList . return m >>= f = joinOr (fmap f m) -instance Once OrList where - onceM = useOnceJoin - instance Switch OrList where switch T = return T switch (OrList xs) = liftM orList (sequence xs) @@ -93,17 +101,9 @@ crush T = [] crush (OrList xs) = xs -instance OnceJoin OrList where - onceJoinM _ T = mzero - onceJoinM f (OrList xs) = rec xs - where - rec [] = mzero - rec (x:xs) = liftM (\/ orList xs) (f x) `mplus` - liftM (return x \/) (rec xs) - instance IsTerm a => IsTerm (OrList a) where - toTerm = toTerm . build orView - fromTerm expr = fromTerm expr >>= matchM orView + toTerm = toTerm . build orListView + fromTerm expr = fromTerm expr >>= matchM orListView instance Arbitrary a => Arbitrary (OrList a) where arbitrary = do @@ -111,8 +111,8 @@ xs <- vector n return (OrList xs) instance CoArbitrary a => CoArbitrary (OrList a) where - coarbitrary T = variant 0 - coarbitrary (OrList xs) = variant 1 . coarbitrary xs + coarbitrary T = variant (0 :: Int) + coarbitrary (OrList xs) = variant (1 :: Int) . coarbitrary xs instance Show a => Show (OrList a) where show T = "true" @@ -123,8 +123,8 @@ ------------------------------------------------------------ -- View to the logic data type -orView :: View (Logic a) (OrList a) -orView = makeView f g +orListView :: View (Logic a) (OrList a) +orListView = makeView f g where f p = case p of Logic.Var a -> return (return a) 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 @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- module Domain.Math.Data.Polynomial ( Polynomial, var, con, raise, power, scale - , degree, coefficient, terms + , degree, lowestDegree, coefficient, terms , isMonic, toMonic, isRoot, positiveRoots, negativeRoots , derivative, eval, division, longDivision, polynomialGCD , factorize @@ -21,7 +21,7 @@ import qualified Data.IntSet as IS import Data.Char import Control.Monad -import Common.Traversable +import Common.Classes import Data.List (nub) import Data.Ratio (approxRational) import Domain.Math.Approximation (newton, within) @@ -50,9 +50,6 @@ instance Functor Polynomial where fmap f (P m) = P (IM.map f m) -instance Once Polynomial where - onceM f (P m) = liftM P (onceM f m) - instance Switch Polynomial where switch (P m) = liftM P (switch m) @@ -97,6 +94,13 @@ | otherwise = IS.findMax is where is = IM.keysSet m +lowestDegree :: Polynomial a -> Int +lowestDegree (P m) + | IS.null is = 0 + | otherwise = IS.findMin is + where is = IM.keysSet m + + coefficient :: Num a => Int -> Polynomial a -> a coefficient n (P m) = IM.findWithDefault 0 n m @@ -158,7 +162,7 @@ -- polynomial long division, where p2 is monic monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) monicLongDivision p1 p2 - | d1 >= d2 && isMonic p2 = (toP quot, toP rem) + | d1 >= d2 && isMonic p2 = (toP quotient, toP remainder) | otherwise = error $ "invalid monic division" ++ show (p1, p2) where d1 = degree p1 @@ -166,7 +170,7 @@ xs = map (`coefficient` p1) [d1, d1-1 .. 0] ys = drop 1 $ map (negate . (`coefficient` p2)) [d2, d2-1 .. 0] - (quot, rem) = rec [] xs + (quotient, remainder) = rec [] xs toP = P . IM.filter (/= 0) . IM.fromAscList . zip [0..] rec acc (a:as) | length as >= length ys = @@ -203,10 +207,10 @@ , Just p2 <- [division p p1] ] - candidateRoots :: Polynomial Rational -> [Rational] - candidateRoots p = nub (map (`approxRational` 0.0001) xs) - where - f = eval (fmap fromRational p) - df = eval (fmap fromRational (derivative p)) - xs = nub (map (within 0.0001 . take 10 . newton f df) startList) - startList = [0, 3, -3, 10, -10, 100, -100] +candidateRoots :: Polynomial Rational -> [Rational] +candidateRoots p = nub (map (`approxRational` 0.0001) xs) + where + f = eval (fmap fromRational p) + df = eval (fmap fromRational (derivative p)) + xs = nub (map (within 0.0001 . take 10 . newton f df) startList) + startList = [0, 3, -3, 10, -10, 100, -100] 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 @@ -13,10 +13,13 @@ ( PrimeFactors , factors, multiplicity, coprime , square, power, splitPower - , primes + , primes, greatestPower, allPowers ) where import qualified Data.IntMap as IM +import Common.Utils +import Control.Monad +import Data.Maybe ------------------------------------------------------------- -- Representation @@ -35,9 +38,9 @@ -- Conversion to and from factors toFactors :: Integer -> Factors -toFactors n - | n > 0 = rec primes n - | n < 0 = rec primes (-n) +toFactors a + | a > 0 = rec primes a + | a < 0 = rec primes (-a) | otherwise = IM.singleton 0 1 where rec [] n = IM.singleton (fromIntegral n) 1 @@ -56,7 +59,7 @@ fromFactors :: Factors -> Integer fromFactors = product . map f . IM.toList - where f (a, i) = fromIntegral a ^ fromIntegral i + where f (a, i) = toInteger a ^ toInteger i -- For practical reasons, the list of prime numbers is cut-off after -- 1000 elements (last primes gives 7919). @@ -121,6 +124,28 @@ power :: PrimeFactors -> Int -> PrimeFactors power (PF a m) i = PF (a^i) (IM.map (*i) m) + +greatestPower :: Integer -> Maybe (Integer, Integer) +greatestPower n = do + guard $ n > 1 + let (as, xs) = unzip $ factors $ fromInteger n + x <- safeHead xs + guard $ allsame xs && x > 1 + return (fromIntegral (product as), fromIntegral x) + +-- n == a^x with (a,x) == greatestPower n +-- prop_greatestPower n = traceShow n $ +-- maybe True (\(a,x) -> fromIntegral a ^ fromIntegral x == n) $ greatestPower n + +allPowers :: Integer -> [(Integer, Integer)] +allPowers n = do + (b, e) <- maybeToList $ greatestPower n + let f i = let (a, r) = e `divMod` i + in if a > 1 && r == 0 then Just (b^i, a) else Nothing + mapMaybe f [1..e] + +-- prop_allPowers n = traceShow n $ +-- and (map (\(a,x) -> fromIntegral a ^ fromIntegral x == n) (allPowers n)) -- splitPower i a = (b,c) -- => b^i * c = a diff --git a/src/Domain/Math/Data/Relation.hs b/src/Domain/Math/Data/Relation.hs --- a/src/Domain/Math/Data/Relation.hs +++ b/src/Domain/Math/Data/Relation.hs @@ -16,6 +16,7 @@ Relational(..), mapLeft, mapRight, updateLeft, updateRight -- * Relation data type , Relation, relationType, RelationType(..), relationSymbols + , notRelation, eval -- * Constructor functions , makeType, (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) -- * Equation (or equality) @@ -25,10 +26,10 @@ ) where import Common.View -import Common.Rewriting (IsTerm(..), Rewrite) -import Common.Traversable -import Domain.Math.Expr.Symbolic -import qualified Text.OpenMath.Dictionary.Relation1 as Relation1 +import Common.Rewriting +import Common.Classes +import Domain.Math.Expr.Symbols (openMathSymbol) +import Text.OpenMath.Dictionary.Relation1 import Data.Maybe import Test.QuickCheck import Control.Monad @@ -40,7 +41,7 @@ leftHandSide :: f a -> a rightHandSide :: f a -> a flipSides :: f a -> f a -- possibly also flips operator - constructor :: f a -> (b -> b -> f b) + constructor :: f a -> b -> b -> f b isSymmetric :: f a -> Bool -- default definitions isSymmetric _ = False @@ -74,31 +75,56 @@ leftHandSide = lhs rightHandSide = rhs flipSides (R x rt y) = R y (flipRelType rt) x - constructor (R _ rt _) x y = R x rt y + constructor (R _ rt _) = flip R rt isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType instance IsTerm a => IsTerm (Relation a) where toTerm p = let op = relationType p - sym = maybe (toSymbol (show op)) snd (lookup op relationSymbols) + sym = maybe (newSymbol (show op)) snd (lookup op relationSymbols) in binary sym (toTerm (leftHandSide p)) (toTerm (rightHandSide p)) - fromTerm a = - let f (relType, (_, s)) = do - (e1, e2) <- isBinary s a - liftM2 (makeType relType) (fromTerm e1) (fromTerm e2) - in msum (map f relationSymbols) + fromTerm term = + case getFunction term of + Just (s, [a, b]) -> + case [ rt | (rt, (_, t)) <- relationSymbols, s==t ] of + [rt] -> liftM2 (makeType rt) (fromTerm a) (fromTerm b) + _ -> fail "fromTerm: relation" + _ -> fail "fromTerm: relation" instance Rewrite a => Rewrite (Relation a) relationSymbols :: [(RelationType, (String, Symbol))] relationSymbols = - [ (EqualTo, ("==", eqSymbol)), (NotEqualTo, ("/=", neqSymbol)) - , (LessThan, ("<", ltSymbol)), (GreaterThan, (">", gtSymbol)) - , (LessThanOrEqualTo, ("<=", leqSymbol)) - , (GreaterThanOrEqualTo, (">=", geqSymbol)) - , (Approximately, ("~=", approxSymbol)) + [ (EqualTo, ("==", openMathSymbol eqSymbol)) + , (NotEqualTo, ("/=", openMathSymbol neqSymbol)) + , (LessThan, ("<", openMathSymbol ltSymbol)) + , (GreaterThan, (">", openMathSymbol gtSymbol)) + , (LessThanOrEqualTo, ("<=", openMathSymbol leqSymbol)) + , (GreaterThanOrEqualTo, (">=", openMathSymbol geqSymbol)) + , (Approximately, ("~=", openMathSymbol approxSymbol)) ] +notRelation :: Relation a -> Relation a +notRelation r = r { relationType = relationType r ? table } + where + table = xs ++ map swap xs ++ [(Approximately, Approximately)] + swap (x, y) = (y, x) + xs = [ (EqualTo, NotEqualTo) + , (LessThan, GreaterThanOrEqualTo) + , (LessThanOrEqualTo, GreaterThan) + ] + +eval :: Ord a => RelationType -> a -> a -> Bool +eval relType = + case relType of + EqualTo -> (==) + NotEqualTo -> (/=) + LessThan -> (<) + GreaterThan -> (>) + LessThanOrEqualTo -> (<=) + GreaterThanOrEqualTo -> (>=) + Approximately -> (==) + -- helpers showRelType :: RelationType -> String showRelType = fst . (? relationSymbols) @@ -115,18 +141,12 @@ ----------------------------------------------------------------------------- -- Traversable instance declarations -instance Once Relation where onceM = onceMRelation instance Switch Relation where switch = switchRelation instance Crush Relation where crush = crushRelation switchRelation :: (Relational f, Monad m) => f (m a) -> m (f a) switchRelation p = liftM2 (constructor p) (leftHandSide p) (rightHandSide p) - -onceMRelation :: (Relational f, MonadPlus m) => (a -> m a) -> f a -> m (f a) -onceMRelation f p = - liftM (`updateLeft` p) (f (leftHandSide p)) `mplus` - liftM (`updateRight` p) (f (rightHandSide p)) crushRelation :: Relational f => f a -> [a] crushRelation p = [leftHandSide p, rightHandSide p] @@ -176,7 +196,10 @@ instance Functor Equation where fmap f (x :==: y) = f x :==: f y - + +instance Zip Equation where + fzipWith f (a :==: b) (c :==: d) = f a c :==: f b d + instance Relational Equation where leftHandSide = leftHandSide . build equationView rightHandSide = rightHandSide . build equationView @@ -184,7 +207,6 @@ constructor = const (:==:) isSymmetric = const True -instance Once Equation where onceM = onceMRelation instance Switch Equation where switch = switchRelation instance Crush Equation where crush = crushRelation @@ -232,7 +254,6 @@ let relType = relationType (build inequalityView ineq) in fst (relType ? inequalityTable) -instance Once Inequality where onceM = onceMRelation instance Switch Inequality where switch = switchRelation instance Crush Inequality where crush = crushRelation @@ -264,17 +285,4 @@ inequalityTable = [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.))) , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.))) - ] - ------------------------------------------------------------------------------ --- OpenMath symbols - -eqSymbol, ltSymbol, gtSymbol, neqSymbol, leqSymbol, - geqSymbol, approxSymbol :: Symbol -eqSymbol = toSymbol Relation1.eqSymbol -ltSymbol = toSymbol Relation1.ltSymbol -gtSymbol = toSymbol Relation1.gtSymbol -neqSymbol = toSymbol Relation1.neqSymbol -leqSymbol = toSymbol Relation1.leqSymbol -geqSymbol = toSymbol Relation1.geqSymbol -approxSymbol = toSymbol Relation1.approxSymbol + ] 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 @@ -80,14 +80,14 @@ recipSqMap m = case M.toList m of [] -> error "division by zero" - [(n, x)] -> M.singleton n (recip (x Prelude.* fromIntegral n)) - _ -> (a-b) * recipSqMap (makeMap ((a*a) - (b*b))) + [(n, x)] -> M.singleton n (recip (x * fromIntegral n)) + _ -> (a .-. b) .*. recipSqMap (makeMap ((a .*. a) .-. (b .*. b))) where (ys, zs) = splitAt (length xs `div` 2) xs (a, b) = (M.fromList ys, M.fromList zs) xs = M.toList m - (*) = timesSqMap - (-) = minusSqMap + (.*.) = timesSqMap + (.-.) = minusSqMap sqrtPF :: Num a => P.PrimeFactors -> SqMap a sqrtPF n @@ -100,13 +100,13 @@ -- Type class instances instance Num a => Show (SquareRoot a) where - show (S b m) = g (map f (M.toList m)) ++ imPart + show (S isNeg m) = g (map f (M.toList m)) ++ imPart where f (n, a) = ( signum a == -1 , times (guard (abs a /= 1) >> Just (show (abs a))) (guard (n /= 1) >> Just ("sqrt(" ++ show (toInteger n) ++ ")")) ) - imPart = if b then " (imaginary number)" else "" + imPart = if isNeg then " (imaginary number)" else "" g [] = "0" g ((b,x):xs) = (if b then "-" else "") ++ x ++ concatMap h xs h (b, x) = (if b then " - " else " + ") ++ x @@ -147,7 +147,7 @@ fromSquareRoot :: Num a => SquareRoot a -> Maybe a fromSquareRoot a = case toList a of - [(a, n)] | n==1 -> Just a + [(b, n)] | n==1 -> Just b [] -> Just 0 _ -> Nothing @@ -165,7 +165,7 @@ scale a sr = if a==0 then 0 else fmap (*a) sr isqrt :: Integer -> Integer -isqrt = floor . Prelude.sqrt . fromInteger +isqrt = (floor :: Double -> Integer) . Prelude.sqrt . fromInteger sqrtRational :: Fractional a => Rational -> SquareRoot a sqrtRational r = scale (1/fromIntegral b) (sqrt (a*b)) diff --git a/src/Domain/Math/Derivative/Exercises.hs b/src/Domain/Math/Derivative/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Derivative/Exercises.hs @@ -0,0 +1,219 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Derivative.Exercises + ( derivativeExercise, derivativePolyExercise + , derivativeProductExercise, derivativeQuotientExercise + , derivativePowerExercise + ) where + +import Common.Library +import Common.Uniplate +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ord +import Domain.Math.Derivative.Rules +import Domain.Math.Derivative.Strategies +import Domain.Math.Examples.DWO5 +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Generators +import Domain.Math.Polynomial.RationalExercises +import Domain.Math.Polynomial.Views +import Prelude hiding (repeat, (^)) +import Test.QuickCheck + +derivativePolyExercise :: Exercise Expr +derivativePolyExercise = describe + "Find the derivative of a polynomial. First normalize the polynomial \ + \(e.g., with distribution). Don't make use of the product-rule, or \ + \other chain rules." $ makeExercise + { exerciseId = diffId # "polynomial" + , status = Provisional + , parser = parseExpr + , isReady = (`belongsTo` polyNormalForm rationalView) + , isSuitable = isPolyDiff + , equivalence = eqPolyDiff + , similarity = simPolyDiff + , strategy = derivativePolyStrategy + , navigation = navigator + , examples = concat (diffSet1 ++ diffSet2 ++ diffSet3) + , testGenerator = Just $ liftM (diff . lambda (Var "x")) $ + sized quadraticGen + } + +derivativeProductExercise :: Exercise Expr +derivativeProductExercise = describe + "Use the product-rule to find the derivative of a polynomial. Keep \ + \the parentheses in your answer." $ + derivativePolyExercise + { exerciseId = diffId # "product" + , isReady = noDiff + , strategy = derivativeProductStrategy + , examples = concat diffSet3 + } + +derivativeQuotientExercise :: Exercise Expr +derivativeQuotientExercise = describe + "Use the quotient-rule to find the derivative of a polynomial. Only \ + \remove parentheses in the numerator." $ + derivativePolyExercise + { exerciseId = diffId # "quotient" + , isReady = readyQuotientDiff + , isSuitable = isQuotientDiff + , equivalence = eqQuotientDiff + , strategy = derivativeQuotientStrategy + , ruleOrdering = ruleOrderingWithId [ruleDerivQuotient] + , examples = concat diffSet4 + , testGenerator = Nothing + } + +derivativePowerExercise :: Exercise Expr +derivativePowerExercise = describe + "First write as a power, then find the derivative. Rewrite negative or \ + \rational exponents." $ + derivativePolyExercise + { exerciseId = diffId # "power" + , status = Experimental + , isReady = \a -> noDiff a && onlyNatPower a + , isSuitable = const True + , equivalence = \_ _ -> True -- \x y -> eqApprox (evalDiff x) (evalDiff y) + , strategy = derivativePowerStrategy + , examples = concat (diffSet5 ++ diffSet6) + , testGenerator = Nothing + } + +derivativeExercise :: Exercise Expr +derivativeExercise = makeExercise + { exerciseId = describe "Derivative" diffId + , status = Experimental + , parser = parseExpr + , isReady = noDiff + , strategy = derivativeStrategy + , ruleOrdering = derivativeOrdering + , navigation = navigator + , examples = concat (diffSet3++diffSet4++ + diffSet5++diffSet6++diffSet7++diffSet8) + } + +derivativeOrdering :: Rule a -> Rule a -> Ordering +derivativeOrdering = comparing f + where + f a = (getId a /= j, getId a == i, showId a) + i = getId ruleDefRoot + j = getId ruleDerivPolynomial + +isPolyDiff :: Expr -> Bool +isPolyDiff = maybe False (`belongsTo` polyViewWith rationalView) . getDiffExpr + +isQuotientDiff :: Expr -> Bool +isQuotientDiff de = fromMaybe False $ do + expr <- getDiffExpr de + xs <- match sumView expr + let f a = maybe [a] (\(x, y) -> [x, y]) (match divView a) + ys = concatMap f xs + isp = (`belongsTo` polyViewWith rationalView) + return (all isp ys) + +eqPolyDiff :: Expr -> Expr -> Bool +eqPolyDiff x y = + let f a = fromMaybe (descend f a) (apply ruleDerivPolynomial a) + in viewEquivalent (polyViewWith rationalView) (f x) (f y) + +eqQuotientDiff :: Expr -> Expr -> Bool +eqQuotientDiff a b = eqSimplifyRational (make a) (make b) + where + make = inContext derivativeQuotientExercise . f + rs = [ ruleDerivPolynomial, ruleDerivQuotient, ruleDerivProduct + , ruleDerivNegate, ruleDerivPlus, ruleDerivMin + ] + f x = case mapMaybe (`apply` x) rs of + hd:_ -> f hd + [] -> descend f x + +readyQuotientDiff :: Expr -> Bool +readyQuotientDiff expr = fromMaybe False $ do + xs <- match sumView expr + let f a = fromMaybe (a, 1) (match divView a) + (ys, zs) = unzip (map f xs) + isp = (`belongsTo` polyViewWith rationalView) + nfp = (`belongsTo` polyNormalForm rationalView) + return (all nfp ys && all isp zs) + +simPolyDiff :: Expr -> Expr -> Bool +simPolyDiff x y = + let f = acExpr . cleanUpExpr + in f x == f y + +noDiff :: Expr -> Bool +noDiff e = null [ () | Sym s _ <- universe e, isDiffSymbol s ] + +onlyNatPower :: Expr -> Bool +onlyNatPower e = and [ isNat a | Sym s [_, a] <- universe e, isPowerSymbol s ] + where + isNat (Nat _) = True + isNat _ = False + +{- +evalDiff :: Expr -> Expr +evalDiff expr + | isDiff expr = + case concatMap (`applyAll` expr) list of + hd:_ -> evalDiff hd + _ -> expr + | otherwise = descend evalDiff expr + where + list = [ ruleDerivPolynomial, ruleDerivPowerFactor + , ruleDerivPlus, ruleDerivMin, ruleDerivNegate + , ruleDerivProduct, ruleDerivQuotient + , ruleDerivPowerChain, ruleDerivSqrtChain, ruleDerivRoot + ] + +go = checkExercise derivativePowerExercise + +raar i = printDerivation derivativePowerExercise expr + where + expr = examples derivativePowerExercise !! i + +eqApprox :: Expr -> Expr -> Bool +eqApprox a b = rec 5 doubleList + where + vs = nub (collectVars a ++ collectVars b) + + rec 0 = const True + rec n = rec2 n 10 + + rec2 _ 0 ds = undefined -- a==b + rec2 n m ds = case eqApproxWith f a b of + Just b -> b && rec (n-1) ys + Nothing -> rec2 n (m-1) ys + where + (xs, ys) = splitAt (length vs) ds + f = (xs !!) . fromMaybe 0 . (`elemIndex` vs) + +eqApproxWith :: (String -> Double) -> Expr -> Expr -> Maybe Bool +eqApproxWith f a b = do + d1 <- match doubleView (subst a) + d2 <- match doubleView (subst b) + return $ abs (d1 - d2) < 1e-9 -- 11 is still ok for example set + where + subst (Var s) = Number (f s) + subst expr = descend subst expr + +doubleList :: [Double] -- between -20 and 20 +doubleList = iterate next (pi*exp 1) + where + next :: Double -> Double + next a = if b > 20 then b-20 else b + where + b = a + exp 3 * log 2 -} diff --git a/src/Domain/Math/Derivative/Rules.hs b/src/Domain/Math/Derivative/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Derivative/Rules.hs @@ -0,0 +1,210 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Derivative.Rules where + +import Prelude hiding ((^)) +import Common.Transformation +import Common.View +import Control.Monad +import Domain.Math.Expr +import Common.Id +import Common.Rewriting +import Data.Maybe +import Domain.Math.Polynomial.Views +import Domain.Math.Numeric.Views +import Domain.Math.Data.Polynomial +import Domain.Math.Power.Views +import Domain.Math.Power.Utils ( (<&>) ) + + +derivativeRules :: [Rule Expr] +derivativeRules = + [ ruleDerivCon, ruleDerivPlus, ruleDerivMin, ruleDerivNegate + , ruleDerivMultiple, ruleDerivPower, ruleDerivVar + , ruleDerivProduct, ruleDerivQuotient, ruleDerivPowerChain + , ruleSine, ruleLog, ruleDerivSqrt, ruleDerivSqrtChain + ] + +diff :: Expr -> Expr +diff = unary diffSymbol + +ln :: Expr -> Expr +ln = unary lnSymbol + +lambda :: Expr -> Expr -> Expr +lambda = binary lambdaSymbol + +diffId :: Id +diffId = newId "calculus.differentiation" + +isDiffSymbol, isLambdaSymbol :: Symbol -> Bool +isDiffSymbol = (== diffSymbol) +isLambdaSymbol = (== lambdaSymbol) + +----------------------------------------------------------------- +-- Rules for Diffs + +ruleSine :: Rule Expr +ruleSine = rule (diffId, "sine") $ + \x -> diff (lambda x (sin x)) :~> cos x + +ruleLog :: Rule Expr +ruleLog = rule (diffId, "logarithmic") $ + \x -> diff (lambda x (ln x)) :~> 1/x + +ruleDerivPlus :: Rule Expr +ruleDerivPlus = rule (diffId, "plus") $ + \x f g -> diff (lambda x (f + g)) :~> diff (lambda x f) + diff (lambda x g) + +ruleDerivMin :: Rule Expr +ruleDerivMin = rule (diffId, "min") $ + \x f g -> diff (lambda x (f - g)) :~> diff (lambda x f) - diff (lambda x g) + +ruleDerivNegate :: Rule Expr +ruleDerivNegate = rule (diffId, "negate") $ + \x f -> diff (lambda x (-f)) :~> -diff (lambda x f) + +ruleDerivVar :: Rule Expr +ruleDerivVar = rule (diffId, "var") $ + \x -> diff (lambda x x) :~> 1 + +ruleDerivProduct :: Rule Expr +ruleDerivProduct = rule (diffId, "product") $ + \x f g -> diff (lambda x (f * g)) :~> diff (lambda x f)*g + f*diff (lambda x g) + +-- The second rewrite rule should not have been necessary, except that cleaning +-- up an expression will typically put the negate in front of the division: this +-- makes sure the rule is triggered anyway. +ruleDerivQuotient :: Rule Expr +ruleDerivQuotient = ruleList (diffId, "quotient") + [ \x f g -> diff (lambda x (f/g)) :~> (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2) + , \x f g -> diff (lambda x (-f/g)) :~> (g*diff (lambda x (-f)) - (-f)*diff (lambda x g)) / (g^2) + ] + +ruleDerivPolynomial :: Rule Expr +ruleDerivPolynomial = describe "This rule returns the derivative for all \ + \expressions that can be turned into a polynomial (of rational numbers). \ + \The polynomial does not have to be in standard form." $ + makeSimpleRule (diffId, "deriv-of-poly") f + where + f (Sym d [Sym l [Var v, expr]]) | isDiffSymbol d && isLambdaSymbol l = do + let myView = polyViewWith rationalView + (s, p) <- match myView expr + guard (s==v) + return (build myView (s, derivative p)) + f _ = Nothing + +----------------------------------- +-- Special rules (not defined with unification) + +ruleDerivCon :: Rule Expr +ruleDerivCon = makeSimpleRule (diffId, "constant") f + where + f (Sym d [Sym l [Var v, e]]) + | isDiffSymbol d && isLambdaSymbol l && withoutVar v e = return 0 + f _ = Nothing + +ruleDerivMultiple :: Rule Expr +ruleDerivMultiple = makeSimpleRule (diffId, "constant-multiple") f + where + f (Sym d [Sym l [x@(Var v), n :*: e]]) + | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = + return $ n * diff (lambda x e) + f (Sym d [Sym l [x@(Var v), e :*: n]]) + | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = + return $ n * diff (lambda x e) + f _ = Nothing + +ruleDerivPower :: Rule Expr +ruleDerivPower = makeSimpleRule (diffId, "power") f + where + f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) + | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && x==x1 && withoutVar v n = + return $ n * (x ^ (n-1)) + f _ = Nothing + +ruleDerivPowerChain :: Rule Expr +ruleDerivPowerChain = makeSimpleRule (diffId, "chain-power") f + where + f (Sym d [Sym l [x@(Var v), Sym p [a, n]]]) + | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar v n = + return $ n * (a ^ (n-1)) * diff (lambda x a) + f _ = Nothing + +ruleDerivSqrt :: Rule Expr +ruleDerivSqrt = makeSimpleRule (diffId, "sqrt") f + where + f (Sym d [Sym l [x@(Var _), Sqrt x1]]) + | isDiffSymbol d && isLambdaSymbol l && x==x1 = + return $ 1 / (2 * sqrt x) + f _ = Nothing + +ruleDerivSqrtChain :: Rule Expr +ruleDerivSqrtChain = makeSimpleRule (diffId, "chain-sqrt") f + where + f (Sym d [Sym l [x@(Var _), Sqrt a]]) + | isDiffSymbol d && isLambdaSymbol l = + return $ (1 / (2 * sqrt a)) * diff (lambda x a) + f _ = Nothing + +ruleDefRoot :: Rule Expr +ruleDefRoot = rule (diffId, "def-root") $ + \a b -> root a b :~> a ^ (1/b) + +ruleDerivRoot :: Rule Expr +ruleDerivRoot = rule (diffId, "def-root") $ + \a b x -> diff (lambda x (root a b)) :~> diff (lambda x (a ^ (1/b))) + +ruleDerivPowerFactor :: Rule Expr +ruleDerivPowerFactor = makeSimpleRule (diffId, "power-factor") $ \de -> do + expr <- getDiffExpr de + (a, x, r) <- match myPowerView expr + return $ build myPowerView (a*fromRational r, x, r-1) + +-- (a+b)/c ~> a/c + b/c +ruleSplitRational :: Rule Expr +ruleSplitRational = makeSimpleRule (diffId, "split-rational") $ \expr -> do + (up, c) <- match divView expr + (a, b) <- match plusView up + return (a/c + b/c) + +myPowerView :: View Expr (Expr, String, Rational) +myPowerView = makeView f g + where + f expr = case match timesView expr of + Just (a, b) -> do + guard (hasNoVar a) + (x, r) <- match powView b + return (a, x, r) + `mplus` do + guard (hasNoVar b) + (x, r) <- match powView a + return (b, x, r) + Nothing -> do + (x, r) <- match powView expr + return (1, x, r) + g (a, x, r) = a .*. (Var x .^. fromRational r) + + powView = (powerView <&> noPowerView) >>> myVarView *** rationalView + myVarView = makeView isVar Var + noPowerView = makeView (\expr -> Just (expr, 1)) (build powerView) + + isVar (Var x) = Just x + isVar _ = Nothing + +isDiff :: Expr -> Bool +isDiff = isJust . getDiffExpr + +getDiffExpr :: Expr -> Maybe Expr +getDiffExpr (Sym d [Sym l [Var _, expr]]) | + isDiffSymbol d && isLambdaSymbol l = Just expr +getDiffExpr _ = Nothing diff --git a/src/Domain/Math/Derivative/Strategies.hs b/src/Domain/Math/Derivative/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Derivative/Strategies.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Derivative.Strategies + ( derivativeStrategy, derivativePolyStrategy + , derivativeProductStrategy, derivativeQuotientStrategy + , derivativePowerStrategy, getDiffExpr + ) where + +import Common.Library +import Data.Maybe +import Domain.Math.Derivative.Rules +import Domain.Math.Expr +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Views +import Domain.Math.Polynomial.Rules +import Domain.Math.Numeric.Views +import Domain.Math.Power.Strategies +import Domain.Math.Power.Rules + +import Prelude hiding ((^)) + +derivativeStrategy :: LabeledStrategy (Context Expr) +derivativeStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ + label "Derivative" $ repeatS $ somewhere $ + alternatives (map liftToContext derivativeRules) + <|> derivativePolyStepStrategy + <|> check isDiffC <*> once (once (liftToContext ruleDefRoot)) + where + isDiffC = maybe False isDiff . current + +derivativePolyStrategy :: LabeledStrategy (Context Expr) +derivativePolyStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ + label "derivative-polynomial" $ + repeatS (somewhere (alternatives (map liftToContext rulesPolyNF))) + <*> derivativePolyStepStrategy + +rulesPolyNF :: [Rule Expr] +rulesPolyNF = + [ distributionSquare, distributeTimes, merge + , distributeDivision, noDivisionConstant + ] + +derivativeProductStrategy :: LabeledStrategy (Context Expr) +derivativeProductStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ + label "derivative-product" $ + repeatS (somewhere (derivativePolyStepStrategy |> alternatives list)) + where + list = map liftToContext + [ distributeDivision, noDivisionConstant + , ruleDerivProduct, defPowerNat + , ruleDerivNegate, ruleDerivPlus, ruleDerivMin + ] + +derivativeQuotientStrategy :: LabeledStrategy (Context Expr) +derivativeQuotientStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ + label "derivative-quotient" $ + repeatS (somewhere (derivativePolyStepStrategy |> alternatives list)) + <*> repeatS (exceptLowerDiv (alternatives (map liftToContext rulesPolyNF))) + where + list = map liftToContext + [ ruleDerivQuotient, ruleDerivPlus, ruleDerivMin, ruleDerivNegate ] + +derivativePowerStrategy :: LabeledStrategy (Context Expr) +derivativePowerStrategy = label "derivative-power" $ + cleanUpStrategy (applyTop cleanUpExpr) (label "split-rational" + (repeatS (somewhere (liftToContext ruleSplitRational)))) <*> + configure mycfg powerOfStrategy <*> + repeatS (distr <*> configure mycfg powerOfStrategy) <*> + cleanUpStrategy (applyTop cleanUpExpr) (label "use-derivative-rules" + (repeatS (somewhere (alternatives list)))) <*> + configure mycfg nonNegBrokenExpStrategy + where + list = map liftToContext + [ ruleDerivPlus, ruleDerivMin, ruleDerivNegate, ruleDerivPowerFactor + , ruleDerivCon ] + mycfg = [(byName myFractionTimes, Remove)] + distr = cleanUpStrategy (applyTop cleanUpExpr) $ + label "distr" (somewhere (alternatives (map liftToContext rulesPolyNF))) + +derivativePolyStepStrategy :: LabeledStrategy (Context Expr) +derivativePolyStepStrategy = label "derivative-poly-step" $ + check polyDiff <*> liftToContext ruleDerivPolynomial + where + polyDiff = maybe False nfPoly . (>>= getDiffExpr) . current + nfPoly = (`belongsTo` polyNormalForm rationalView) + +exceptLowerDiv :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr) +exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> + if isDivC a then [0] else [0 .. arity a-1] + where + isDivC = maybe False isDiv . current + isDiv (_ :/: _) = True + isDiv _ = False diff --git a/src/Domain/Math/DerivativeExercise.hs b/src/Domain/Math/DerivativeExercise.hs deleted file mode 100644 --- a/src/Domain/Math/DerivativeExercise.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS -fno-case-merge #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.DerivativeExercise where - -import Common.Uniplate (universe) -import Prelude hiding (repeat, (^)) -import Domain.Math.DerivativeRules -import Common.Strategy (Strategy, somewhere, (<*>), alternatives, label, LabeledStrategy, try) -import qualified Common.Strategy -import Common.Navigator -import Common.Context (Context, liftToContext) -import Common.Exercise -import Common.Transformation -import Control.Monad -import Domain.Math.Simplification -import Domain.Math.Expr - -derivativeExercise :: Exercise Expr -derivativeExercise = makeExercise - { description = "Derivative" - , exerciseCode = makeCode "math" "derivative" - , status = Experimental - , parser = parseExpr - , isReady = noDiff - , extraRules = map liftToContext derivativeRules ++ [tidyup] - , strategy = derivativeStrategy - , navigation = navigator - , examples = [ex1, ex2, ex3, ex4] - } - -noDiff :: Expr -> Bool -noDiff e = null [ () | Sym s _ <- universe e, s == diffSymbol ] - -derivativeStrategy :: LabeledStrategy (Context Expr) -derivativeStrategy = - label "Derivative" $ - try tidyup <*> Common.Strategy.repeat (derivative <*> try tidyup) - -tidyup :: Rule (Context Expr) -tidyup = liftToContext $ makeSimpleRule "Tidy-up rule" $ \old -> - let new = simplify old - in if old==new then Nothing else Just new - -derivative :: Strategy (Context Expr) -derivative = somewhere $ alternatives (map liftToContext derivativeRules) - -ex1, ex2, ex3 :: Expr -ex1 = diff $ lambda (Var "x") $ Var "x" ^ 2 -ex2 = diff $ lambda (Var "x") $ ((1/3) :*: (x ^ fromInteger 3)) :+: (fromInteger (-3) :*: (x ^ fromInteger 2)) :+: x :+: fromInteger (-5) - where x = Var "x" -ex3 = diff $ lambda (Var "x") (2 * Var "x") -ex4 = diff $ lambda (Var "x") (ln (Var "x")) - -main :: IO () -main = forM_ [ex1, ex2, ex3, ex4] $ - printDerivation derivativeExercise diff --git a/src/Domain/Math/DerivativeRules.hs b/src/Domain/Math/DerivativeRules.hs deleted file mode 100644 --- a/src/Domain/Math/DerivativeRules.hs +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.DerivativeRules where - -import Prelude hiding ((^)) -import Common.Transformation -import Domain.Math.Expr -import Common.Rewriting - -derivativeRules :: [Rule Expr] -derivativeRules = - [ ruleDerivCon, ruleDerivPlus, ruleDerivMin - , ruleDerivMultiple, ruleDerivPower, ruleDerivVar - , ruleDerivProduct, ruleDerivQuotient {-, ruleDerivChain-}, ruleDerivChainPowerExprs - , ruleSine, ruleLog - ] - -diff :: Expr -> Expr -diff = unary diffSymbol - -ln :: Expr -> Expr -ln = unary lnSymbol - -lambda :: Expr -> Expr -> Expr -lambda = binary lambdaSymbol - -fcomp :: Expr -> Expr -> Expr -fcomp = binary fcompSymbol - ------------------------------------------------------------------ --- Rules for Diffs - -ruleSine :: Rule Expr -ruleSine = rule "Sine" $ - \x -> diff (lambda x (sin x)) :~> lambda x (cos x) - -ruleLog :: Rule Expr -ruleLog = rule "Logarithmic" $ - \x -> diff (lambda x (ln x)) :~> lambda x (1/x) - -ruleDerivPlus :: Rule Expr -ruleDerivPlus = rule "Sum" $ - \x f g -> diff (lambda x (f + g)) :~> diff (lambda x f) + diff (lambda x g) - -ruleDerivMin :: Rule Expr -ruleDerivMin = rule "Sum" $ - \x f g -> diff (lambda x (f - g)) :~> diff (lambda x f) - diff (lambda x g) - -ruleDerivVar :: Rule Expr -ruleDerivVar = rule "Var" $ - \x -> diff (lambda x x) :~> 1 - -ruleDerivProduct :: Rule Expr -ruleDerivProduct = rule "Product" $ - \x f g -> diff (lambda x (f * g)) :~> f*diff (lambda x g) + g*diff (lambda x f) - -ruleDerivQuotient :: Rule Expr -ruleDerivQuotient = rule "Quotient" $ - \x f g -> diff (lambda x (f/g)) :~> (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2) - -{- ruleDerivChain :: Rule Expr -ruleDerivChain = rule "Chain Rule" f - where f (Diff x (f :.: g)) = return $ (Diff x f :.: g) :*: Diff x g - f _ = Nothing -} - ------------------------------------ --- Special rules (not defined with unification) - -ruleDerivCon :: Rule Expr -ruleDerivCon = makeSimpleRule "Constant Term" f - where - f (Sym d [Sym l [Var v, e]]) - | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars e = return 0 - f _ = Nothing - -ruleDerivMultiple :: Rule Expr -ruleDerivMultiple = makeSimpleRule "Constant Multiple" f - where - f (Sym d [Sym l [x@(Var v), n :*: e]]) - | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars n = - return $ n * diff (lambda x e) - f (Sym d [Sym l [x@(Var v), e :*: n]]) - | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars n = - return $ n * diff (lambda x e) - f _ = Nothing - -ruleDerivPower :: Rule Expr -ruleDerivPower = makeSimpleRule "Power" f - where - f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) - | d == diffSymbol && l == lambdaSymbol && p == powerSymbol && x==x1 && v `notElem` collectVars n = - return $ n * (x ^ (n-1)) - f _ = Nothing - -ruleDerivChainPowerExprs :: Rule Expr -ruleDerivChainPowerExprs = makeSimpleRule "Chain Rule for Power Exprs" f - where - f (Sym d [Sym l [x@(Var v), Sym p [g, n]]]) - | d == diffSymbol && l == lambdaSymbol && p == powerSymbol && v `notElem` collectVars n = - return $ n * (g ^ (n-1)) * diff (lambda x g) - f _ = Nothing diff --git a/src/Domain/Math/Equation/BalanceRules.hs b/src/Domain/Math/Equation/BalanceRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Equation/BalanceRules.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 Domain.Math.Equation.BalanceRules + ( plusT, minusT, timesT, divisionT + ) where + +import Common.Transformation +import Common.View +import Control.Monad +import Domain.Math.Data.Relation +import Domain.Math.Numeric.Views +import Domain.Math.Expr + +plusT, minusT :: Functor f => Expr -> Transformation (f Expr) +plusT e = makeTrans $ return . fmap (:+: e) +minusT e = makeTrans $ return . fmap (:-: e) + +timesT :: Functor f => Expr -> Transformation (f Expr) +timesT e = makeTrans $ unlessZero e . fmap (e :*:) + +divisionT :: Expr -> Transformation (Equation Expr) +divisionT e = makeTrans $ unlessZero e . fmap (:/: e) + +unlessZero :: MonadPlus m => Expr -> a -> m a +unlessZero e a = do + r <- matchM rationalView e + guard (r /= 0) + return a 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 @@ -9,22 +9,19 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Math.Equation.CoverUpExercise (coverUpExercise) where +module Domain.Math.Equation.CoverUpExercise + ( coverUpExercise, coverUpStrategy + ) where import Common.Context import Common.Exercise import Common.Strategy hiding (replicate) -import Common.Transformation -import Common.Uniplate (transform) -import Common.View import Control.Monad -import Data.Ratio import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Equation.CoverUpRules import Domain.Math.Equation.Views import Domain.Math.Examples.DWO1 -import Domain.Math.Numeric.Views import Domain.Math.Expr import Prelude hiding (repeat) @@ -33,14 +30,15 @@ coverUpExercise :: Exercise (OrList (Equation Expr)) coverUpExercise = makeExercise - { description = "solve an equation by covering up" - , exerciseCode = makeCode "math" "coverup" + { exerciseId = describe "solve an equation by covering up" $ + newId "algebra.equations.coverup" , status = Provisional , parser = parseExprWith (pOrList (pEquation pExpr)) - , equivalence = \_ _ -> True + -- , equivalence = \_ _ -> True , isReady = solvedEquations - , extraRules = map liftToContext coverUpRulesOr + , extraRules = coverUpRulesOr , strategy = coverUpStrategy + , navigation = termNavigator , examples = map (orList . return) (concat (fillInResult ++ coverUpEquations)) } @@ -49,8 +47,9 @@ coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) coverUpStrategy = label "Cover-up" $ - repeat (alternatives $ map (liftToContext . cleanUp) coverUpRulesOr) + repeat $ somewhere $ alternatives coverUpRulesOr +{- cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr)) cleanUp = doAfter $ fmap $ fmap cleanUpExpr @@ -59,7 +58,7 @@ where f (Negate a) = liftM negate (f a) f (Sqrt a) = match rationalView a >>= rootedRational 2 - f (Sym s [Nat n, a]) | s == rootSymbol = + f (Sym s [Nat n, a]) | isRootSymbol s = match rationalView a >>= rootedRational n f e = match rationalView e @@ -76,7 +75,7 @@ x <- rootedInt a (numerator r) y <- rootedInt a (denominator r) return (fromInteger x / fromInteger y) - +-} ------------------------------------------------------------ -- Testing 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 @@ -11,12 +11,13 @@ ----------------------------------------------------------------------------- module Domain.Math.Equation.CoverUpRules ( coverUpRules, coverUpRulesOr + , coverUp, coverUpOrs , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight , coverUpTimes, coverUpNegate , coverUpNumerator, coverUpDenominator, coverUpSqrt -- parameterized rules , ConfigCoverUp, configName, predicateCovered, predicateCombined - , coverLHS, coverRHS, configCoverUp, varConfig + , coverLHS, coverRHS, configCoverUp , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith @@ -24,86 +25,89 @@ , coverUpBinaryRule, commOp, flipOp ) where +import Common.Classes +import Common.Context +import Common.Id +import Common.Rewriting +import Common.Transformation import Common.View -import Domain.Math.Expr -import Domain.Math.Data.Relation import Control.Monad.Identity -import Common.Transformation +import Data.Maybe import Domain.Math.Data.OrList -import Common.Traversable +import Domain.Math.Data.Relation +import Domain.Math.Expr --------------------------------------------------------------------- -- Constructors for cover-up rules -coverUpBinary2Rule :: (OnceJoin f, Switch f, Relational r) - => String -> (Expr -> [(Expr, Expr)]) +coverUpFunction :: (Switch f, Relational r) + => (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> [f Expr]) - -> ConfigCoverUp -> Rule (f (r Expr)) -coverUpBinary2Rule opName fm fb cfg = - makeSimpleRuleList name $ onceJoinM $ \eq -> - (guard (coverLHS cfg) >> coverLeft eq) ++ - (guard (coverRHS cfg) >> coverRight eq) + -> ConfigCoverUp -> r Expr -> [f (r Expr)] +coverUpFunction fm fb cfg eq0 = + (guard (coverLHS cfg) >> coverLeft eq0) ++ + (guard (coverRHS cfg) >> coverRight eq0) where - name = coverUpRuleName opName (configName cfg) - coverRight = map (fmap flipSides) . coverLeft . flipSides - + coverRight = map (fmap flipSides) . coverLeft . flipSides coverLeft eq = do (e1, e2) <- fm (leftHandSide eq) guard (predicateCovered cfg e1) new <- fb (rightHandSide eq) e2 - switch $ fmap (guard . predicateCombined cfg) new + _ <- switch $ fmap (guard . predicateCombined cfg) new return (fmap (constructor eq e1) new) +coverUpBinaryOrRule :: Relational r + => String -> (Expr -> [(Expr, Expr)]) + -> (Expr -> Expr -> [OrList Expr]) + -> ConfigCoverUp -> Rule (OrList (r Expr)) +coverUpBinaryOrRule opName fm fb cfg = + let name = coverUpRuleName opName (configName cfg) + in makeSimpleRuleList name $ oneDisjunct $ coverUpFunction fm fb cfg + coverUpBinaryRule :: Relational r => String -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) -> ConfigCoverUp -> Rule (r Expr) -coverUpBinaryRule opName fm fb = - let v = makeView (return . Identity) runIdentity - fbi x y = [Identity (fb x y)] - in liftRule v . coverUpBinary2Rule opName fm fbi +coverUpBinaryRule opName fm fb cfg = + let name = coverUpRuleName opName (configName cfg) + fb2 a b = [Identity (fb a b)] + in makeSimpleRuleList name $ map runIdentity . coverUpFunction fm fb2 cfg coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr) -> ConfigCoverUp -> Rule (r Expr) coverUpUnaryRule opName fm fb = coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb) -coverUpRuleName :: String -> Maybe String -> String -coverUpRuleName opName viewName = - "cover-up " ++ opName ++ maybe "" (\s -> " [" ++ s ++ "]") viewName +coverUpRuleName :: String -> String -> Id +coverUpRuleName opName cfg = + let f = if null cfg then newId else ( cfg # ) + in "algebra.equations.coverup" # f opName --------------------------------------------------------------------- -- Configuration for cover-up rules data ConfigCoverUp = Config - { configName :: Maybe String + { configName :: String , predicateCovered :: Expr -> Bool , predicateCombined :: Expr -> Bool , coverLHS :: Bool , coverRHS :: Bool } +-- Default configuration: cover-up part with variables configCoverUp :: ConfigCoverUp configCoverUp = Config - { configName = Nothing - , predicateCovered = const True - , predicateCombined = const True + { configName = "" + , predicateCovered = hasSomeVar + , predicateCombined = hasNoVar , coverLHS = True , coverRHS = True } --- default configuration -varConfig :: ConfigCoverUp -varConfig = configCoverUp - { configName = Just "vars" - , predicateCovered = hasVars - , predicateCombined = noVars - } - --------------------------------------------------------------------- -- Parameterized cover-up rules coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr)) -coverUpPowerWith = coverUpBinary2Rule "power" (isBinary powerSymbol) fb +coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb where fb rhs e2 = do n <- isNat e2 @@ -116,10 +120,10 @@ coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-) coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpMinusLeftWith = coverUpBinaryRule "minus left" isMinus (+) +coverUpMinusLeftWith = coverUpBinaryRule "minus-left" isMinus (+) coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpMinusRightWith = coverUpBinaryRule "minus right" (flipOp . isMinus) (flip (-)) +coverUpMinusRightWith = coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-)) -- | Negations are pushed inside coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr) @@ -140,7 +144,7 @@ coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/)) coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpSqrtWith = coverUpUnaryRule "square root" isSqrt (\x -> x*x) +coverUpSqrtWith = coverUpUnaryRule "sqrt" isSqrt (\x -> x*x) where isSqrt (Sqrt a) = return a isSqrt _ = [] @@ -148,9 +152,23 @@ --------------------------------------------------------------------- -- Cover-up rules for variables -coverUpRulesOr :: [Rule (OrList (Equation Expr))] -coverUpRulesOr = coverUpPower : map ruleOnce coverUpRules +coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr) +coverUpOrs = join . fmap (f . coverUp) + where + f :: Equation Expr -> OrList (Equation Expr) + f eq = case apply coverUpPower (return eq) of + Just xs -> coverUpOrs xs + Nothing -> return eq + +coverUp :: Equation Expr -> Equation Expr +coverUp eq = + case mapMaybe (`apply` eq) coverUpRules of + hd:_ -> coverUp hd + _ -> eq +coverUpRulesOr :: IsTerm a => [Rule (Context a)] +coverUpRulesOr = use coverUpPower : map use coverUpRules + coverUpRules :: [Rule (Equation Expr)] coverUpRules = [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate @@ -161,15 +179,15 @@ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate, coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr) -coverUpPower = coverUpPowerWith varConfig -coverUpPlus = coverUpPlusWith varConfig -coverUpMinusLeft = coverUpMinusLeftWith varConfig -coverUpMinusRight = coverUpMinusRightWith varConfig -coverUpTimes = coverUpTimesWith varConfig -coverUpNegate = coverUpNegateWith varConfig -coverUpNumerator = coverUpNumeratorWith varConfig -coverUpDenominator = coverUpDenominatorWith varConfig -coverUpSqrt = coverUpSqrtWith varConfig +coverUpPower = coverUpPowerWith configCoverUp +coverUpPlus = coverUpPlusWith configCoverUp +coverUpMinusLeft = coverUpMinusLeftWith configCoverUp +coverUpMinusRight = coverUpMinusRightWith configCoverUp +coverUpTimes = coverUpTimesWith configCoverUp +coverUpNegate = coverUpNegateWith configCoverUp +coverUpNumerator = coverUpNumeratorWith configCoverUp +coverUpDenominator = coverUpDenominatorWith configCoverUp +coverUpSqrt = coverUpSqrtWith configCoverUp --------------------------------------------------------------------- -- Some helper-functions 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 @@ -19,7 +19,7 @@ import Domain.Math.Data.OrList import Domain.Math.Data.Relation import Common.View -import Common.Traversable +import Common.Classes -- generalized to relation solvedRelations :: (Crush f, Relational g) => f (g Expr) -> Bool @@ -31,9 +31,9 @@ solvedRelation r = case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of (Just _, Just _) -> False - (Just x, Nothing) -> x `notElem` collectVars (rightHandSide r) - (Nothing, Just x) -> x `notElem` collectVars (leftHandSide r) - _ -> noVars (leftHandSide r) && noVars (rightHandSide r) + (Just x, Nothing) -> withoutVar x (rightHandSide r) + (Nothing, Just x) -> withoutVar x (leftHandSide r) + _ -> hasNoVar (leftHandSide r) && hasNoVar (rightHandSide r) -- The variable must appear on the left solvedRelationWith :: Relational f => (Expr -> Bool) -> f Expr -> Bool @@ -48,12 +48,12 @@ solvedEquation :: Equation Expr -> Bool solvedEquation eq@(lhs :==: rhs) = - (eq `belongsTo` equationSolvedForm) || (noVars lhs && noVars rhs) + (eq `belongsTo` equationSolvedForm) || (hasNoVar lhs && hasNoVar rhs) equationSolvedForm :: View (Equation Expr) (String, Expr) equationSolvedForm = makeView f g where - f (Var x :==: e) | x `notElem` collectVars e = + f (Var x :==: e) | withoutVar x e = return (x, e) f _ = Nothing g (s, e) = Var s :==: e 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 @@ -20,6 +20,7 @@ ) where import Prelude hiding ((^)) +import Common.Rewriting import Domain.Math.Data.Relation import Domain.Math.Expr diff --git a/src/Domain/Math/Examples/DWO3.hs b/src/Domain/Math/Examples/DWO3.hs --- a/src/Domain/Math/Examples/DWO3.hs +++ b/src/Domain/Math/Examples/DWO3.hs @@ -15,6 +15,7 @@ module Domain.Math.Examples.DWO3 where import Prelude hiding ((^)) +import Common.Rewriting import Domain.Math.Expr ---------------------------------------------------------- diff --git a/src/Domain/Math/Examples/DWO4.hs b/src/Domain/Math/Examples/DWO4.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Examples/DWO4.hs @@ -0,0 +1,502 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Examples.DWO4 + ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit + , powerEquations, expEquations, logEquations, higherPowerEquations + , rootEquations, rootEquations2, rootSubstEquations, expEquations2 + ) where + +import Prelude hiding ((^)) +import Common.Rewriting +import Domain.Math.Data.Relation +import Domain.Math.Expr + +---------------------------------------------------------- +-- HAVO B applets + +-- Hoofdstuk 7, vergelijkingen met machten algebraisch (6) +powerEquations :: [[Equation Expr]] +powerEquations = + -- los vergelijkingen algebraisch op + let x = Var "x" in + [ [ x^14 :==: 25 + , x^(-7) :==: 110 + , 2*x^(3.5) :==: 70 + , 8*x^(-(9.2)) :==: 1000 + ] + , [ root x 5 :==: 2.9 + , 5 * root x 3 :==: 7 + , root (x^3) 4 :==: 720 + , root (x^2) 5 :==: 5.5 + ] + , [ 4*x^(-12) :==: 28 + , 7*x^(5.1) + 16 :==: 100 + , 8*x^(-((1.9))) - 5 :==: 2 + , 0.8 * x^(0.7) + 7 :==: 12.5 + ] + , [ 4*root x 7 + 7 :==: 11.8 + , 9*x^(3.2)+17 :==: 37 + , 6*x^(-(3.1))-9 :==: 12 + , 0.7 * x^(-(1.1)) + 17 :==: 40 + ] + ] + +-- Hoofdstuk 7, exponentiele vergelijkingen algebraisch (7) +expEquations :: [[Equation Expr]] +expEquations = + -- los exponentiele vergelijkingen algebraisch op + let x = Var "x" in + [ [ 2^x :==: 16 * sqrt 2 + , 2^(x+2) :==: 1/4 + , 3^(x-1) :==: 81 + , 3^(x+5) :==: 243/(sqrt 3) + ] + , [ 5^(2-x) :==: 0.04 + , 3^(2*x) :==: 1/9 + , 3^(1-3*x) :==: 81 + , 3^(3*x-2) :==: 3*sqrt 3 + ] + , [ 5*2^(x-1) :==: 20*sqrt 2 + , 6*5^(2-x) :==: 150 + , 2*7^(4*x-1) :==: 98 + , 8*3^(5-2*x) :==: 72*sqrt 3 + ] + , [ 2^x-7 :==: 9 + , 4^(3*x)+5 :==: 69 + , 7*3^(2*x+1) :==: 189 + , 5*2^(1-4*x)+11 :==: 51 + ] + , [ 5^(x-4) :==: (1/5)^(2*x+1) + , 7^(1-2*x) :==: 1 + , 4^(2*x-3) :==: 2*sqrt 2 + , 2*9^(1-2*x) :==: 6*sqrt 3 + ] + ] + +-- Hoofdstuk 7, logaritmische vergelijkingen algebraisch (8) +logEquations :: [[Equation Expr]] +logEquations = + -- los algebraisch op + let x = Var "x" in + [ [ logBase 2 x :==: 7 + , logBase 3 (x-2) :==: 2 + , logBase 4 (x-3) :==: 1+(1/2) + , logBase 5 ((1/10)*x-3) :==: -1 + , logBase x 7 :==: 1 + , logBase x 4 :==: -1 + , logBase 2 (x^2-1) :==: 3 + , logBase (1/3) (1-5*x) :==: -1 + ] + ] + + +---------------------------------------------------------- +-- VWO A/C applets + +-- Hoofdstuk 5, hogeremachtswortels (1) +higherPowerEquations :: [[Equation Expr]] +higherPowerEquations = + -- bereken exacte oplossing + let x = Var "x" in + [ [ 2*x^3+9 :==: 19 + , 4*x^5-17 :==: 27 + , 3*x^7+8 :==: 62 + , 5*x^3-1 :==: 9 + , 6-5*x^3 :==: 76 + , 11-7*x^5 :==: 53 + , 4-(1/5)*x^7 :==: 9 + , 18-11*x^7 :==: 62 + ] + , [ (1/2)*x^4+5 :==: 12 + , 5*x^6-37 :==: 68 + , 4*x^8-19 :==: 9 + , 5*x^6+7 :==: 97 + , 18-7*x^4 :==: -38 + , 3+(1/3)*x^6 :==: 7 + , 1-(1/9)*x^8 :==: -4 + , 47+15*x^8 :==: 77 + ] + , [ 18*x^8-11 :==: 7 + , (1/4)*x^6+14 :==: 30 + , 5*x^4+67 :==: 472 + , 5*x^4-1 :==: 4 + , (1/8)*x^7+24 :==: 40 + , (1/5)*x^3+27 :==: 52 + , 32*x^3+18 :==: 22 + , 4*x^3-8 :==: 100 + ] + , [ 14-2*x^3 :==: 700 + , 4-3*x^5 :==: 100 + , 14-11*x^7 :==: 25 + , 1-3*x^5 :==: 97 + ] + -- Geef in twee decimalen nauwkeurig + , [ 3*x^5+7 :==: 15 + , 0.7 * x^4 - 1.3 :==: 2 + , (1/3)*x^7 :==: 720 + ] + ] + +-- Hoofdstuk 5, hogeremachtswortels (2) +rootEquations :: [[Equation Expr]] +rootEquations = + -- Bereken exacte oplossing + let x = Var "x" in + let y = Var "y" in + [ [ x^4 :==: 6 + , root x 4 :==: 6 + , sqrt x :==: 10 + , root x 5 :==: 2 + ] + , [ 3*x^5-1 :==: 20 + , 3*root (x-1) 5 - 1 :==: 20 + , (1/10)*sqrt x + 2 :==: 12 + , (1/5)*x^7+8 :==: 26 + ] + , [ 3*root x 4+2 :==: 14 + , (1/2)*x^8-2 :==: 18 + , 5-2*root x 3 :==: 3 + ] + -- Maak x vrij + , [ y :==: x^5 + , y :==: 2*x^5+4 + , y :==: (1/10)*x^3-6 + , y :==: root x 7 + , y :==: 2*root x 3+8 + , y :==: (1/10)*root x 5-6 + ] + , [ y :==: 3*root x 7-6 + , y :==: (1/4)*x^9-6 + , y :==: 8+(1/2)*root x 3 + ] + ] + + + +---------------------------------------------------------- +-- VWO B applets + +-- Hoofdstuk 1, wortelvergelijkingen +rootEquations2 :: [[Equation Expr]] +rootEquations2 = + let x = Var "x" in + -- los algebraisch op + [ [ 5-2*sqrt x :==: 1 + , 7-3*sqrt x :==: 5 + , 4-2*sqrt x :==: -3 + , 6-3*sqrt x :==: 2 + ] + , [ 2*sqrt x :==: x + , 2*sqrt x :==: 3*x + , x-3*sqrt x :==: 0 + , 3*x-5*sqrt x :==: 0 + ] + , [ x :==: sqrt (2*x+3) + , x :==: sqrt (3*x+10) + , x :==: sqrt (4*x+21) + , x :==: sqrt (3*x+4) + ] + , [ 5*x :==: sqrt (50*x+75) + , 2*x :==: sqrt (24*x+28) + , 3*x :==: sqrt (27*x-18) + , 2*x :==: sqrt (28*x-40) + , 3*x :==: sqrt (3*x+42) + , 5*x :==: sqrt (49*x+2) + , 3*x :==: sqrt (10*x-1) + , 5*x :==: sqrt (30*x-5) + ] + , [ x-sqrt x :==: 6 + , x-4*sqrt x :==: 12 + , x-sqrt x :==: 12 + , x-sqrt x :==: 2 + , 2*x+sqrt x :==: 3 + , 3*x+4*sqrt x :==: 20 + , 2*x+sqrt x :==: 15 + , 2*x-3*sqrt x :==: 27 + ] + ] + +-- Hoofdstuk 1, wortelvergelijkingen +rootSubstEquations :: [[Equation Expr]] +rootSubstEquations = + let x = Var "x" in + -- los algebraisch op + [ [ 8*x^3+1 :==: 9*x*sqrt x + , 27*x^3 :==: 28*x*sqrt x-1 + , x^3+3 :==: 4*x*sqrt x + , x^3 :==: 10*x*sqrt x-16 + ] + , [ x^3 :==: 6*x*sqrt x+16 + , x^3-24*x*sqrt x :==: 81 + , x^3+x*sqrt x :==: 20 + , x^3-15 :==: 2*x*sqrt x + ] + , [ x^5+32 :==: 33*x^2*sqrt x + , 243*x^5-244*x^2*sqrt x+1 :==: 0 + , 32*x^5+31*x^2*sqrt x :==: 1 + , x^5 :==: 242*x^2*sqrt x+243 + ] + , [ x^5+8 :==: 6*x^2*sqrt x + , x^5 :==: 9*x^2*sqrt x-18 + , x^5 :==: 5*x^2*sqrt x+24 + , x^5+4*x^2*sqrt x :==:12 + ] + ] + +-- Hoofdstuk 1, gebroken vergelijkingen +brokenEquations :: [[Equation Expr]] +brokenEquations = + -- Bereken exact de oplossingen + let x = Var "x" in + [ [ (2*x^2-10) / (x^2+3) :==: 0 + , (7*x^2-21) / (2*x^2-5) :==: 0 + , (3*x^2-6) / (4*x^2+1) :==: 0 + , (4*x^2-24) / (6*x^2-2) :==: 0 + , x^2 / (x+4) :==: (3*x+4) / (x+4) + , (x^2+2) / (x-2) :==: (x+8) / (x-2) + , (x^2+6*x-6)/(x^2-1) :==: (4*x+9)/(x^2-1) + , (x^2+6)/(x^2-2) :==: (7*x)/(x^2-2) + ] + , [ (x^2+6*x)/(x^2-1) :==: (3*x+4)/(x^2-1) + , (x^2+6)/(x-3) :==: (5*x)/(x-3) + , (x^2+4*x)/(x^2-4) :==: (3*x + 6)/(x^2-4) + , (x^2+2*x-4)/(x-5) :==: (4*x+11)/(x-5) + , (5*x+2)/(2*x-1) :==: (5*x+2)/(3*x+5) + , (x^2-9)/(4*x-1) :==: (x^2-9)/(2*x+7) + , (3*x-2)/(2*x^2) :==: (3*x-2)/(x^2+4) + , (2*x+1)/(x^2+3*x) :==: (2*x+1)/(5*x+8) + ] + , [ (x^2-1)/(2*x+2) :==: (x^2-1)/(x+8) + , (x^2-4)/(3*x-6) :==: (x^2-4)/(2*x+1) + , (x^2+5*x)/(2*x^2) :==: (x^2+5*x)/(x^2+4) + , (x^2-3*x)/(2*x-6) :==: (x^2-3*x)/(4*x+2) + , x/(x+1) :==: 1 + 3/4 + , (x+2)/(3*x) :==: 1 + 1/3 + , (2*x+3)/(x-1) :==: 3 + 1/2 + , (x-3)/(1-x) :==: 1 + 2/5 + ] + , [ (x+4)/(x+3) :==: (x+1)/(x+2) + , (2*x+3)/(x-1) :==: (2*x-1) / (x-2) + , (3*x+6)/(3*x-1) :==: (x+4)/(x+1) + , (x+2)/(2*x+5) :==: (x+4)/(2*x-3) + , (x+5)/(2*x) + 2 :==: 5 + , (3*x+4)/(x+2) - 3 :==: 2 + , (x^2)/(5*x+6) + 4 :==: 5 + , (x^2)/(2*x-3) + 3 :==: 7 + ] + , [ (x-2)/(x-3) :==: x/2 + , (x+9)/(x-5) :==: 2/x + , (x+2)/(x+4) :==: 2/(x+1) + , (-3)/(x-5) :==: (x+3)/(x+1) + , (x+1)/(x+2) :==: (7*x+1)/(2*x-4) + , (2*x-7)/(5-x) :==: (x+1)/(3*x-7) + , (x+1)/(x-1) :==: (3*x-7)/(x-2) + , (3*x-7)/(x-2) :==: (7-x)/(3*x-3) + ] + ] + +-- Hoofdstuk 4, gebroken vorm herleiden (1 en 1a) +normBroken :: [[Expr]] +normBroken = + -- Herleid + let x = Var "x" in + let y = Var "y" in + let a = Var "a" in + let b = Var "b" in + [ [ 7/(2*x) + 3/(5*x), 3/(2*x) + 2/(3*x), 4/(5*x)-2/(3*x) + , 2/(7*x) - 1/(4*x), 5/(6*a)+3/(7*a), 3/(8*a)+5/(3*a) + , 7/(2*a)-2/(3*a), 9/(5*a)-1/(2*a) + ] + , [ 1/x+1/y, 2/(3*x)+1/(2*y), 3/(x^2*y) - 5/(2*x*y), 2/(x*y)-7/(5*y) + , 2/a - 3/b, 4/(3*a)-2/(5*b), 2/(a*b)+4/(3*a), 7/(4*a)+3/(4*b) + ] + , [ 3+1/(2*x), 2*x+(3/(5*x)), 5/(2*x)-3, 3-5/(7*x), 5/(3*a)+1 + , 4*a+3/(2*a), 2*a-1/(3*a), 7/(5*a)-2 + ] + , [ 5/(x+2)+4/(x+3), 3/(x-1)+2/(x+3), 4/(x+5)+2/(x-3), 3/(x-2)+2/(x-3) + , 4/(x+3)-6/(x+2), 1/(x+5)-3/(x-4), 7/(x-3)-2/(x+1), 6/(x-1)-3/(x-2) + ] + , [ (x+1)/(x+2)+(x+2)/(x-3), (x-2)/(x+3)+(x-1)/(x+2), (x+3)/(x-1)+(x+2)/(x-4) + , (x-4)/(x+5)+(x-2)/(x-3), (x-1)/(x+1)-(x+2)/(x-2), (x+5)/(x+3)-(x+3)/(x+5) + , (x-1)/(x+2)-(x+4)/(x+1), (x-3)/(x-1)-(x+2)/(x+4) + ] + , [ (2*x)/(x-1)+x/(x+2), (3*x)/(x-4)+(5*x)/(x-2) + , (4*x)/(x+2)-(2*x)/(x+1), x/(x+5)-(4*x)/(x+6) + ] + ] + +-- Hoofdstuk 4, gebroken vorm herleiden (2 en 2a) +normBroken2 :: [[Expr]] +normBroken2 = + -- Herleid + let x = Var "x" in + let a = Var "a" in + let p = Var "p" in + [ [ (x^2+4*x-5)/(x^2+5*x-6), (x^2+2*x-8)/(x^2+10*x+24) + , (x^2-7*x+12)/(x^2+x-20), (x^2+7*x+12)/(x^2+5*x+6) + , (a^2-a-2)/(a^2+4*a-12), (a^2-3*a-10)/(a^2-a-20) + , (a^2-2*a-15)/(a^2-3*a-18), (a^2+a-2)/(a^2+3*a+2) + ] + , [ (x^2-16)/(x^2+x-12), (x^2-2*x+1)/(x^2-1), (x^2-9)/(x^2+6*x+9) + , (x^2-7*x+6)/(x^2-1), (2*p^2+8*p)/(p^2-16), (-(p^2)+5*p)/(p^2-10*p+25) + , (p^2-4)/(4*p^2+8*p), (p^2-12*p+36)/(p^2-6*p) + ] + , [ (x^3+3*x^2+2*x)/(x^2+4*x+4), (x^3+10*x^2+24*x)/(x^2+7*x+6) + , (x^2+5*x+6)/(x^3-x^2-6*x), (x^2+3*x-4)/(x^3-6*x^2+5*x) + , (a^3+7*a^2+12*a)/(a^2+6*a+9), (a^3+7*a^2+10*a)/(a^2-a-6) + , (a^2-9)/(a^3-4*a^2+3*a), (a^2-2*a-15)/(a^3-3*a^2-10*a) + ] + ] + +deelUit :: [[Expr]] +deelUit = + let x = Var "x" in + let a = Var "a" in + let p = Var "p" in + let t = Var "t" in + [ -- laatste sommen van gebroken vorm herleiden (2), niveau 5 + [ (-6*a^2-1)/a, -2*p^2+3/(7*p), (7*t^2+4)/(-4*t), (9*x^2+8)/(8*x) + ] + , -- sommen (2a) + [ (-7*a^2-4*a-6)/(-6*a), (3*p^2+6*p-8)/p, (2*t^2-9*t-8)/(-2*t) + , (x^2+5*x+5)/(2*x), (5*a^3-4*a+2)/(9*a), (5*p^3-7*p^2+9)/(2*p) + , (-3*t^3+6*t-4)/(3*t), (4*x^3-3*x^2+4)/(7*x) + ] + ] + +-- Vervolg hoofdstuk 4, gebroken vorm herleiden (2 en 2a), vanaf niveau 4 +normBrokenCon :: [[Equation Expr]] +normBrokenCon = + -- Herleid + let a = Var "a" in + let p = Var "p" in + let t = Var "t" in + let ca = symbol (newSymbol "A") in + let ct = symbol (newSymbol "T") in + let cn = symbol (newSymbol "N") in + [ [ ca :==: (p^2+2*p)/(p^2-4), ca :==: (6*p^2-18*p)/(p^2-9) + , ca :==: (p^2-1)/(-2*p^2+2*p), ca :==: (p^2-16)/(4*p^2+16*p) + , ct :==: (t^3-2*t^2)/(t^2-4), ct :==: (t^3+4*t^2)/(t^2-16) + , ct :==: (t^2-1)/(t^3+t^2), ct :==: (t^2-25)/(t^3-5*t^2) + ] + , [ cn :==: (a^4+4*a^2-5)/(a^4-1), cn :==: (a^4+5*a^2+6)/(a^4+4*a^2+3) + , cn :==: (a^4-5*a^2+6)/(a^4-7*a^2+10), cn :==: (a^4-8*a^2+16)/(a^4-5*a^2+4) + ] + ] + +-- Hoofdstuk 5, exponentiele vergelijkingen exact oplossen (1, 2, 2a) +expEquations2 :: [[Equation Expr]] +expEquations2 = + let x = Var "x" in + -- los algebraisch op + -- 1 + [ [ 2^(2*x-1) :==: 1/16 + , 3^(1-x) :==: 81 + , 5^(1-2*x) :==: 1/5 + , (1/2)^(4*x-3) :==: 1/4 + , (1/3)^(5*x+2) :==: 1/3 + , 6^(3*x-2) :==: 1/216 + ] + , [ 2^(3*x+2) :==: 2*sqrt 2 + , 3^(2*x+1) :==: 9*sqrt 3 + , 5^(4*x+3) :==: 625*sqrt 5 + , (1/2)^(x+1) :==: 4 + , (1/3)^(x-3) :==: 3 + , 4^(x+2) :==: 64*root 4 3 + ] + , [ 2^(x+3) :==: (1/2)*root 2 3 + , 3^(4*x+1) :==: 27 + , 5^(-x+2) :==: 1/25 + , (1/2)^(1-x) :==: sqrt 2 + , (1/3)^(x+1) :==: (1/9)*sqrt 3 + , 2^(1-3*x) :==: (1/8)*sqrt 2 + ] + , [ 3*2^x+1 :==: 25 + , 4*3^x-9 :==: 27 + , 2*5^x+4 :==: 14 + , 5*(1/2)^x+11 :==: 51 + , 8*(1/3)^x+27 :==: 99 + , 3*(1/5)^x-35 :==: 40 + ] + , [ 2^(4*x+3) :==: 1 + , (1/2)^(2*x-1) :==: 1 + , 3^(2*x+4) :==: 1 + , (1/3)^(x-3) :==: 1 + , 4^(4*x-7) :==: 1 + , 5^(3*x-6) :==: 1 + ] + -- 2 + , [ 2^(2*x+1) :==: (1/2)^(x+2) + , 4^(2*x-1) :==: 2^(3*x+2) + , 2^(5*x-4) :==: 8^(x-3) + , (1/4)^(2*x+1) :==: 2^(6-2*x) + , (1/3)^(2*x-3) :==: 3^(4*x-3) + , 3^(3*x-2) :==: 9^(2-x) + , 27^(2*x+1) :==: 3^(2*x-5) + , 3^(5*x-1) :==: (1/9)^(2*x-1) + ] + , [ 6^(7*x-3) :==: 36^(2*x+3) + , (1/7)^(2*x-1) :==: 7^(2*x-7) + , 5^(5-2*x) :==: (1/5)^(x+2) + , 25^(4*x+1) :==: 5^(5*x-4) + , 3^(x^2) :==: (1/3)^(2*x) + , (1/2)^(x^2) :==: 2^(2*x) + , 5^(x^2) :==: 25^(3*x) + , 2^(x^2) :==: (1/8)^(-x) + ] + , [ (1/2)^(2-2*x) :==: 4^(3*x+5) + , 8^(x+1) :==: (1/2)^(x+7) + , (1/4)^(x+2) :==: 8^(2*x-1) + , 8^(2*x-3) :==: 16^(2*x+3) + , (1/3)^(x-2) :==: 9^(x+4) + , 9^(2*x-1) :==: 27^(2*x-1) + , (1/9)^(x+3) :==: 27^(2*x+2) + , 27^(3-2*x) :==: (1/3)^(4*x+3) + ] + , [ 4*2^x :==: 2^(3*x-2) + , 2^(5*x-9) :==: (1/8)*2^x + , 3^(4*x+6) :==: 27*3^x + , (1/9)*3^x :==: 3^(2-3*x) + , 3*3^x :==: (1/3)^(2*x+5) + , 4^(x+1) :==: 8*2^x + , (1/2)*2^x :==: (1/2)^x + , 9^(x+2) :==: (1/3)*3^x + ] + , [ (1/5)*5^(3*x-2) :==: 25^(x+1) + , 9*3^(2*x+1) :==: (1/3)^(4*x-3) + , 4^(3*x-5) :==: 8*2^(x+2) + , (1/2)^(3-2*x) :==: (1/4)*2^(3*x-4) + , 2^(x+2)+2^x :==: 40 + , 2^(x+4) :==: 3/4+2^(x+2) + , 2^(x-2)+2^(x+1) :==: 9 + , 2^(x+5)-2^(x+4) :==: 16 + ] + -- 2a + , [ 3^(x+2) :==: 72+3^x + , 3^(x-1)+3^(x+1) :==: 10 + , 3^(x+3)+3^(x+2) :==: 12 + , 3^x-3^(x-1) :==: 54 + ] + , [ 5^(x+1)+5^x :==: 150 + , 5^(x+1) :==: 100+5^x + , 5^(x+2)+5^x :==:1+1/25 + , 5^(x+1)+5^(x+2) :==: 30 + ] + , [ 2^(x+4)-2^(x-2) :==: 63*sqrt 2 + , 3^(x-1)+3^x :==: 12*sqrt 3 + , 5^x-5^(x-1) :==: 4*sqrt 5 + , 2^(x+2)+2^(x-3) :==: 66*sqrt 2 + ] + ] diff --git a/src/Domain/Math/Examples/DWO5.hs b/src/Domain/Math/Examples/DWO5.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Examples/DWO5.hs @@ -0,0 +1,167 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Examples.DWO5 + ( diffSet1, diffSet2, diffSet3, diffSet4 + , diffSet5, diffSet6, diffSet7, diffSet8 + ) where + +import Domain.Math.Expr +import Prelude hiding ((^)) +import Data.Maybe + +differentiateLists :: [[Expr]] -> [[Expr]] +differentiateLists = map (map differentiate) + +differentiate :: Expr -> Expr +differentiate a = + let x = fromMaybe "x" (selectVar a) + in unary diffSymbol $ binary lambdaSymbol (Var x) a + +---------------------------------------------------------- +-- HAVO B applets + +-- Hoofdstuk 6, differentieer +-- Bereken de afgeleide +diffSet1 :: [[Expr]] +diffSet1 = differentiateLists $ + let x = Var "x" in + let p = Var "p" in + let q = Var "q" in + let r = Var "r" in + [ [ 3*x^4 - 7*x^2, -x^3-5*x, 1/2*x^6-5*x^2+4, -1/3*x^3+(1+1/2)*x^2-x+1] + , [ -x^5+5*x+23, -2*p^4+5*p-12, 3/5*q^5-q^3+4*q, -2/3*r^6+1/4*r^4-3*r+7] + , -- werk eerst de haakjes weg + [ (x-2)^2, -(1-3*x)^2, (x-1)*(2*x+5), -(1-3*x)*(2*x+7)] + -- differentieer + , [x^3-x*(x+5), -2*(p+1)*(p-12), q*(q^5-q^3)+3*q^2+4, -3*r*(r-1)*(r+2)] + ] + +---------------------------------------------------------- +-- VWO A/C applets + +-- Hoofdstuk 7, differentieer +diffSet2 :: [[Expr]] +diffSet2 = differentiateLists $ + let x = Var "x" in + [ [ 5*x^2, -4*x^2, 10*x^2-8, -8*x^2+7] + , [ 3*x^2+4*x, -0.5*x^2-2*x, -8*x^2+7*x-3, -0.25*x^2+x-1] + , [ (x+2)^2, (5*x+7)*(4-3*x), (3*x+6)^2-8*x + , 5*(x-3)^2+5*x, 5*(x-3)^2+5*(2*x-1), -3*(x-1)*(5-9*x)-8*(x-7) ] + ] + +-- Hoofdstuk 7, bereken de afgeleide: zelfde als Havo B applet + +---------------------------------------------------------- +-- VWO B applets + +-- Hoofdstuk 3, differentieren: zelfde als Havo B applet + +-- Hoofdstuk 7 +-- Gebruik de productregel +diffSet3 :: [[Expr]] +diffSet3 = differentiateLists $ + let x = Var "x" in + [ [ (x^2+2*x)*(3*x+5), (2*x^2-3*x)*(4*x+1), (3*x^3+4*x)*(x^2-2) + , (4*x^3-x)*(3*x^2+7*x), (x^2+2*x)*(x^3-4*x^2+3), (5*x-7)*(2*x^3-3*x+1) + , (3*x^2+2)*(5*x^3+4*x^2-7*x), (4*x+1)*(3*x^3-x^2+2*x) + ] + , [ (3*x+1)^2, (5*x-2)^2, (2*x+7)^2, (4*x-3)^2 + , (2*x^2-3*x)^2, (3*x^2+2)^2, 2*x^3-3*x^2, (5*x^3+7*x)^2 + ] + ] + +-- Gebruik de quotientregel +diffSet4 :: [[Expr]] +diffSet4 = differentiateLists $ + let x = Var "x" in + [ [ 5/(x-1), 3/(x+2), (-2)/(x-3), (-3)/(x+4), 3/(2*x-1) + , 2/(3*x+4), (-4)/(3*x-1), (-2)/(4*x+3) + ] + , [ (x+1)/(x-2), (x-3)/(x+4), (x+5)/(x-1), (x-2)/(x+1) + , (2*x+3)/(4*x-1), (3*x-1)/(2*x+1), (4*x+3)/(3*x-2), (5*x-2)/(3*x+4) + ] + , [ (3*x^2)/(2*x^3+4), (2*x^3)/(3*x^2-1), (x^2)/(4*x^3-2) + , (3*x^3)/(5*x^2+7), (1-x^3)/(x+4), (x+3)/(2-x^2) + , (1-2*x^3)/(x+1), (x+5)/(2-3*x^2) + ] + , [ (2-x)/(x^2+1)+2*x^3, (x^3-3)/(4-x)+x^2 + , (3-2*x)/(2*x^2-3)+x^3, (2*x^3-4)/(6-5*x)+4*x^2 + ] + ] + +-- differentieer x^n (n geheel), noteer zonder negatieve exponent +diffSet5 :: [[Expr]] +diffSet5 = differentiateLists $ + let x = Var "x" in + [ [ 4/x^2, 5/x^3, 2/x^4, 3/x^5, 1/9*x^2, 1/7*x^3, 1/5*x^4, 1/8*x^5 ] + , [ 3*x^2-4/(x^2), 7*x^3-2/(x^3), 2*x^4-5/(x^4), 2*x^5-6/(x^5) + , (3*x+2)/(x^3), (2*x^2-4)/x^5, (4*x-3)/x^2, (6*x^2+5)/x^4 + ] + , -- herleid de afgeleide tot 1 breuk + [ (2*x^4+3)/x^2, (2*x^5-5)/x^3, (4*x^5-1)/x^2, (4*x^4+3)/x^3 + , (3*x-1)/(7*x^2), (2*x^3+1)/(3*x^4), (x^2-2)/(3*x^3), (x+5)/(6*x^3) + ] + ] + +-- differentieer x^r (r uit R), noteer zonder negatieve en gebroken exponent +diffSet6 :: [[Expr]] +diffSet6 = differentiateLists $ + let x = Var "x" in + [ [ x*root x 3, x^3*sqrt x, x*root x 5, x^4*sqrt x, 1/(x*root x 3) + , 1/(x^3*sqrt x), 1/(x*root x 5), 1/(x^4*sqrt x) + ] + , [ x^2*root (x^2) 3, x*root (x^3) 4, x^3*root (x^2) 5, x^2*root (x^3) 5 + , (x^3+1)*(2+sqrt x), (3+x^2)*(1+root x 3), (x^2+1)*(root x 3+2) + , (3+x^3)*(sqrt x+1) + ] + , [ (sqrt x + 1)^2, (x*sqrt x-3)^2, (sqrt x-2)^2, (x*sqrt x+1)^2 + , (x+2)/sqrt x, (x-3)/sqrt x, (x-4)/sqrt x, (x+5)/sqrt x + ] + , [ (x-2)/(x*sqrt x), (x+3)/(x*sqrt x), (x+4)/(x*sqrt x), (x-5)/(x*sqrt x) + , (x^2+2)/(3*sqrt x), (x^2-3)/(4*sqrt x) + , (x^2+4)/(2*sqrt x), (x^2-6)/(3*sqrt x) + ] + , [ (x+3)/(x^2*sqrt x), (x-1)/(x^3*sqrt x), (x-2)/(x^2*sqrt x) + , (x+4)/(x^3*sqrt x), (sqrt x-2)/x^2, (2*sqrt x+1)/x^2 + , (1-sqrt x)/x, (3*sqrt x+2)/x + ] + ] + +-- differentieren met de kettingregel +diffSet7 :: [[Expr]] +diffSet7 = differentiateLists $ + let x = Var "x" in + [ [ 2*(x^2+3*x)^5, 3*(x^3-4*x)^6, -6*(x^2+2*x)^4, -5*(x^3-3*x^2)^3] + , [ -(2/(x^2+3*x)^5),-(3/(x^3-4*x)^6), 6/(x^2+2*x)^4, 5/(x^3-3*x^2)^3] + , [ sqrt (3*x^4-x), sqrt (x^3+5*x^2), sqrt (6*x^2+x), sqrt (7*x^3-3*x^2)] + , [ 1/sqrt (3*x-2), 1/sqrt (8*x+5), 1/sqrt (3*x-4), 1/sqrt (5*x-2)] + , [ (2*x-1)^2*sqrt (2*x-1), (3*x^2+2)*sqrt (3*x^2+2) + , (3*x+5)^3*sqrt (3*x+5), (4*x^3-7)*sqrt (4*x^3-7) + ] + ] + +-- differentieren met de kettingregel gecombineerd +diffSet8 :: [[Expr]] +diffSet8 = differentiateLists $ + let x = Var "x" in + [ [ 2*x*sqrt (4*x+3), 3*x*sqrt (2*x-5), 4*x*sqrt (3*x+2), 2*x*sqrt (5*x-3)] + , [ x^2*(4*x^2-2)^3, x^3*(3*x-4)^3, x^4*(3*x^2+1)^5, x^5*(4*x+3)^4] + , [ (x+3)/sqrt (2*x-1), (x+7)/sqrt (4*x+3) + , (x-2)/sqrt (3*x+1), (x-7)/sqrt (5*x-4) + ] + , [ sqrt (2*x^2-1)/(x+3), sqrt (4*x^2+3)/(x+7) + , sqrt (3*x^2+1)/(x-2), sqrt (5*x^2-4)/(x-7) + ] + ] 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 @@ -10,15 +10,15 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Expr - ( module Domain.Math.Expr.Data + ( module Common.Rewriting.Term + , module Domain.Math.Expr.Data , module Domain.Math.Expr.Parser - , module Domain.Math.Expr.Symbolic , module Domain.Math.Expr.Symbols , module Domain.Math.Expr.Views ) where import Domain.Math.Expr.Data import Domain.Math.Expr.Parser -import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Expr.Views +import Common.Rewriting.Term hiding (Term(..)) 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,4 +1,4 @@ -{-# OPTIONS -XDeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -12,18 +12,18 @@ ----------------------------------------------------------------------------- module Domain.Math.Expr.Data where -import Data.Char (isAlphaNum) -import Data.Ratio -import Data.Typeable -import Test.QuickCheck -import Control.Monad +import Common.Rewriting import Common.Uniplate import Common.Utils (commaList) import Common.View -import Common.Rewriting hiding (operators) -import Domain.Math.Expr.Symbolic +import Control.Monad +import Data.Char (isAlphaNum) +import Data.Maybe +import Data.Ratio +import Data.Typeable +import Domain.Math.Data.Relation (relationSymbols) import Domain.Math.Expr.Symbols - +import Test.QuickCheck import qualified Common.Rewriting.Term as Term ----------------------------------------------------------------------- @@ -88,23 +88,17 @@ asinh = unary asinhSymbol atanh = unary atanhSymbol acosh = unary acoshSymbol - -instance Symbolic Expr where - variable = Var - - getVariable (Var s) = return s - getVariable _ = mzero - + +instance WithFunctions Expr where function s [a, b] | s == plusSymbol = a :+: b | s == timesSymbol = a :*: b | s == minusSymbol = a :-: b | s == divideSymbol = a :/: b - | s == rootSymbol && b == Nat 2 = Sqrt a + | isRootSymbol s && b == Nat 2 = Sqrt a function s [a] | s == negateSymbol = Negate a - function s as = - Sym s as + function s as = Sym s as getFunction expr = case expr of @@ -115,8 +109,13 @@ a :/: b -> return (divideSymbol, [a, b]) Sqrt a -> return (rootSymbol, [a, Nat 2]) Sym s as -> return (s, as) - _ -> mzero + _ -> fail "Expr.getFunction" +instance WithVars Expr where + variable = Var + getVariable (Var s) = return s + getVariable _ = fail "Expr.getVariable" + fromDouble :: Double -> Expr fromDouble d | d < 0 = negate (Number (abs d)) @@ -144,16 +143,16 @@ instance CoArbitrary Expr where coarbitrary expr = case expr of - a :+: b -> variant 0 . coarbitrary a . coarbitrary b - a :*: b -> variant 1 . coarbitrary a . coarbitrary b - a :-: b -> variant 2 . coarbitrary a . coarbitrary b - Negate a -> variant 3 . coarbitrary a - Nat n -> variant 4 . coarbitrary n - a :/: b -> variant 5 . coarbitrary a . coarbitrary b - Number d -> variant 6 . coarbitrary d - Sqrt a -> variant 7 . coarbitrary a - Var s -> variant 8 . coarbitrary s - Sym f xs -> variant 9 . coarbitrary (show f) . coarbitrary xs + a :+: b -> variant (0 :: Int) . coarbitrary a . coarbitrary b + a :*: b -> variant (1 :: Int) . coarbitrary a . coarbitrary b + a :-: b -> variant (2 :: Int) . coarbitrary a . coarbitrary b + Negate a -> variant (3 :: Int) . coarbitrary a + Nat n -> variant (4 :: Int) . coarbitrary n + a :/: b -> variant (5 :: Int) . coarbitrary a . coarbitrary b + Number d -> variant (6 :: Int) . coarbitrary d + Sqrt a -> variant (7 :: Int) . coarbitrary a + Var s -> variant (8 :: Int) . coarbitrary s + Sym f xs -> variant (9 :: Int) . coarbitrary (show f) . coarbitrary xs symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr symbolGenerator extras syms = f @@ -171,9 +170,9 @@ natGenerator = liftM (Nat . abs) arbitrary varGenerator :: [String] -> Gen Expr -varGenerator vars - | null vars = error "varGenerator: empty list" - | otherwise = oneof [ return (Var x) | x <- vars ] +varGenerator xs + | null xs = error "varGenerator: empty list" + | otherwise = oneof [ return (Var x) | x <- xs ] ----------------------------------------------------------------------- -- Pretty printer @@ -184,6 +183,7 @@ showExpr :: OperatorTable -> Expr -> String showExpr table = rec 0 where + rec :: Int -> Expr -> String rec _ (Nat n) = if n>=0 then show n else "(ERROR)" ++ show n rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d rec _ (Var s) @@ -191,28 +191,30 @@ | otherwise = "\"" ++ s ++ "\"" rec i expr = case getFunction expr of + Just (s1, [Sym s2 [Var x, a]]) | s1 == diffSymbol && s2 == lambdaSymbol -> + parIf (i>10000) $ "D(" ++ x ++ ") " ++ rec 10001 a -- To do: remove special case for sqrt - Just (s, [a, b]) | s == rootSymbol && b == Nat 2 -> + Just (s, [a, b]) | isRootSymbol s && b == Nat 2 -> parIf (i>10000) $ unwords ["sqrt", rec 10001 a] Just (s, xs) | s == listSymbol -> "[" ++ commaList (map (rec 0) xs) ++ "]" Just (s, as) -> case (lookup s symbolTable, as) of (Just (InfixLeft, n, op), [x, y]) -> - parIf (i>n) $ concat [rec n x, op, rec (n+1) y] + parIf (i>n) $ rec n x ++ op ++ rec (n+1) y (Just (InfixRight, n, op), [x, y]) -> - parIf (i>n) $ concat [rec (n+1) x, op, rec n y] + parIf (i>n) $ rec (n+1) x ++ op ++ rec n y (Just (InfixNon, n, op), [x, y]) -> - parIf (i>n) $ concat [rec (n+1) x, op, rec (n+1) y] + parIf (i>n) $ rec (n+1) x ++ op ++ rec (n+1) y (Just (PrefixNon, n, op), [x]) -> - parIf (i>=n) $ concat [op, rec (n+1) x] + parIf (i>=n) $ op ++ rec (n+1) x _ -> parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as) Nothing -> error "showExpr" showSymbol s - | s == rootSymbol = "root" + | isRootSymbol s = "root" | otherwise = show s symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ] @@ -220,16 +222,22 @@ parIf b = if b then par else id par s = "(" ++ s ++ ")" -instance ShallowEq Expr where - shallowEq (Nat a) (Nat b) = a == b - shallowEq (Var a) (Var b) = a == b - shallowEq (Number a) (Number b) = a == b - shallowEq expr1 expr2 = - case (getFunction expr1, getFunction expr2) of - (Just (s1, as), Just (s2, bs)) -> - s1 == s2 && length as == length bs - _ -> False +type OperatorTable = [(Associativity, [(Symbol, String)])] +data Associativity = InfixLeft | InfixRight | PrefixNon + | InfixNon + deriving (Show, Eq) + +operatorTable :: OperatorTable +operatorTable = + (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) : + [ (InfixLeft, [(plusSymbol, "+"), (minusSymbol, "-")]) -- 6 + , (PrefixNon, [(negateSymbol, "-")]) -- 6+ + , (InfixLeft, [(timesSymbol, "*"), (divideSymbol, "/")]) -- 7 + , (InfixRight, [(powerSymbol, "^")]) -- 8 + ] + + instance Rewrite Expr instance Different Expr where @@ -241,57 +249,30 @@ toTerm (Var v) = Term.Var v toTerm expr = case getFunction expr of - Just (s, xs) -> Term.makeConTerm s (map toTerm xs) + Just (s, xs) -> function s (map toTerm xs) Nothing -> error "IsTerm Expr" fromTerm (Term.Num n) = return (fromInteger n) fromTerm (Term.Float d) = return (Number d) fromTerm (Term.Var v) = return (Var v) fromTerm t = - case Term.getSpine t of - (Term.Con s, xs) -> do + case getFunction t of + Just (s, xs) -> do ys <- mapM fromTerm xs return (function s ys) _ -> fail "fromTerm" instance IsTerm a => IsTerm [a] where toTerm = function listSymbol . map toTerm - fromTerm a = isSymbol listSymbol a >>= mapM fromTerm + fromTerm a = do + xs <- isFunction listSymbol a + mapM fromTerm xs toExpr :: IsTerm a => a -> Expr -toExpr a = - case fromTerm (toTerm a) of - Just expr -> expr - Nothing -> error "Invalid term" +toExpr = fromJust . fromTerm . toTerm fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a fromExpr = fromTerm . toTerm exprView :: IsTerm a => View Expr a exprView = makeView fromExpr toExpr - ------------------------------------------------------------------------ --- AC Theory for expression -{- -exprACs :: Operators Expr -exprACs = [plusOperator, timesOperator] - -plusOperator, timesOperator :: Operator Expr -plusOperator = acOperator (+) isPlus -timesOperator = acOperator (*) isTimes - -collectPlus, collectTimes :: Expr -> [Expr] -collectPlus = collectWithOperator plusOperator -collectTimes = collectWithOperator timesOperator - -size :: Expr -> Int -size e = 1 + compos 0 (+) size e --} -collectVars :: Expr -> [String] -collectVars e = [ s | Var s <- universe e ] - -hasVars :: Expr -> Bool -hasVars = not . noVars - -noVars :: Expr -> Bool -noVars = null . collectVars 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 @@ -17,20 +17,20 @@ import Prelude hiding ((^)) import Text.Parsing -import Control.Monad +import Control.Monad.Error +import Common.Rewriting import Common.Transformation import qualified Domain.Logic.Formula as Logic import Domain.Logic.Formula (Logic) import Domain.Math.Data.Relation import Domain.Math.Expr.Data -import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Data.OrList import Test.QuickCheck (arbitrary) scannerExpr :: Scanner scannerExpr = defaultScanner - { keywords = ["sqrt", "root", "and", "or", "true", "false"] + { keywords = ["sqrt", "root", "log", "and", "or", "true", "false", "D"] , keywordOperators = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"] , operatorCharacters = "+-*/^.=<>~" , qualifiedIdentifiers = True @@ -67,9 +67,15 @@ -- To fix: sqrt expects exactly one argument <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt" <|> function rootSymbol <$ pKey "root" + <|> function logSymbol <$ pKey "log" + <|> makeDiff <$ pKey "D" + where + makeDiff [x,a] = unary diffSymbol (binary lambdaSymbol x a) + makeDiff _ = symbol bottomSymbol qualifiedSymb :: TokenParser ([Expr] -> Expr) -qualifiedSymb = (function . uncurry makeSymbol) <$> (pQVarid <|> pQConid) +qualifiedSymb = f <$> (pQVarid <|> pQConid) + where f (a, b) = function $ newSymbol (a, b) pEquations :: TokenParser a -> TokenParser (Equations a) pEquations = pLines True . pEquation @@ -101,7 +107,6 @@ pTerm = return <$> p <|> true <$ pKey "true" <|> false <$ pKey "false" - pSepList p q = (:) <$> p <*> pList (q *> p) pLogic :: TokenParser a -> TokenParser (Logic a) pLogic p = levelOr diff --git a/src/Domain/Math/Expr/Symbolic.hs b/src/Domain/Math/Expr/Symbolic.hs deleted file mode 100644 --- a/src/Domain/Math/Expr/Symbolic.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Expr.Symbolic - ( module Domain.Math.Expr.Symbolic, Symbol - ) where - -import Control.Monad -import Data.Maybe -import Common.Rewriting.Term -import qualified Text.OpenMath.Symbol as OM - -makeSymbol :: String -> String -> Symbol -makeSymbol = S . Just - -class IsSymbol a where - toSymbol :: a -> Symbol - fromSymbol :: Symbol -> a - -instance IsSymbol Symbol where - toSymbol = id - fromSymbol = id - -instance IsSymbol String where - toSymbol = S Nothing - fromSymbol (S (Just a) b) = a ++ "." ++ b - fromSymbol (S Nothing b) = b - -instance IsSymbol OM.Symbol where - toSymbol s = S (OM.dictionary s) (OM.symbolName s) - fromSymbol (S (Just a) b) = OM.makeSymbol a b - fromSymbol (S Nothing b) = OM.extraSymbol b - -stringToSymbol :: String -> Symbol -stringToSymbol s = - case break (=='.') s of - (xs, _:ys) -> S (Just xs) ys - _ -> S Nothing s - -------------------------------------------------------------------- --- Type class for symbolic representations - -class Symbolic a where - -- constructing - variable :: String -> a - symbol :: Symbol -> a - function :: Symbol -> [a] -> a - -- matching - getVariable :: MonadPlus m => a -> m String - getSymbol :: MonadPlus m => a -> m Symbol - getFunction :: MonadPlus m => a -> m (Symbol, [a]) - isSymbol :: MonadPlus m => Symbol -> a -> m [a] - -- default definition - symbol s = function s [] - getSymbol a = do - (t, as) <- getFunction a - guard (null as) - return t - isSymbol s a = do - (t, as) <- getFunction a - guard (s==t) - return as - -instance Symbolic Term where - variable = Var - symbol = Con - function = makeConTerm - getVariable = isVar - getSymbol = isCon - getFunction = getConSpine - -nullary :: (IsSymbol s, Symbolic a) => s -> a -nullary = symbol . toSymbol - -unary :: (IsSymbol s, Symbolic a) => s -> a -> a -unary f a = function (toSymbol f) [a] - -binary :: (IsSymbol s, Symbolic a) => s -> a -> a -> a -binary f a b = function (toSymbol f) [a, b] - -isConst :: (IsSymbol s, Symbolic a) => s -> a -> Bool -isConst s = maybe False null . isSymbol (toSymbol s) - -isVariable :: Symbolic a => a -> Bool -isVariable = isJust . getVariable - -isUnary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m a -isUnary s a = - case isSymbol (toSymbol s) a of - Just [x] -> return x - _ -> mzero - -isBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a) -isBinary s a = - case isSymbol (toSymbol s) a of - Just [x, y] -> return (x, y) - _ -> mzero - --- left-associative by default -isAssoBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a) -isAssoBinary s a = - case isSymbol (toSymbol s) a of - Just [x, y] -> return (x, y) - Just (x:xs) | length xs > 1 -> return (x, function (toSymbol s) xs) - _ -> mzero - -fromTermWith :: (MonadPlus m, IsSymbol s, IsTerm a) - => (s -> [a] -> m a) -> Term -> m a -fromTermWith f term = do - (s, xs) <- getFunction term - ys <- mapM fromTermM xs - f (fromSymbol s) ys 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 @@ -8,103 +8,131 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Exports relevant OpenMath symbols, converted to the --- Symbol data type from @Common.Rewriting@. +-- Exports relevant OpenMath symbols -- ----------------------------------------------------------------------------- -module Domain.Math.Expr.Symbols where +module Domain.Math.Expr.Symbols + ( openMathSymbol + -- OpenMath dictionary symbols + , plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol + , powerSymbol, negateSymbol, sinSymbol, cosSymbol, lnSymbol + , diffSymbol, piSymbol, lambdaSymbol, listSymbol + , absSymbol, signumSymbol, logSymbol, expSymbol, tanSymbol, asinSymbol + , atanSymbol, acosSymbol, sinhSymbol, tanhSymbol, coshSymbol, asinhSymbol + , atanhSymbol, acoshSymbol, bottomSymbol, fcompSymbol + -- Matching + , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot + , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol + , (^), root + ) where +import Common.Id +import Common.Rewriting import Control.Monad -import Domain.Math.Expr.Symbolic -import Domain.Math.Data.Relation (relationSymbols) +import Prelude hiding ((^)) +import qualified Text.OpenMath.Dictionary.Arith1 as OM +import qualified Text.OpenMath.Dictionary.Calculus1 as OM +import qualified Text.OpenMath.Dictionary.Fns1 as OM +import qualified Text.OpenMath.Dictionary.List1 as OM +import qualified Text.OpenMath.Dictionary.Nums1 as OM +import qualified Text.OpenMath.Dictionary.Transc1 as OM +import qualified Text.OpenMath.Symbol as OM --- OpenMath dictionaries -import qualified Text.OpenMath.Dictionary.Arith1 as Arith1 -import qualified Text.OpenMath.Dictionary.Calculus1 as Calculus1 -import qualified Text.OpenMath.Dictionary.Fns1 as Fns1 -import qualified Text.OpenMath.Dictionary.List1 as List1 -import qualified Text.OpenMath.Dictionary.Nums1 as Nums1 -import qualified Text.OpenMath.Dictionary.Transc1 as Transc1 +-- | Conversion function +openMathSymbol :: OM.Symbol -> Symbol +openMathSymbol s = newSymbol (OM.dictionary s # OM.symbolName s) ------------------------------------------------------------- --- Converted OpenMath symbols +-- Arith1 dictionary -plusSymbol, timesSymbol, minusSymbol, divideSymbol, - rootSymbol, powerSymbol, negateSymbol :: Symbol -plusSymbol = toSymbol Arith1.plusSymbol -timesSymbol = toSymbol Arith1.timesSymbol -minusSymbol = toSymbol Arith1.minusSymbol -divideSymbol = toSymbol Arith1.divideSymbol -rootSymbol = toSymbol Arith1.rootSymbol -powerSymbol = toSymbol Arith1.powerSymbol -negateSymbol = toSymbol Arith1.unaryMinusSymbol +plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol, + powerSymbol, negateSymbol, absSymbol :: Symbol + +plusSymbol = openMathSymbol OM.plusSymbol +timesSymbol = openMathSymbol OM.timesSymbol +minusSymbol = openMathSymbol OM.minusSymbol +divideSymbol = openMathSymbol OM.divideSymbol +rootSymbol = openMathSymbol OM.rootSymbol +powerSymbol = openMathSymbol OM.powerSymbol +negateSymbol = openMathSymbol OM.unaryMinusSymbol +absSymbol = openMathSymbol OM.absSymbol -sinSymbol, cosSymbol, lnSymbol :: Symbol -sinSymbol = toSymbol Transc1.sinSymbol -cosSymbol = toSymbol Transc1.cosSymbol -lnSymbol = toSymbol Transc1.lnSymbol +------------------------------------------------------------- +-- Transc1 dictionary -diffSymbol, piSymbol, lambdaSymbol, listSymbol :: Symbol -diffSymbol = toSymbol Calculus1.diffSymbol -piSymbol = toSymbol Nums1.piSymbol -lambdaSymbol = toSymbol Fns1.lambdaSymbol -listSymbol = toSymbol List1.listSymbol +logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol, + sinhSymbol, tanhSymbol, coshSymbol :: Symbol -------------------------------------------------------------- --- Operator fixities +logSymbol = openMathSymbol OM.logSymbol +sinSymbol = openMathSymbol OM.sinSymbol +cosSymbol = openMathSymbol OM.cosSymbol +lnSymbol = openMathSymbol OM.lnSymbol +expSymbol = openMathSymbol OM.expSymbol +tanSymbol = openMathSymbol OM.tanSymbol +sinhSymbol = openMathSymbol OM.sinhSymbol +tanhSymbol = openMathSymbol OM.tanhSymbol +coshSymbol = openMathSymbol OM.coshSymbol -type OperatorTable = [(Associativity, [(Symbol, String)])] +------------------------------------------------------------- +-- Other dictionaries -data Associativity = InfixLeft | InfixRight | PrefixNon - | InfixNon - deriving (Show, Eq) +diffSymbol, lambdaSymbol, listSymbol, piSymbol :: Symbol -operatorTable :: OperatorTable -operatorTable = - (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) : - [ (InfixLeft, [(plusSymbol, "+"), (minusSymbol, "-")]) -- 6 - , (PrefixNon, [(negateSymbol, "-")]) -- 6+ - , (InfixLeft, [(timesSymbol, "*"), (divideSymbol, "/")]) -- 7 - , (InfixRight, [(powerSymbol, "^")]) -- 8 - ] +diffSymbol = openMathSymbol OM.diffSymbol +lambdaSymbol = openMathSymbol OM.lambdaSymbol +listSymbol = openMathSymbol OM.listSymbol +piSymbol = openMathSymbol OM.piSymbol ------------------------------------------------------------- -- Extra math symbols -absSymbol = toSymbol "abs" -signumSymbol = toSymbol "signum" -logSymbol = toSymbol "log" -- in Haskell, logbase e = log -expSymbol = toSymbol "exp" -- exp 1 ~= 2.718 -tanSymbol = toSymbol "tan" -asinSymbol = toSymbol "asin" -atanSymbol = toSymbol "atan" -acosSymbol = toSymbol "acos" -sinhSymbol = toSymbol "sinh" -tanhSymbol = toSymbol "tanh" -coshSymbol = toSymbol "cosh" -asinhSymbol = toSymbol "asinh" -atanhSymbol = toSymbol "atanh" -acoshSymbol = toSymbol "acosh" -bottomSymbol = toSymbol "error" -fcompSymbol = toSymbol "compose" +signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol, + acoshSymbol, bottomSymbol, fcompSymbol :: Symbol +signumSymbol = newSymbol "signum" +asinSymbol = newSymbol "asin" +atanSymbol = newSymbol "atan" +acosSymbol = newSymbol "acos" +asinhSymbol = newSymbol "asinh" +atanhSymbol = newSymbol "atanh" +acoshSymbol = newSymbol "acosh" +bottomSymbol = newSymbol "error" +fcompSymbol = newSymbol "compose" + ------------------------------------------------------------- -- Some match functions -isPlus, isTimes, isMinus, isDivide :: - (Symbolic a, MonadPlus m) => a -> m (a, a) -isNegate :: (Symbolic a, MonadPlus m) => a -> m a +isPlus, isTimes, isMinus, isDivide, isPower, isRoot :: + (WithFunctions a, MonadPlus m) => a -> m (a, a) +isNegate :: (WithFunctions a, MonadPlus m) => a -> m a isPlus = isAssoBinary plusSymbol isTimes = isAssoBinary timesSymbol isMinus = isBinary minusSymbol isDivide = isBinary divideSymbol isNegate = isUnary negateSymbol +isPower = isBinary powerSymbol +isRoot = isBinary rootSymbol +isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol :: Symbol -> Bool + +isPowerSymbol = (== powerSymbol) +isRootSymbol = (== rootSymbol) +isLogSymbol = (== logSymbol) +isDivideSymbol = (== divideSymbol) + infixr 8 ^ -(^) :: Symbolic a => a -> a -> a +(^) :: WithFunctions a => a -> a -> a (^) = binary powerSymbol -root :: Symbolic a => a -> a -> a +root :: WithFunctions a => a -> a -> a root = binary rootSymbol + +-- left-associative +isAssoBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) +isAssoBinary s a = + case isFunction s a of + Just [x, y] -> return (x, y) + Just (x:xs) | length xs > 1 -> return (x, function s xs) + _ -> fail "isAssoBinary" 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 @@ -12,25 +12,34 @@ module Domain.Math.Expr.Views where import Prelude hiding (recip, (^)) +import Common.Rewriting import Common.View import Domain.Math.Expr.Data import Domain.Math.Expr.Symbols -import Data.List (nub) +import qualified Data.Set as S ------------------------------------------------------------ -- Smart constructors +infixr 8 .^. +infixl 7 .*., ./. +infixl 6 .-., .+. + (.+.) :: Expr -> Expr -> Expr -Nat 0 .+. b = b -a .+. Nat 0 = a -a .+. Negate b = a .-. b -a .+. b = a :+: b +Nat 0 .+. b = b +a .+. Nat 0 = a +a .+. Negate b = a .-. b +a .+. (b :+: c) = (a .+. b) .+. c +a .+. (b :-: c) = (a .+. b) .-. c +a .+. b = a :+: b (.-.) :: Expr -> Expr -> Expr -Nat 0 .-. b = neg b -a .-. Nat 0 = a -a .-. Negate b = a .+. b -a .-. b = a :-: b +Nat 0 .-. b = neg b +a .-. Nat 0 = a +a .-. Negate b = a .+. b +a .-. (b :+: c) = (a .-. b) .-. c +a .-. (b :-: c) = (a .-. b) .+. c +a .-. b = a :-: b neg :: Expr -> Expr neg (Nat 0) = 0 @@ -40,14 +49,15 @@ neg a = Negate a (.*.) :: Expr -> Expr -> Expr -Nat 0 .*. _ = Nat 0 -_ .*. Nat 0 = Nat 0 -Nat 1 .*. b = b -a .*. Nat 1 = a -Negate a .*. b = neg (a .*. b) -a .*. Negate b = neg (a .*. b) +Nat 0 .*. _ = Nat 0 +_ .*. Nat 0 = Nat 0 +Nat 1 .*. b = b +a .*. Nat 1 = a +Negate a .*. b = neg (a .*. b) +a .*. Negate b = neg (a .*. b) a .*. (Nat 1 :/: b) = a ./. b -a .*. b = a :*: b +a .*. (b :*: c) = (a .*. b) .*. c +a .*. b = a :*: b (./.) :: Expr -> Expr -> Expr a ./. Nat 1 = a @@ -129,32 +139,32 @@ simpleProductView :: View Expr (Bool, [Expr]) simpleProductView = makeView (Just . second ($ []) . f) g where - f (a :*: b) = f a &&& f b + f (a :*: b) = f a .&&. f b f (Negate a) = first not (f a) f e = (False, (e:)) - (n1, g1) &&& (n2, g2) = (n1 /= n2, g1 . g2) + (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2) g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) productView :: View Expr (Bool, [Expr]) productView = makeView (Just . second ($ []) . f False) g where - f r (a :*: b) = f r a &&& f r b + f r (a :*: b) = f r a .&&. f r b f r (a :/: b) = case a of -- two special cases (for efficiency) Nat 1 -> f (not r) b Negate (Nat 1) -> first not (f (not r) b) - _ -> f r a &&& f (not r) b + _ -> f r a .&&. f (not r) b f r (Negate a) = first not (f r a) f r e = (False, if r then (recip e:) else (e:)) - (n1, g1) &&& (n2, g2) = (n1 /= n2, g1 . g2) + (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2) g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) -- helper to determine the name of the variable (move to a different module?) selectVar :: Expr -> Maybe String -selectVar = f . nub . collectVars +selectVar = f . S.toList . varSet where f [] = Just "x" -- exceptional case (e.g., for constants) f [a] = Just a 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 @@ -27,42 +27,43 @@ ------------------------------------------------------------ -- Exercises -numericExercise :: LabeledStrategy Expr -> Exercise Expr +numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr numericExercise s = makeExercise { status = Alpha , parser = parseExpr , equivalence = viewEquivalent rationalView - , strategy = mapRules liftToContext s + , strategy = s + , navigation = termNavigator } naturalExercise :: Exercise Expr naturalExercise = (numericExercise naturalStrategy) - { description = "simplify expression (natural numbers)" - , exerciseCode = makeCode "math" "natural" + { exerciseId = describe "simplify expression (natural numbers)" $ + newId "numbers.natural" , isReady = (`belongsTo` integerNormalForm) , examples = concat calculateResults } integerExercise :: Exercise Expr integerExercise = (numericExercise integerStrategy) - { description = "simplify expression (integers)" - , exerciseCode = makeCode "math" "integer" + { exerciseId = describe "simplify expression (integers)" $ + newId "numbers.integers" , isReady = (`belongsTo` integerNormalForm) , examples = concat calculateResults } rationalExercise :: Exercise Expr rationalExercise = (numericExercise rationalStrategy) - { description = "simplify expression (rational numbers)" - , exerciseCode = makeCode "math" "rational" + { exerciseId = describe "simplify expression (rational numbers)" $ + newId "numbers.rational" , isReady = (`belongsTo` rationalNormalForm) , randomExercise = simpleGenerator (rationalGenerator 5) } fractionExercise :: Exercise Expr fractionExercise = (numericExercise fractionStrategy) - { description = "simplify expression (fractions)" - , exerciseCode = makeCode "math" "fraction" + { exerciseId = describe "simplify expression (fractions)" $ + newId "arithmetic.fractions" , isReady = (`belongsTo` rationalNormalForm) , randomExercise = simpleGenerator (rationalGenerator 5) } 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 @@ -16,91 +16,88 @@ , fracLaws, testFracLaws, testFracLawsWith ) where +import Common.TestSuite import Test.QuickCheck -testNumLaws :: Num a => String -> Gen a -> IO () +testNumLaws :: Num a => String -> Gen a -> TestSuite testNumLaws = testNumLawsWith (==) -testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> IO () -testNumLawsWith eq s g = do - putStrLn $ "Testing Num instance for " ++ s +testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> TestSuite +testNumLawsWith eq s g = suite ("Num instance for " ++ s) $ mapM_ ($ g) (numLaws eq) -testFracLaws :: Fractional a => String -> Gen a -> IO () +testFracLaws :: Fractional a => String -> Gen a -> TestSuite testFracLaws = testFracLawsWith (==) -testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> IO () -testFracLawsWith eq s g = do - putStrLn $ "Testing Fractional instance for " ++ s +testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> TestSuite +testFracLawsWith eq s g = suite ("Fractional instance for " ++ s) $ mapM_ ($ g) (fracLaws eq) -numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> IO ()] +numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> TestSuite] numLaws eq = - [ law1 "plus zero left" $ \a -> 0+a == a - , law1 "plus zero right" $ \a -> a+0 == a - , law2 "plus comm" $ \a b -> a+b == b+a - , law3 "plus trans" $ \a b c -> a+(b+c) == (a+b)+c - , law1 "negate zero" $ \a -> -0 == 0 `asTypeOf` a - , law1 "negate double" $ \a -> -(-a) == a - , law1 "minus zero left" $ \a -> 0-a == -a - , law1 "minus zero right" $ \a -> a-0 == a - , law2 "negate plus" $ \a b -> -(a+b) == -a-b - , law2 "negate minus" $ \a b -> -(a-b) == -a+b - , law2 "plus negate" $ \a b -> a+(-b) == a-b - , law1 "times zero left" $ \a -> 0*a == 0 - , law1 "times zero right" $ \a -> a*0 == 0 - , law1 "times one left" $ \a -> 1*a == a - , law1 "times one right" $ \a -> a*1 == a - , law2 "times comm" $ \a b -> a*b == b*a - , law3 "times trans" $ \a b c -> a*(b*c) == (a*b)*c - , law2 "times negate left" $ \a b -> (-a)*b == -(a*b) - , law2 "times negate right" $ \a b -> a*(-b) == -(a*b) - , law3 "times plus left" $ \a b c -> (a+b)*c == a*c + b*c - , law3 "times plus right" $ \a b c -> a*(b+c) == a*b + a*c - , law3 "times minus left" $ \a b c -> (a-b)*c == a*c - b*c - , law3 "times minus right" $ \a b c -> a*(b-c) == a*b - a*c + [ law1 "plus zero left" $ \a -> 0+a === a + , law1 "plus zero right" $ \a -> a+0 === a + , law2 "plus comm" $ \a b -> a+b === b+a + , law3 "plus trans" $ \a b c -> a+(b+c) === (a+b)+c + , law1 "negate zero" $ \a -> -0 === 0 `asTypeOf` a + , law1 "negate double" $ \a -> -(-a) === a + , law1 "minus zero left" $ \a -> 0-a === -a + , law1 "minus zero right" $ \a -> a-0 === a + , law2 "negate plus" $ \a b -> -(a+b) === -a-b + , law2 "negate minus" $ \a b -> -(a-b) === -a+b + , law2 "plus negate" $ \a b -> a+(-b) === a-b + , law1 "times zero left" $ \a -> 0*a === 0 + , law1 "times zero right" $ \a -> a*0 === 0 + , law1 "times one left" $ \a -> 1*a === a + , law1 "times one right" $ \a -> a*1 === a + , law2 "times comm" $ \a b -> a*b === b*a + , law3 "times trans" $ \a b c -> a*(b*c) === (a*b)*c + , law2 "times negate left" $ \a b -> (-a)*b === -(a*b) + , law2 "times negate right" $ \a b -> a*(-b) === -(a*b) + , law3 "times plus left" $ \a b c -> (a+b)*c === a*c + b*c + , law3 "times plus right" $ \a b c -> a*(b+c) === a*b + a*c + , law3 "times minus left" $ \a b c -> (a-b)*c === a*c - b*c + , law3 "times minus right" $ \a b c -> a*(b-c) === a*b - a*c ] where - infix 4 == - a == b = property (a `eq` b) + infix 4 === + a === b = property (a `eq` b) -fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> IO ()] +fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> TestSuite] fracLaws eq = - [ law3 "division numerator" $ \a b c -> (a/b)/c == a/(b*c) <| b/=0 && c/=0 - , law3 "division denominator" $ \a b c -> a/(b/c) == a*(c/b) <| b/=0 && c/=0 - , law1 "zero numerator" $ \a -> 0/a == 0 <| a/=0 - , law1 "one numerator" $ \a -> 1/a == recip a <| a/=0 - , law1 "one denominator" $ \a -> a/1 == a - , law1 "division is one" $ \a -> a/a == 1 <| a/=0 - , law1 "recip double" $ \a -> a == recip (recip a) <| a/=0 - , law3 "times division left" $ \a b c -> (a/b)*c == (a*c)/b <| b/=0 - , law3 "times division right" $ \a b c -> a*(b/c) == (a*b)/c <| c/=0 - , law3 "plus division left" $ \a b c -> (a/b)+c == (a+c*b)/b <| b/=0 - , law3 "plus division right" $ \a b c -> a+(b/c) == (a*c+b)/c <| c/=0 - , law3 "minus division left" $ \a b c -> (a/b)-c == (a-c*b)/b <| b/=0 - , law3 "minus division right" $ \a b c -> a-(b/c) == (a*c-b)/c <| c/=0 - , law2 "negate numerator" $ \a b -> a/(-b) == -(a/b) <| b/=0 - , law2 "negate denominator" $ \a b -> (-a)/b == -(a/b) <| b/=0 - , law2 "recip times" $ \a b -> recip (a*b) == recip a*recip b <| a/=0 && b/=0 - , law2 "recip division" $ \a b -> recip (a/b) == b/a <| a/=0 && b/=0 + [ law3 "division numerator" $ \a b c -> (a/b)/c === a/(b*c) <| b/=0 && c/=0 + , law3 "division denominator" $ \a b c -> a/(b/c) === a*(c/b) <| b/=0 && c/=0 + , law1 "zero numerator" $ \a -> 0/a === 0 <| a/=0 + , law1 "one numerator" $ \a -> 1/a === recip a <| a/=0 + , law1 "one denominator" $ \a -> a/1 === a + , law1 "division is one" $ \a -> a/a === 1 <| a/=0 + , law1 "recip double" $ \a -> a === recip (recip a) <| a/=0 + , law3 "times division left" $ \a b c -> (a/b)*c === (a*c)/b <| b/=0 + , law3 "times division right" $ \a b c -> a*(b/c) === (a*b)/c <| c/=0 + , law3 "plus division left" $ \a b c -> (a/b)+c === (a+c*b)/b <| b/=0 + , law3 "plus division right" $ \a b c -> a+(b/c) === (a*c+b)/c <| c/=0 + , law3 "minus division left" $ \a b c -> (a/b)-c === (a-c*b)/b <| b/=0 + , law3 "minus division right" $ \a b c -> a-(b/c) === (a*c-b)/c <| c/=0 + , law2 "negate numerator" $ \a b -> a/(-b) === -(a/b) <| b/=0 + , law2 "negate denominator" $ \a b -> (-a)/b === -(a/b) <| b/=0 + , law2 "recip times" $ \a b -> recip (a*b) === recip a*recip b <| a/=0 && b/=0 + , law2 "recip division" $ \a b -> recip (a/b) === b/a <| a/=0 && b/=0 ] where - infix 4 == - a == b = property (a `eq` b) + infix 4 === + a === b = property (a `eq` b) infix 1 <| p <| b = b ==> p -- local helper-functions -report :: String -> Property -> IO () -report s p = putStr (take 30 ("- " ++ s ++ repeat ' ')) >> quickCheck p - -law1 :: Show a => String -> (a -> Property) -> Gen a -> IO () -law1 s p g = report s (make g id p) +law1 :: Show a => String -> (a -> Property) -> Gen a -> TestSuite +law1 s p g = addProperty s (make g id p) -law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> IO () -law2 s p g = report s (make g (make g id) p) +law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> TestSuite +law2 s p g = addProperty s (make g (make g id) p) -law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> IO () -law3 s p g = report s (make g (make g (make g id)) p) +law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> TestSuite +law3 s p g = addProperty s (make g (make g (make g id)) p) +make :: Show a => Gen a -> (b -> Property) -> (a -> b) -> Property make g c p = forAll g (c . p) 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 @@ -20,9 +20,12 @@ ------------------------------------------------------------ -- Rules +alg :: String +alg = "algebra.manipulation" + calcRuleName :: String -> String -> String calcRuleName opName viewName = - "calculate " ++ opName ++ " [" ++ viewName ++ "]" + "arithmetic.operation." ++ viewName ++ "." ++ opName calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e calcBinRule opName op m viewName v = @@ -52,87 +55,87 @@ return (build v d) negateZero :: Rule Expr -negateZero = makeSimpleRule "negate zero" f +negateZero = makeSimpleRule (alg, "negate-zero") f where f (Negate (Nat n)) | n == 0 = Just 0 f _ = Nothing doubleNegate :: Rule Expr -doubleNegate = makeSimpleRule "double negate" f +doubleNegate = makeSimpleRule (alg, "double-negate") f where f (Negate (Negate a)) = Just a f _ = Nothing plusNegateLeft :: Rule Expr -plusNegateLeft = makeSimpleRule "plus negate left" f +plusNegateLeft = makeSimpleRule (alg, "plus-negate-left") f where f (Negate a :+: b) = Just (b :-: a) f _ = Nothing plusNegateRight :: Rule Expr -plusNegateRight = makeSimpleRule "plus negate right" f +plusNegateRight = makeSimpleRule (alg, "plus-negate-right") f where f (a :+: Negate b) = Just (a :-: b) f _ = Nothing minusNegateLeft :: Rule Expr -minusNegateLeft = makeSimpleRule "minus negate left" f +minusNegateLeft = makeSimpleRule (alg, "minus-negate-left") f where f (Negate a :-: b) = Just (Negate (a :+: b)) f _ = Nothing minusNegateRight :: Rule Expr -minusNegateRight = makeSimpleRule "minus negate right" f +minusNegateRight = makeSimpleRule (alg, "minus-negate-right") f where f (a :-: Negate b) = Just (a :+: b) f _ = Nothing timesNegateLeft :: Rule Expr -timesNegateLeft = makeSimpleRule "times negate left" f +timesNegateLeft = makeSimpleRule (alg, "times-negate-left") f where f (Negate a :*: b) = Just (Negate (a :*: b)) f _ = Nothing timesNegateRight :: Rule Expr -timesNegateRight = makeSimpleRule "times negate right" f +timesNegateRight = makeSimpleRule (alg, "times-negate-right") f where f (a :*: Negate b) = Just (Negate (a :*: b)) f _ = Nothing divisionNegateLeft :: Rule Expr -divisionNegateLeft = makeSimpleRule "division negate left" f +divisionNegateLeft = makeSimpleRule (alg, "division-negate-left") f where f (Negate a :/: b) = Just (Negate (a :/: b)) f _ = Nothing divisionNegateRight :: Rule Expr -divisionNegateRight = makeSimpleRule "division negate right" f +divisionNegateRight = makeSimpleRule (alg, "division-negate-right") f where f (a :/: Negate b) = Just (Negate (a :/: b)) f _ = Nothing divisionNumerator :: Rule Expr -divisionNumerator = makeSimpleRule "division numerator" f +divisionNumerator = makeSimpleRule (alg, "division-numerator") f where f ((a :/: b) :/: c) = Just (a :/: (b :*: c)) f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c))) f _ = Nothing divisionDenominator :: Rule Expr -divisionDenominator = makeSimpleRule "division denominator" f +divisionDenominator = makeSimpleRule (alg, "division-denominator") f where f (a :/: (b :/: c)) = Just ((a :*: c) :/: b) f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b)) f _ = Nothing simplerFraction :: Rule Expr -simplerFraction = makeSimpleRule "simpler fraction" $ \expr -> do +simplerFraction = makeSimpleRule (alg, "simpler-fraction") $ \expr -> do new <- canonical rationalRelaxedForm expr guard (expr /= new) return new fractionPlus :: Rule Expr -- also minus -fractionPlus = makeSimpleRule "fraction plus" $ \expr -> do +fractionPlus = makeSimpleRule (alg, "fraction-plus") $ \expr -> do (e1, e2) <- match plusView expr (a, b) <- match fractionForm e1 (c, d) <- match fractionForm e2 @@ -140,11 +143,11 @@ return (build fractionForm (a+c, b)) fractionPlusScale :: Rule Expr -- also minus -fractionPlusScale = makeSimpleRuleList "fraction plus scale" $ \expr -> do +fractionPlusScale = makeSimpleRuleList (alg, "fraction-plus-scale") $ \expr -> do (e1, e2) <- matchM plusView expr (a, b) <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1)) (c, d) <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2)) - guard (b /= 0 && d /= 0) + guard (b /= 0 && d /= 0 && b /= d) let bd = lcm b d e1n = build fractionForm (a * (bd `div` b), bd) e2n = build fractionForm (c * (bd `div` d), bd) @@ -152,7 +155,7 @@ build plusView (e1, e2n) | d /= bd ] fractionTimes :: Rule Expr -fractionTimes = makeSimpleRule "fraction times" f +fractionTimes = makeSimpleRule (alg, "fraction-times") f where f (e1 :*: e2) = do (a, b) <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1)) 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 @@ -12,109 +12,69 @@ module Domain.Math.Numeric.Strategies ( naturalStrategy, integerStrategy , rationalStrategy, fractionStrategy - , testAll ) where -import Common.Apply +import Common.Context import Common.Strategy -import Common.Transformation -import Common.Uniplate import Common.View import Domain.Math.Expr import Domain.Math.Numeric.Rules import Domain.Math.Numeric.Views -import Domain.Math.Numeric.Generators import Prelude hiding (repeat) -import Test.QuickCheck hiding (label) ------------------------------------------------------------ -- Strategies -naturalStrategy :: LabeledStrategy Expr -naturalStrategy = label "simplify" $ repeat $ alternatives $ map swRule - [ calcPlusWith "nat" natView - , calcMinusWith "nat" natView - , calcTimesWith "nat" natView - , calcDivisionWith "nat" natView - , doubleNegate - , negateZero - , plusNegateLeft - , plusNegateRight - , minusNegateLeft - , minusNegateRight - , timesNegateLeft - , timesNegateRight - , divisionNegateLeft - , divisionNegateRight - ] +naturalStrategy :: LabeledStrategy (Context Expr) +naturalStrategy = label "simplify" $ + repeat $ somewhere $ alternatives $ map use + [ calcPlusWith "natural" natView + , calcMinusWith "natural" natView + , calcTimesWith "natural" natView + , calcDivisionWith "natural" natView + , doubleNegate, negateZero, plusNegateLeft, plusNegateRight + , minusNegateLeft, minusNegateRight, timesNegateLeft + , timesNegateRight, divisionNegateLeft, divisionNegateRight + ] where natView = makeView f fromInteger where f (Nat n) = Just n f _ = Nothing -integerStrategy :: LabeledStrategy Expr -integerStrategy = label "simplify" $ repeat $ alternatives $ map swRule - [ calcPlusWith "int" integerNormalForm - , calcMinusWith "int" integerNormalForm - , calcTimesWith "int" integerNormalForm - , calcDivisionWith "int" integerNormalForm - , doubleNegate - , negateZero - ] - -rationalStrategy :: LabeledStrategy Expr -rationalStrategy = label "simplify" $ repeat $ alternatives $ map swRule - [ calcPlusWith "rational" rationalRelaxedForm - , calcMinusWith "rational" rationalRelaxedForm - , calcTimesWith "rational" rationalRelaxedForm - , calcDivisionWith "int" integerNormalForm - , doubleNegate - , negateZero - , divisionDenominator - , divisionNumerator - , simplerFraction - ] - -fractionStrategy :: LabeledStrategy Expr -fractionStrategy = label "simplify" $ repeat $ alternatives $ map swRule - [ fractionPlus, fractionPlusScale, fractionTimes - , calcPlusWith "int" integerNormalForm - , calcMinusWith "int" integerNormalForm - , calcTimesWith "int" integerNormalForm -- not needed? - , calcDivisionWith "int" integerNormalForm - , doubleNegate - , negateZero - , divisionDenominator - , divisionNumerator - , simplerFraction -- only apply when fractionPlusScale is not applicable - ] - -swRule :: Uniplate a => Rule a -> Rule a -swRule r = makeSimpleRuleList (name r) (somewhereM (applyAll r)) - ------------------------------------------------------------- --- Test code +integerStrategy :: LabeledStrategy (Context Expr) +integerStrategy = label "simplify" $ + repeat $ somewhere $ alternatives $ map use + [ calcPlusWith "integer" integerNormalForm + , calcMinusWith "integer" integerNormalForm + , calcTimesWith "integer" integerNormalForm + , calcDivisionWith "integer" integerNormalForm + , doubleNegate, negateZero + ] -testAll :: IO () -testAll = sequence_ [test1, test2, test3, test4] +rationalStrategy :: LabeledStrategy (Context Expr) +rationalStrategy = label "simplify" $ + repeat $ somewhere $ alternatives $ map use + [ calcPlusWith "rational" rationalRelaxedForm + , calcMinusWith "rational" rationalRelaxedForm + , calcTimesWith "rational" rationalRelaxedForm + , calcDivisionWith "integer" integerNormalForm + , doubleNegate, negateZero, divisionDenominator + , divisionNumerator, simplerFraction + ] -test1 = quickCheck $ forAll (sized integerGenerator) $ \e -> - Prelude.not (e `belongsTo` integerView) || - applyD naturalStrategy e `belongsTo` integerNormalForm - -test2 = quickCheck $ forAll (sized integerGenerator) $ \e -> - Prelude.not (e `belongsTo` integerView) || - applyD integerStrategy e `belongsTo` integerNormalForm - -test3 = quickCheck $ forAll (sized rationalGenerator) $ \e -> - Prelude.not (e `belongsTo` rationalView) || - applyD rationalStrategy e `belongsTo` rationalNormalForm - -test4 = quickCheck $ forAll (sized rationalGenerator) $ \e -> - Prelude.not (e `belongsTo` rationalView) || - applyD fractionStrategy e `belongsTo` rationalNormalForm - -{- testC = quickCheck $ forAll (sized rationalGenerator) $ \e -> - let a = cleanUp e - in a == cleanUp a -} +fractionStrategy :: LabeledStrategy (Context Expr) +fractionStrategy = label "simplify" $ + repeat $ + somewhere + ( use (calcPlusWith "integer" integerNormalForm) + <|> use (calcMinusWith "integer" integerNormalForm) + <|> use (calcTimesWith "integer" integerNormalForm) -- not needed? + -- <|> use (calcDivisionWith "integer" integerNormalForm) -- not needed? + ) |> + somewhere + ( use doubleNegate <|> use negateZero <|> use divisionDenominator + <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator + ) |> + somewhere (use fractionPlusScale) |> + somewhere (use simplerFraction) diff --git a/src/Domain/Math/Numeric/Tests.hs b/src/Domain/Math/Numeric/Tests.hs --- a/src/Domain/Math/Numeric/Tests.hs +++ b/src/Domain/Math/Numeric/Tests.hs @@ -11,59 +11,65 @@ ----------------------------------------------------------------------------- module Domain.Math.Numeric.Tests (main) where -import Common.Apply +import Common.Classes +import Common.Context +import Common.TestSuite import Common.View import Control.Monad +import Data.Maybe import Domain.Math.Expr import Domain.Math.Numeric.Generators import Domain.Math.Numeric.Strategies import Domain.Math.Numeric.Views import Test.QuickCheck -main :: IO () -main = do - putStrLn "** Correctness numeric views" - let f v = forM_ numGenerators $ \g -> do - quickCheck $ propIdempotence g v - quickCheck $ propSoundness semEqDouble g v - f integerView - f rationalView - f integerNormalForm - f rationalNormalForm - f rationalRelaxedForm - - putStrLn "** Normal forms" - let f v = forM_ numGenerators $ \g -> - quickCheck $ propNormalForm g v - f integerNormalForm +main :: TestSuite +main = suite "Numeric tests" $ do + + suite "Correctness numeric views" $ do + let f s v = forM_ numGenerators $ \g -> do + addProperty ("idempotence " ++ s) $ propIdempotence g v + addProperty ("soundness " ++ s) $ propSoundness semEqDouble g v + f "integer view" integerView + f "rational view" rationalView + f "integer normal form" integerNormalForm + f "rational normal form" rationalNormalForm + f "rational relaxed form" rationalRelaxedForm + + suite "Normal forms" $ do + let f s v = forM_ numGenerators $ \g -> + addProperty s $ propNormalForm g v + f "integer normal form" integerNormalForm -- f rationalNormalForm -- no longer a normal form - putStrLn "** Correctness generators" - let f g v = quickCheck $ forAll (sized g) (`belongsTo` v) - f integerGenerator integerView - f rationalGenerator rationalView - f ratioExprGen rationalNormalForm - f ratioExprGenNonZero rationalNormalForm - - putStrLn "** View relations" - let va .>. vb = forM_ numGenerators $ \g -> - quickCheck $ forAll g $ \a -> - not (a `belongsTo` va) || a `belongsTo` vb - integerNormalForm .>. integerView - rationalNormalForm .>. rationalRelaxedForm - rationalRelaxedForm .>. rationalView - integerNormalForm .>. rationalNormalForm - integerView .>. rationalView - - putStrLn "** Pre/post conditions strategies" - let f s pre post = forM_ numGenerators $ \g -> - quickCheck $ forAll g $ \a -> - not (a `belongsTo` pre) || applyD s a `belongsTo` post - f naturalStrategy integerView integerNormalForm - f integerStrategy integerView integerNormalForm - f rationalStrategy rationalView rationalNormalForm - f fractionStrategy rationalView rationalNormalForm - + suite "Correctness generators" $ do + let f s g v = addProperty s $ forAll (sized g) (`belongsTo` v) + f "integer" integerGenerator integerView + f "rational" rationalGenerator rationalView + f "ratio expr" ratioExprGen rationalNormalForm + f "ratio expr nonzero" ratioExprGenNonZero rationalNormalForm + + suite "View relations" $ do + let va .>. vb = forM_ numGenerators $ \g -> + addProperty "" $ forAll g $ \a -> + not (a `belongsTo` va) || a `belongsTo` vb + integerNormalForm .>. integerView + rationalNormalForm .>. rationalRelaxedForm + rationalRelaxedForm .>. rationalView + integerNormalForm .>. rationalNormalForm + integerView .>. rationalView + + suite "Pre/post conditions strategies" $ do + let f l s pre post = forM_ numGenerators $ \g -> + addProperty l $ forAll g $ \a -> + let run = fromMaybe a . fromContext . applyD s + . newContext emptyEnv . termNavigator + in not (a `belongsTo` pre) || run a `belongsTo` post + f "natural" naturalStrategy integerView integerNormalForm + f "integer" integerStrategy integerView integerNormalForm + f "rational" rationalStrategy rationalView rationalNormalForm + f "fraction" fractionStrategy rationalView rationalNormalForm + numGenerators :: [Gen Expr] numGenerators = map sized [ integerGenerator, rationalGenerator @@ -73,12 +79,11 @@ semEqDouble :: Expr -> Expr -> Bool semEqDouble a b = case (match doubleView a, match doubleView b) of - (Just a, Just b) -> a ~= b + (Just x, Just y) -> x ~= y (Nothing, Nothing) -> True _ -> False where delta = 0.0001 (~=) :: Double -> Double -> Bool - a ~= b | abs a < delta || abs b < delta = True - | otherwise = abs (1 - (a/b)) < delta + x ~= y = abs x < delta || abs y < delta || abs (1 - (x/y)) < delta 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 @@ -10,13 +10,14 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Numeric.Views - ( integralView, realView - , integerView, rationalView, doubleView, mixedFractionView + ( integralView, integerView + , rationalView, doubleView, mixedFractionView , integerNormalForm, rationalNormalForm, mixedFractionNormalForm , rationalRelaxedForm, fractionForm , intDiv, fracDiv, exprToNum ) where +import Common.Rewriting import Common.View import Control.Monad import Data.Ratio @@ -26,37 +27,34 @@ -- Numeric views integralView :: Integral a => View Expr a -integralView = makeView (exprToNum f) fromIntegral +integralView = newView "num.integer" (exprToNum f) fromIntegral where f s [x, y] - | s == divideSymbol = + | isDivideSymbol s = intDiv x y - | s == powerSymbol = do + | isPowerSymbol s = do guard (y >= 0) return (x Prelude.^ y) f _ _ = Nothing + +integerView :: View Expr Integer +integerView = integralView -realView :: RealFrac a => View Expr a -realView = makeView (exprToNum f) (fromRational . toRational) +rationalView :: View Expr Rational +rationalView = newView "num.rational" (exprToNum f) fromRational where f s [x, y] - | s == divideSymbol = + | isDivideSymbol s = fracDiv x y - | s == powerSymbol = do + | isPowerSymbol s = do let ry = toRational y guard (denominator ry == 1) let a = x Prelude.^ abs (numerator ry) return (if numerator ry < 0 then 1/a else a) f _ _ = Nothing -integerView :: View Expr Integer -integerView = integralView - -rationalView :: View Expr Rational -rationalView = makeView (match realView) fromRational - mixedFractionView :: View Expr Rational -mixedFractionView = makeView (match realView) mix +mixedFractionView = newView "num.mixed-fraction" (match rationalView) mix where mix r = let (d, m) = abs (numerator r) `divMod` denominator r @@ -65,7 +63,7 @@ in sign (fromInteger d .+. rest) doubleView :: View Expr Double -doubleView = makeView rec Number +doubleView = newView "num.double" rec Number where rec expr = case expr of @@ -78,14 +76,14 @@ -- N or -N (where n is a natural number) integerNormalForm :: View Expr Integer -integerNormalForm = makeView (optionNegate f) fromInteger +integerNormalForm = newView "num.integer-nf" (optionNegate f) fromInteger where f (Nat n) = Just n f _ = Nothing -- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5) rationalNormalForm :: View Expr Rational -rationalNormalForm = makeView f fromRational +rationalNormalForm = newView "num.rational-nf" f fromRational where f (Nat a :/: Nat b) = simple a b f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b) @@ -98,7 +96,7 @@ | otherwise = Nothing mixedFractionNormalForm :: View Expr Rational -mixedFractionNormalForm = makeView f fromRational +mixedFractionNormalForm = newView "num.mixed-fraction-nf" f fromRational where f (Negate (Nat a) :-: (Nat b :/: Nat c)) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c) f (Negate (Nat a :+: (Nat b :/: Nat c))) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c) @@ -114,7 +112,7 @@ | otherwise = Nothing fractionForm :: View Expr (Integer, Integer) -fractionForm = makeView f (\(a, b) -> (fromInteger a :/: fromInteger b)) +fractionForm = newView "num.fraction-form" f (\(a, b) -> (fromInteger a :/: fromInteger b)) where f (Negate a) = liftM (first negate) (g a) f a = g a @@ -126,7 +124,7 @@ g _ = Nothing rationalRelaxedForm :: View Expr Rational -rationalRelaxedForm = makeView (optionNegate f) fromRational +rationalRelaxedForm = newView "num.rational-relaxed" (optionNegate f) fromRational where f (e1 :/: e2) = do a <- match integerNormalForm e1 @@ -145,9 +143,9 @@ doubleSym :: Symbol -> [Double] -> Maybe Double doubleSym s [x, y] - | s == divideSymbol = fracDiv x y - | s == powerSymbol = floatingPower x y - | s == rootSymbol && x >= 0 && y >= 1 = Just (x ** (1/y)) + | isDivideSymbol s = fracDiv x y + | isPowerSymbol s = floatingPower x y + | isRootSymbol s && x >= 0 && y >= 1 = Just (x ** (1/y)) doubleSym _ _ = Nothing -- General numeric interpretation function: constructors Sqrt and 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 @@ -8,37 +8,426 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Some buggy rules catching common misconceptions on the abc-formula +-- Some buggy rules catching common misconceptions (also on the abc-formula) -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.BuggyRules where +import Prelude hiding ((^)) +import Common.Id import Domain.Math.Expr import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Polynomial.Views -import Domain.Math.Polynomial.Rules (abcFormula) +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.CleanUp import Domain.Math.Numeric.Views +import Domain.Math.Data.Polynomial +import Domain.Math.Equation.CoverUpRules +import Common.Classes +import Common.Context +import Common.Rewriting import Common.View -import Common.Transformation -import Common.Traversable +import Common.Transformation (Rule, buggyRule, siblingOf, Transformation, useRecognizer, supply1, makeTransList) import Control.Monad +import qualified Common.Transformation as Rule -abcBuggyRules :: [Rule (OrList (Equation Expr))] -abcBuggyRules = map f [ minusB, twoA, minus4AC, oneSolution ] +makeRule :: IsId n => n -> Transformation a -> Rule a +makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a +makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a +ruleList :: (RuleBuilder f a, Rewrite a, IsId n) => n -> [f] -> Rule a + +makeRule = buggyName Rule.makeRule +makeSimpleRule = buggyName Rule.makeSimpleRule +makeSimpleRuleList = buggyName Rule.makeSimpleRuleList +ruleList = buggyName Rule.ruleList + +buggyName :: IsId n => (Id -> a) -> n -> a +buggyName f s = f ("algebra.equations.buggy" # s) + +buggyRulesExpr :: [Rule Expr] +buggyRulesExpr = + map (siblingOf distributeTimes) + [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign + , buggyDistrTimesTooMany, buggyDistrTimesDenom + ] ++ + [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined + ] + +buggyRulesEquation :: [Rule (Equation Expr)] +buggyRulesEquation = + [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide + , buggyNegateAll + , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus + , buggyMultiplyOneSide, buggyMultiplyForgetOne + ] + +buggyPlus :: Rule (Equation Expr) +buggyPlus = describe "Moving a term from the left-hand side to the \ + \right-hand side (or the other way around), but forgetting to change \ + \the sign." $ + buggyRule $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do + (a, b) <- matchM plusView lhs + [ a :==: rhs + b, b :==: rhs + a ] + `mplus` do + (a, b) <- matchM plusView rhs + [ lhs + a :==: b, lhs + b :==: a ] + +buggyNegateOneSide :: Rule (Equation Expr) +buggyNegateOneSide = describe "Negate terms on one side only." $ + buggyRule $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) -> + [ -lhs :==: rhs, lhs :==: -rhs ] + +buggyFlipNegateOneSide :: Rule (Equation Expr) +buggyFlipNegateOneSide = describe "Negate terms on one side only." $ + buggyRule $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) -> + [ -rhs :==: lhs, rhs :==: -lhs ] + +buggyNegateAll :: Rule (Equation Expr) +buggyNegateAll = describe "Negating all terms (on both sides of the equation, \ + \but forgetting one term." $ + buggyRule $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys) + makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys) + makeEq as bs = build sumView as :==: build sumView bs + f i j = if i==j then id else negate + len as = let n = length as in if n < 2 then -1 else n + map makeL [0 .. len xs] ++ map makeR [0 .. len ys] + +buggyDivNegate :: Rule (Equation Expr) +buggyDivNegate = describe "Dividing, but wrong sign." $ + buggyRule $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do + (a, b) <- matchM timesView lhs + [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ] + `mplus` do + (a, b) <- matchM timesView rhs + [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ] + +buggyDivNumDenom :: Rule (Equation Expr) +buggyDivNumDenom = describe "Dividing both sides, but swapping \ + \numerator/denominator." $ + buggyRule $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do + (a, b) <- matchM timesView lhs + [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ] + `mplus` do + (a, b) <- matchM timesView rhs + [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ] + +buggyDistrTimes :: Rule Expr +buggyDistrTimes = describe "Incorrect distribution of times over plus: one \ + \term is not multiplied." $ + buggyRule $ makeSimpleRuleList "distr-times-plus" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [ a*b+c, b+a*c ] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [ a*c+b, a+b*c ] + +buggyDistrTimesForget :: Rule Expr +buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \ + \one term is forgotten." $ + buggyRule $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b] where - f r = r { ruleSiblings = [name abcFormula] } + forget :: Expr -> [Expr] + forget expr = + case match productView expr of + Just (b, xs) | n > 1 -> + [ build productView (b, make i) | i <- [0..n-1] ] + where + make i = [ x | (j, x) <- zip [0..] xs, i/=j ] + n = length xs + _ -> [0] +buggyDistrTimesSign :: Rule Expr +buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \ + \changing sign of addition." $ + buggyRule $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [ a.*.b .-. a.*.c ] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [ a.*.c .-. b.*.c ] + +buggyDistrTimesTooMany :: Rule Expr +buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \ + \a*(b+c)+d, where 'a' is also multiplied to d." $ + buggyRule $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do + ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr + [cleanUpExpr $ a*b+a*c+a*d] + +buggyDistrTimesDenom :: Rule Expr +buggyDistrTimesDenom = describe "Incorrct distribution of times over plus: \ + \one of the terms is a fraction, and the outer expression is multiplied by \ + \the fraction's denominator." $ + buggyRule $ makeSimpleRuleList "distr-times-denom" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [(1/a)*b + a*c, a*b + (1/a)*c] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [a*(1/c) + b*c, a*c + b*(1/c)] + +buggyMinusMinus :: Rule Expr +buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \ + \change sign." $ + buggyRule $ makeSimpleRule "minus-minus" $ \expr -> + case expr of + a :-: (b :-: c) -> Just (a-b-c) + Negate (a :-: b) -> Just (a-b) + _ -> Nothing + +buggyCancelMinus :: Rule (Equation Expr) +buggyCancelMinus = describe "Cancel terms on both sides, but terms have \ + \different signs." $ + buggyRule $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys + , cleanUpExpr x == cleanUpExpr (-y) + , let f n as = build sumView $ take n as ++ drop (n+1) as + , let eq = f i xs :==: f j ys + ] + +buggyPriorityTimes :: Rule Expr +buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \ + \ignoring some parentheses." $ + buggyRule $ makeSimpleRuleList "priority-times" $ \expr -> do + (a, (b, c)) <- matchM (plusView >>> second timesView) expr + [(a+b)*c] + `mplus` do + ((a, b), c) <- matchM (plusView >>> first timesView) expr + [a*(b+c)] + +buggyMultiplyOneSide :: Rule (Equation Expr) +buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $ + buggyRule $ makeRule "multiply-one-side" $ + useRecognizer recognizeEq $ supply1 (const (Just 2)) multiplyOneSide + where + recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) = + let p r = r `notElem` [-1, 0, 1] && + any (myEq eq2) (applyAll (multiplyOneSide r) eq1) + in maybe False p (recognizeMultiplication a1 b1) + || maybe False p (recognizeMultiplication a2 b2) + +recognizeMultiplication :: Expr -> Expr -> Maybe Rational +recognizeMultiplication a b = do + (_, pa) <- match (polyViewWith rationalView) a + (_, pb) <- match (polyViewWith rationalView) b + let d = coefficient (degree pa) pa + guard (d /= 0) + return (coefficient (degree pb) pb / d) + +multiplyOneSide :: Rational -> Transformation (Equation Expr) +multiplyOneSide r = makeTransList $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + let f = map (*fromRational r) + [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)] + +buggyMultiplyForgetOne :: Rule (Equation Expr) +buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \ + \equation, but forget one." $ + buggyRule $ makeRule "multiply-forget-one" $ + useRecognizer recognizeEq $ supply1 (const (Just 2)) multiplyForgetOne + where + recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) = + let p r = r `notElem` [-1, 0, 1] && + any (myEq eq2) (applyAll (multiplyForgetOne r) eq1) + in maybe False p (recognizeMultiplication a1 b1) + || maybe False p (recognizeMultiplication a2 b2) + +multiplyForgetOne :: Rational -> Transformation (Equation Expr) +multiplyForgetOne r = makeTransList $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys) + makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys) + f as bs = build sumView as :==: build sumView bs + mul b = if b then (*fromRational r) else id + do guard (length xs > 1) + map makeL [0 .. length xs-1] + `mplus` do + guard (length ys > 1) + map makeR [0 .. length ys-1] + +-- Redundant function; should come from exercise +myEq :: Equation Expr -> Equation Expr -> Bool +myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr) + +--------------------------------------------------------- +-- Quadratic and Higher-Degree Polynomials + +buggyQuadratic :: IsTerm a => [Rule (Context a)] +buggyQuadratic = + map use + [ buggyCoverUpTimesMul, buggyCoverUpEvenPower + , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth + , buggyDivisionByVarZero + ] ++ + map use + [ buggyDistributionSquare, buggyDistributionSquareForget + , buggySquareMultiplication + ] ++ + map use + [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget + , buggyCoverUpSquareMinus + ] + +buggyCoverUpEvenPower :: Rule (Equation Expr) +buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \ + \the negative root" $ buggyRule $ siblingOf coverUpPower $ + makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) -> + make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs + where + make equals ab c = do + (a, b) <- isBinary powerSymbol ab + n <- matchM integerView b + guard (n > 0 && even n) + return (a `equals` root c (fromInteger n)) + +buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr)) +buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \ + \but there is some other operation to be done first. Example: x^2+1=9" $ + buggyRule $ siblingOf coverUpPower $ + makeSimpleRuleList "coverup.even-power-too-early" $ + oneDisjunct $ helperBuggyCUPower True + +buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr)) +buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \ + \but there is some other operation to be done first. Example: 9*x^2=81, \ + \ and rewriting this into x=9 or x=-9." $ + buggyRule $ siblingOf coverUpPower $ + makeSimpleRuleList "coverup.even-power-forget" $ + oneDisjunct $ helperBuggyCUPower False + +helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)] +helperBuggyCUPower mode (lhs :==: rhs) = + make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs + where + make equals ab c = do + (sym, xs) <- getFunction ab + (i, x) <- zip [0..] xs + (a, b) <- isBinary powerSymbol x + n <- matchM integerView b + guard (n > 0 && even n) + let opa | mode = function sym (take i xs ++ [a] ++ drop (i+1) xs) + | otherwise = a + rb = root c (fromInteger n) + return $ orList [opa `equals` rb, opa `equals` (-rb)] + +buggyCoverUpTimesMul :: Rule (Equation Expr) +buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \ + \dividing the right-hand side, multiplication is used." $ + buggyRule $ siblingOf coverUpTimes $ + makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do + guard (rhs /= 0) + (a, b) <- isTimes lhs + [a :==: rhs*b, b :==: rhs*a] + `mplus` do + guard (lhs /= 0) + (a, b) <- isTimes rhs + [lhs*a :==: b, lhs*b :==: a] + +buggyDistributionSquare :: Rule Expr +buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \ + \addition: forgetting the 2ab term" $ + buggyRule $ siblingOf distributionSquare $ + ruleList "distr-square" + [ \a b -> (a+b)^2 :~> a^2+b^2 + , \a b -> (a-b)^2 :~> a^2-b^2 + , \a b -> (a-b)^2 :~> a^2+b^2 + ] + +buggyDistributionSquareForget :: Rule Expr +buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \ + \addition: squaring only one term" $ + buggyRule $ siblingOf distributionSquare $ + ruleList "distr-square-forget" + [ \a b -> (a+b)^2 :~> a^2+b + , \a b -> (a+b)^2 :~> a+b^2 + , \a b -> (a-b)^2 :~> a^2-b + , \a b -> (a-b)^2 :~> a-b^2 + ] + +buggySquareMultiplication :: Rule Expr +buggySquareMultiplication = describe "Incorrect square of a term that involves \ + \a multiplication." $ buggyRule $ + ruleList "square-multiplication" + [ \a b -> (a*b)^2 :~> a*b^2 + , \a b -> (a*b)^2 :~> a^2*b + , \a b -> a*b^2 :~> (a*b)^2 + , \a b -> a^2*b :~> (a*b)^2 + ] + +buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr)) +buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \ + \on the right-hand side, resulting in an error in the signs" $ + buggyRule $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq -> + case eq of + Sym s [a, 2] :==: b | isPowerSymbol s -> + Just $ orList [a :==: sqrt b, a :==: sqrt (-b)] + _ -> Nothing + +buggyCoverUpTimesWithPlus :: Rule (Equation Expr) +buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \ + \addition on the other side. Only one of the terms is divided." $ + buggyRule $ makeSimpleRuleList "coverup.times-with-plus" $ + \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs + where + make equals ab cd = do + (a, b) <- isTimes ab + (c, d) <- isPlus cd + [ a `equals` (c/b+d), a `equals` (c+d/b), + b `equals` (c/a+d), b `equals` (c+d/a) ] + +buggyDivisionByVarBoth :: Rule (Equation Expr) +buggyDivisionByVarBoth = describe "Divide both sides by variable, without \ + \introducing the x=0 alternative." $ + buggyRule $ makeSimpleRule "division-by-var-both" $ + \(lhs :==: rhs) -> do + (s1, p1) <- match polyView lhs + (s2, p2) <- match polyView rhs + let n = lowestDegree p1 `min` lowestDegree p2 + guard (n > 0 && s1==s2) + let f p = build polyView (s1, raise (-n) p) + return (f p1 :==: f p2) + +buggyDivisionByVarZero :: Rule (Equation Expr) +buggyDivisionByVarZero = describe "Divide both sides by variable, without \ + \introducing the x=0 alternative." $ + buggyRule $ makeSimpleRuleList "division-by-var-zero" $ + \(lhs :==: rhs) -> do + guard (rhs == 0) + (s, p) <- matchM polyView lhs + let n = lowestDegree p + guard (n > 0) + -- Quick fix to do some trivial steps for a linear equation, so that + -- buggy rules are recognized. + let eq = build polyView (s, raise (-n) p) :==: 0 + eq : applyM coverUpPlus eq + +--------------------------------------------------------- +-- ABC formula misconceptions + +abcBuggyRules :: [Rule (OrList (Equation Expr))] +abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ] + abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)]) -> Transformation (OrList (Equation Expr)) abcMisconception f = makeTransList $ - onceJoinM $ \(lhs :==: rhs) -> do + oneDisjunct $ \(lhs :==: rhs) -> do guard (rhs == 0) (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs f x a b c minusB :: Rule (OrList (Equation Expr)) -minusB = buggyRule $ makeRule "abc misconception minus b" $ +minusB = buggyRule $ makeRule "abc.minus-b" $ abcMisconception $ \x a b c -> do let discr = sqrt (fromRational (b*b - 4 * a * c)) f (?) buggy = @@ -50,7 +439,7 @@ twoA :: Rule (OrList (Equation Expr)) -twoA = buggyRule $ makeRule "abc misconception two a" $ +twoA = buggyRule $ makeRule "abc.two-a" $ abcMisconception $ \x a b c -> do let discr = sqrt (fromRational (b*b - 4 * a * c)) f (?) buggy = @@ -61,7 +450,7 @@ orList [ f (+) True, f (-) False ]] minus4AC :: Rule (OrList (Equation Expr)) -minus4AC = buggyRule $ makeRule "abc misconception minus 4ac" $ +minus4AC = buggyRule $ makeRule "abc.minus-4ac" $ abcMisconception $ \x a b c -> do let discr (?) = sqrt (fromRational ((b*b) ? (4 * a * c))) f (?) buggy = @@ -72,7 +461,7 @@ orList [ f (+) True, f (-) False ]] oneSolution :: Rule (OrList (Equation Expr)) -oneSolution = buggyRule $ makeRule "abc misconception one solution" $ +oneSolution = buggyRule $ makeRule "abc.one-solution" $ abcMisconception $ \x a b c -> do let discr = sqrt (fromRational (b*b - 4 * a * c)) f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a) 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 @@ -10,23 +10,25 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.CleanUp - ( cleanUp, cleanUpRelation, cleanUpExpr, cleanUpExpr2 + ( cleanUpRelations, cleanUpRelation, cleanUpExpr , cleanUpSimple, collectLikeTerms - , normalizeSum, normalizeProduct + , acExpr, smart ) where +import Common.Utils (fixpoint) import Common.Uniplate import Common.View import Control.Monad import Data.List import Data.Maybe +import Data.Ord import Domain.Math.Data.OrList import Domain.Math.Data.Relation import Domain.Math.Data.SquareRoot (fromSquareRoot) import Domain.Math.Expr import Domain.Math.Numeric.Views -import Domain.Math.Power.Views -import Domain.Math.Simplification (smartConstructors) +import Domain.Math.Power.OldViews +import Domain.Math.Simplification hiding (simplify, simplifyWith) import Domain.Math.SquareRoot.Views import Prelude hiding ((^), recip) import qualified Prelude @@ -44,10 +46,10 @@ f x y | x == 0 = 0 | y == 0 || x <= 0 = root (fromIntegral x) (fromIntegral y) - | a Prelude.^ y == x = fromIntegral a + | e Prelude.^ y == x = fromIntegral e | otherwise = root (fromIntegral x) (fromIntegral y) where - a = round (fromIntegral x ** (1 / fromIntegral y)) + e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y)) ---------------------------------------------------------------------- -- Expr normalization @@ -55,108 +57,58 @@ collectLikeTerms :: Expr -> Expr collectLikeTerms = simplifyWith f sumView where - f = normalizeSum . map (simplifyWith (second normalizeProduct) productView) - -normalizeProduct :: [Expr] -> [Expr] -normalizeProduct ys = f [ (match rationalView y, y) | y <- ys ] - where - f [] = [] - f ((Nothing , e):xs) = e:f xs - f ((Just r , _):xs) = - let cs = r : [ c | (Just c, _) <- xs ] - rest = [ x | (Nothing, x) <- xs ] - in build rationalView (product cs):rest - -normalizeSum :: [Expr] -> [Expr] -normalizeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ] - where - pm :: Rational -> Expr -> (Rational, Expr) - pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of - (Just r1, _) -> pm (r*r1) e2 - (_, Just r1) -> pm (r*r1) e1 - _ -> (r, e1 .*. e2) - pm r (Negate e) = pm (negate r) e - pm r e = case match rationalView e of - Just r1 -> (r*r1, Nat 1) - Nothing -> (r, e) - - rec [] = [] - rec ((Nothing, e):xs) = e:rec xs - rec ((Just (r, a), e):xs) = new:rec rest - where - (js, rest) = partition (maybe False ((==a) . snd) . fst) xs - rs = r:map fst (mapMaybe fst js) - new | null js = e - | otherwise = build rationalView (sum rs) .*. a + f = mergeAlikeSum . map (simplifyWith (second mergeAlikeProduct) productView) ------------------------------------------------------------ --- Testing - -{- --- List with hard cases -hardCases = map cleanUpExpr $ let x=Var "x" in - [ -1/2*x*(x/1) - , (x/(-3)) - , (x/(-3))^2 - , (0-x)*(-x)/(-5/2) - , (x/(-1))^2 - , (x/(-1))^2-(-7/2)*x/(-1) - , (x^2+0)*3 - , -(49/9*x^2+0^2)*(3/16) - , (0*x-(-x^2))*(-3) - , x^2 - x^2 - , x^2-x^2-(x+x)*1 - , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1 - , (-7+7*x)^2-(x*0)^2/(-3) - , 1*(x+93)+4 - , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9 - ] -} - ------------------------------------------------------------- -- Cleaning up cleanUpSimple :: Expr -> Expr -cleanUpSimple = transform (f4 . f2 . f1) +cleanUpSimple = fixpoint (transform (f2 . f1)) where - use v = simplifyWith (assoPlus v) sumView - f1 = simplify rationalView - f2 = use identity - f4 = smartConstructors - -cleanUpRelation :: OrList (Relation Expr) -> OrList (Relation Expr) -cleanUpRelation = simplifyWith cleanUp (switchView equationView) + use v = simplifyWith (assocPlus v) sumView + f1 = use rationalView + f2 = smartConstructors -cleanUp :: OrList (Equation Expr) -> OrList (Equation Expr) -cleanUp = idempotent . join . fmap (keepEquation . fmap cleanUpExpr) +cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr) +cleanUpRelations = idempotent . join . fmap cleanUpRelation -keepEquation :: Equation Expr -> OrList (Equation Expr) -keepEquation eq@(a :==: b) - | any falsity (universe a ++ universe b) = false - | a == b = true - | otherwise = - case (match rationalView a, match rationalView b) of - (Just r, Just s) - | r == s -> true - | otherwise -> false - _ -> return eq +cleanUpRelation :: Relation Expr -> OrList (Relation Expr) +cleanUpRelation = f . fmap cleanUpBU where + f rel + | any falsity (universe a ++ universe b) = false + | a == b = fromBool (relationType rel `elem` equals) + | otherwise = + case (match rationalView a, match rationalView b) of + (Just r, Just s) -> fromBool (eval (relationType rel) r s) + _ -> return rel + where + (a, b) = (leftHandSide rel, rightHandSide rel) + + equals = + [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately] + + falsity :: Expr -> Bool falsity (Sqrt e) = maybe False (<0) (match rationalView e) falsity (_ :/: e) = maybe False (==0) (match rationalView e) falsity _ = False - + -- also simplify square roots -cleanUpExpr2 :: Expr -> Expr -cleanUpExpr2 = cleanUpExpr . transform (simplify (squareRootViewWith rationalView)) - cleanUpExpr :: Expr -> Expr -cleanUpExpr = cleanUpBU2 {- e = if a1==a2 && a2==a3 && a3==a3 && a3==a4 then a1 else error $ "\n\n\n" ++ unlines (map show - [e, a1, a2, a3, a4]) - where - a1 = cleanUpFix e - a2 = cleanUpBU e - a3 = cleanUpBU2 e - a4 = cleanUpLattice e -} - +cleanUpExpr = fixpoint $ + cleanUpBU . transform (simplify (squareRootViewWith rationalView)) + +-- normalize expr with associativity and commutative rules for + and * +acExpr :: Expr -> Expr +acExpr expr = + case (match sumView expr, match productView expr) of + (Just xs, _) | length xs > 1 -> + build sumView $ sort $ map acExpr xs + (_, Just (b, xs)) | length xs > 1 -> + build productView (b, sort $ map acExpr xs) + _ -> + descend acExpr expr + ------------------------------------------------------------ -- Technique 1: fixed points of views {- @@ -170,178 +122,89 @@ f3 = use (powerFactorViewWith rationalView) f4 = smartConstructors -} -assoPlus :: View Expr a -> [Expr] -> [Expr] -assoPlus v = rec . map (simplify v) +assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr] +assocPlus = assocOp (+) +assocTimes = assocOp (*) + +assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr] +assocOp op v = rec . map (simplify v) where rec (x:y:zs) = - case canonical v (x+y) of - Just a -> assoPlus v (a:zs) - Nothing -> x:assoPlus v (y:zs) + case canonical v (op x y) of + Just a -> rec (a:zs) + Nothing -> x:rec (y:zs) rec xs = xs ------------------------------------------------------------ --- Technique 2a: one bottom-up traversal -{- +-- Fixpoint of a bottom-up traversal + cleanUpBU :: Expr -> Expr -cleanUpBU = transform (f4 . f3 . f2 . f1) +cleanUpBU = {- fixpoint $ -} transform $ \e -> + simplify myView $ + fromMaybe (smart e) $ + canonical rationalView e + `mplus` do + a <- canonical specialSqrtOrder e + -- Just simplify order of terms with square roots for now + return (transform smart a) + `mplus` do + xs <- match sumView e + guard (length xs > 1) + return $ build sumView $ + assocPlus myView xs + `mplus` + canonical myView e + `mplus` do + (b, xs) <- match productView e + guard (length xs > 1) + return $ build productView + (b, assocTimes myView xs) where - use v = simplifyWith (assoPlus v) sumView - - f1 = simplify rationalView - f2 = simplify (squareRootViewWith rationalView) - f3 = use (powerFactorViewWith rationalView) - f4 = smartConstructors --} ------------------------------------------------------------- --- Technique 2b: one bottom-up traversal - -cleanUpBU2 :: Expr -> Expr -cleanUpBU2 = transform $ \e -> - case ( canonical rationalView e - , canonical specialSqrtOrder e - , match sumView e - ) of - (Just a, _, _) -> a - (_, Just a, _) -> -- Just simplify order of terms with square roots for now - transform smart a - (_, _, Just xs) | length xs > 1 -> - build sumView (assoPlus (powerFactorViewWith rationalView) xs) - _ -> case canonical (powerFactorViewWith rationalView) e of - Just a -> a - Nothing -> smart e + myView = powerFactorViewWith rationalView specialSqrtOrder :: View Expr [Expr] specialSqrtOrder = sumView >>> makeView f id where make = match (squareRootViewWith rationalView) - cmp (_, x) (_, y) = g x `compare` g y - g = isNothing . fromSquareRoot + g = isNothing . fromSquareRoot . snd f xs = do ys <- mapM make xs - return $ map fst $ sortBy cmp $ zip xs ys + return $ map fst $ sortBy (comparing g) $ zip xs ys smart :: Expr -> Expr smart (a :*: b) = a .*. b smart (a :/: b) = a ./. b smart expr@(Sym s [x, y]) - | s == powerSymbol = x .^. y - | s == rootSymbol = fromMaybe expr $ + | isPowerSymbol s = x .^. y + | isRootSymbol s = fromMaybe expr $ liftM2 simplerRoot (match rationalView x) (match integerView y) smart (Negate a) = neg a smart (a :+: b) = a .+. b smart (a :-: b) = a .-. b smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2 +-- smart (Sqrt a) = maybe (Sqrt a) (`simplerRoot` 2) (match rationalView a) smart e = e ------------------------------------------------------------- --- Technique 3: lattice of views -{- -data T = R Rational - | S (SquareRoot Rational) - | P String Rational Int - | E Expr deriving Show - -cleanUpLattice :: Expr -> Expr -cleanUpLattice = fromT . toT -fromT :: T -> Expr -fromT (R r) = fromRational r -fromT (S s) = build (squareRootViewWith rationalView) s -fromT (P x r n) = build (powerFactorViewForWith x rationalView) (r, n) -fromT (E e) = e - -toT :: Expr -> T -toT (Nat n) = R (fromInteger n) -toT (x :/: y) = divT (toT x) (toT y) -toT (x :*: y) = mulT (toT x) (toT y) -toT (Var x) = P x 1 1 -toT (Sym s [x, y]) | s == powerSymbol = - case (toT x, toT y) of - (R x, R y) | denominator y == 1 -> - R (x Prelude.^ fromInteger (numerator y)) - (P x a n, R y) | denominator y == 1 -> - P x (a Prelude.^ numerator y) (n*fromInteger (numerator y)) - (x, y) -> E (fromT x .^. fromT y) -toT e@(Sqrt _) = fromMaybe (E e) $ do -- Also here, too simplistic - s <- match (squareRootViewWith rationalView) e - return (S s) -toT (Negate e) = negT (toT e) -toT expr = - case match sumView expr of - Just xs | length xs > 1 -> sumT (map toT xs) - _ -> error $ show expr - -negT :: T -> T -negT (R r) = R (negate r) -negT (S s) = S (negate s) -negT (P x r n) = P x (negate r) n -negT (E e) = E (neg e) - -sumT :: [T] -> T -sumT = head . f (const True) . f (`elem` [1,2]) . f (==1) . concatMap g - where - g e@(E a) = case match sumView a of - Just xs | length xs > 1 -> map (upgr . E) xs - _ -> [e] - g a = [a] - - f p (a:b:xs) - | p (orderT a) && p (orderT b) = - f p (plusT a b:xs) - | otherwise = a:f p (b:xs) - f _ xs = xs - -plusT :: T -> T -> T -plusT (R 0) t = t -- ????? -plusT t (R 0) = t -- ????? -plusT (R x) (R y) = R (x+y) -plusT (S x) (S y) = S (x+y) -plusT t@(P _ _ _) b = plusT (E $ fromT t) b -plusT (E a) (E b) = E (a .+. b) -plusT a b = convTs plusT a b - -divT :: T -> T -> T -divT t (R 1) = t -- ????? -divT t (R (-1)) = negT t -- ????? -divT (R x) (R y) | y /= 0 = R (x/y) -divT t@(R _) b@(R _) = divT (E $ fromT t) b -divT (S x) (S y) = S (x/y) -divT t@(P _ _ _) b = divT (E $ fromT t) b -divT (E a) (E b) = E (a ./. b) -divT a b = convTs divT a b - -mulT :: T -> T -> T -mulT (R 0) _ = R 0 -- ????? -mulT _ (R 0) = R 0 -- ????? -mulT t (R 1) = t -- ???? -mulT (R 1) t = t -- ????? -mulT (R a) (R b) = R (a*b) -mulT (S a) (S b) = S (a*b) -mulT (P x1 r1 n1) (P x2 r2 n2) | x1==x2 = P x1 (r1*r2) (n1+n2) - | otherwise = error "" -mulT (E a) (E b) = E (a .*. b) -mulT a b = convTs mulT a b - -convTs :: (T -> T -> T) -> T -> T -> T -convTs f (R a) t@(S _) = f (S (fromRational a)) t -convTs f (R a) t@(P x _ _) = f (P x (fromRational a) 0) t -convTs f t@(R _) e@(E _) = f (E $ fromT t) e -convTs f t@(P _ _ _) e@(E _) = f (E $ fromT t) e -convTs f a b | orderT a > orderT b = convTs (flip f) b a -convTs _ x y = error $ "conv " ++ show (x, y) - -orderT :: T -> Int -orderT (R _) = 1 -orderT (S _) = 2 -orderT (P _ _ _) = 3 -orderT (E _) = 4 +------------------------------------------------------------ +-- Testing -upgr :: T -> T -upgr (E e) = - case (match (squareRootViewWith rationalView) e, match (powerFactorViewWith rationalView) e) of - (Just a, _) -> upgr (S a) - (_, Just (x, a, n)) -> upgr (P x a n) - _ -> E e -upgr (S a) = maybe (S a) R (fromSquareRoot a) -upgr (P _ a n) | n==0 = R a -upgr t = t -} +{- +-- List with hard cases +hardCases = map cleanUpExpr $ let x=Var "x" in + [ -1/2*x*(x/1) + , (x/(-3)) + , (x/(-3))^2 + , (0-x)*(-x)/(-5/2) + , (x/(-1))^2 + , (x/(-1))^2-(-7/2)*x/(-1) + , (x^2+0)*3 + , -(49/9*x^2+0^2)*(3/16) + , (0*x-(-x^2))*(-3) + , x^2 - x^2 + , x^2-x^2-(x+x)*1 + , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1 + , (-7+7*x)^2-(x*0)^2/(-3) + , 1*(x+93)+4 + , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9 + ] -} diff --git a/src/Domain/Math/Polynomial/Equivalence.hs b/src/Domain/Math/Polynomial/Equivalence.hs --- a/src/Domain/Math/Polynomial/Equivalence.hs +++ b/src/Domain/Math/Polynomial/Equivalence.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XGeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -15,27 +15,28 @@ , eqAfterSubstitution ) where +import Common.Classes import Common.Context -import Common.Traversable +import Common.Rewriting +import Common.Uniplate import Common.View +import Control.Monad +import Data.List (sort, nub) import Data.Maybe +import Data.Ord +import Domain.Logic.Formula hiding (Var, disjunctions) +import Domain.Math.Clipboard +import Domain.Math.Data.Interval import Domain.Math.Data.Polynomial hiding (eval) -import Data.List (sort, nub) +import Domain.Math.Data.Relation hiding (eval) +import Domain.Math.Data.SquareRoot +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp import Domain.Math.Polynomial.Views +import Domain.Math.SquareRoot.Views import Prelude hiding ((^), sqrt) -import Domain.Logic.Formula hiding (Var, disjunctions) import qualified Domain.Logic.Formula as Logic -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Numeric.Views -import Domain.Math.Data.Relation -import Domain.Math.Data.Interval -import Domain.Math.SquareRoot.Views -import Domain.Math.Expr -import Domain.Math.Data.SquareRoot -import Control.Monad -import Domain.Math.Clipboard -import Common.Rewriting hiding (constructor) -import Common.Uniplate relationIntervals :: Ord a => RelationType -> a -> Intervals a relationIntervals relType a = @@ -106,7 +107,7 @@ -- Use normal (numeric) ordering on square roots instance Ord Q where - Q a `compare` Q b = f a `compare` f b + Q a `compare` Q b = comparing f a b where f :: SquareRoot Rational -> Double f = eval . fmap fromRational @@ -120,14 +121,18 @@ highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool highEqContext = eqContextWith (polyEq highRel) +eqContextWith :: (Logic (Relation Expr) -> Logic (Relation Expr) -> Bool) + -> Context (Logic (Relation Expr)) + -> Context (Logic (Relation Expr)) + -> Bool eqContextWith eq a b = isJust $ do termA <- fromContext a termB <- fromContext b guard $ case (ineqOnClipboard a, ineqOnClipboard b) of - (Just a, Just b) -> eq a b && eq termA termB - (Just a, Nothing) -> eq (fmap toEq a) termA && eq a termB - (Nothing, Just b) -> eq (fmap toEq b) termB && eq termA b + (Just x, Just y) -> eq x y && eq termA termB + (Just x, Nothing) -> eq (fmap toEq x) termA && eq x termB + (Nothing, Just y) -> eq (fmap toEq y) termB && eq termA y (Nothing, Nothing) -> eq termA termB where toEq :: Relation Expr -> Relation Expr @@ -151,11 +156,11 @@ cuPlus :: Relation Expr -> Maybe (Relation Expr) cuPlus rel = do (a, b) <- match plusView (leftHandSide rel) - guard (noVars b && noVars (rightHandSide rel)) + guard (hasNoVar b && hasNoVar (rightHandSide rel)) return $ constructor rel a (rightHandSide rel - b) `mplus` do (a, b) <- match plusView (leftHandSide rel) - guard (noVars a && noVars (rightHandSide rel)) + guard (hasNoVar a && hasNoVar (rightHandSide rel)) return $ constructor rel b (rightHandSide rel - a) `mplus` do a <- isNegate (leftHandSide rel) @@ -175,8 +180,8 @@ cuPower rel = do (a, b) <- isBinary powerSymbol (leftHandSide rel) n <- match integerView b - guard (n > 0 && noVars (rightHandSide rel)) - let expr = cleanUpExpr2 (root (rightHandSide rel) (fromIntegral n)) + guard (n > 0 && hasNoVar (rightHandSide rel)) + let expr = cleanUpExpr (root (rightHandSide rel) (fromIntegral n)) new = constructor rel a expr opp = constructor (flipSides rel) a (-expr) rt = relationType rel @@ -259,13 +264,13 @@ -- for similarity simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool -simLogic f a b = rec (fmap f a) (fmap f b) +simLogic f p0 q0 = rec (fmap f p0) (fmap f q0) where rec a b - | isOperator orOperator a = + | isOr a = let collect = nub . sort . trueOr . collectOr in recList (collect a) (collect b) - | isOperator andOperator a = + | isAnd a = let collect = nub . sort . falseAnd . collectAnd in recList (collect a) (collect b) | otherwise = @@ -286,6 +291,17 @@ falseAnd xs = if F `elem` xs then [] else xs + shallowEq a b = + let g = descend (const T) + in g a == g b + + isOr (_ :||: _) = True + isOr _ = False + + isAnd (_ :||: _) = True + isAnd _ = False + + eqAfterSubstitution :: (Functor f, Functor g) => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool eqAfterSubstitution eq ca cb = fromMaybe False $ do @@ -296,9 +312,7 @@ substitute :: (String, Expr) -> Expr -> Expr substitute (s, a) (Var b) | s==b = a -substitute pair expr = f (map (substitute pair) cs) - where - (cs, f) = uniplate expr +substitute pair expr = descend (substitute pair) expr substOnClipboard :: Context a -> Maybe (String, Expr) substOnClipboard = evalCM $ const $ do 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 @@ -16,8 +16,8 @@ import Common.Exercise import Common.Rewriting import Common.Strategy -import Common.Traversable -import Common.Transformation +import Common.Classes +import Common.Uniplate import Common.View import Data.Maybe import Domain.Math.Data.OrList @@ -33,6 +33,7 @@ import Domain.Math.Polynomial.Views import Domain.Math.Polynomial.Equivalence import Domain.Math.Numeric.Views +import Domain.Math.Equation.CoverUpRules import Control.Monad ------------------------------------------------------------ @@ -40,18 +41,24 @@ linearExercise :: Exercise (Equation Expr) linearExercise = makeExercise - { description = "solve a linear equation" - , exerciseCode = makeCode "math" "lineq" + { exerciseId = describe "solve a linear equation" $ + newId "algebra.equations.linear" , status = Provisional , parser = parseExprWith (pEquation pExpr) - , similarity = eqRelation cleanUpSimple + , similarity = eqRelation (acExpr . cleanUpExpr) , equivalence = viewEquivalent linearEquationView , isSuitable = (`belongsTo` linearEquationView) , isReady = solvedRelationWith $ \a -> a `belongsTo` mixedFractionNormalForm || a `belongsTo` rationalNormalForm - , extraRules = liftToContext buggyPlus : linearRules - , strategy = mapRules liftToContext linearStrategy + , extraRules = map use buggyRulesEquation ++ + map use buggyRulesExpr + , ruleOrdering = ruleOrderingWithId + [ getId coverUpTimes, getId flipEquation + , getId removeDivision + ] + , strategy = linearStrategy + , navigation = termNavigator , examples = concat (linearEquations ++ [specialCases]) } where @@ -61,87 +68,93 @@ linearMixedExercise :: Exercise (Equation Expr) linearMixedExercise = linearExercise - { description = "solve a linear equation with mixed fractions" - , exerciseCode = makeCode "math" "lineq-mixed" + { exerciseId = describe "solve a linear equation with mixed fractions" $ + newId "algebra.equations.linear.mixed" , isReady = solvedRelationWith (`belongsTo` mixedFractionNormalForm) - , strategy = mapRules liftToContext linearMixedStrategy + , strategy = linearMixedStrategy } quadraticExercise :: Exercise (OrList (Relation Expr)) quadraticExercise = makeExercise - { description = "solve a quadratic equation" - , exerciseCode = makeCode "math" "quadreq" + { exerciseId = describe "solve a quadratic equation" $ + newId "algebra.equations.quadratic" , status = Provisional , parser = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of Left err -> Left err Right xs -> Right (build (switchView equationView) xs) - , similarity = eqOrList cleanUpExpr2 + , similarity = eqOrList cleanUpExpr , equivalence = equivalentRelation (viewEquivalent quadraticEquationsView) , isSuitable = (`belongsTo` (switchView equationView >>> quadraticEquationsView)) , isReady = solvedRelations - , extraRules = map (liftToContext . liftRule (switchView equationView)) $ - quadraticRules ++ abcBuggyRules + , extraRules = map use abcBuggyRules ++ buggyQuadratic ++ + map use buggyRulesEquation ++ map use buggyRulesExpr + , ruleOrdering = ruleOrderingWithId $ + quadraticRuleOrder ++ [getId buggySquareMultiplication] , strategy = quadraticStrategy + , navigation = termNavigator , examples = map (orList . return . build equationView) (concat quadraticEquations) } higherDegreeExercise :: Exercise (OrList (Relation Expr)) higherDegreeExercise = makeExercise - { description = "solve an equation (higher degree)" - , exerciseCode = makeCode "math" "higherdegree" + { exerciseId = describe "solve an equation (higher degree)" $ + newId "algebra.equations.polynomial" , status = Provisional , parser = parser quadraticExercise - , similarity = eqOrList cleanUpExpr2 + , similarity = eqOrList cleanUpExpr , eqWithContext = Just $ eqAfterSubstitution $ equivalentRelation (viewEquivalent higherDegreeEquationsView) , isSuitable = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView)) , isReady = solvedRelations - , extraRules = map (liftToContext . liftRule (switchView equationView)) higherDegreeRules + , extraRules = map use abcBuggyRules ++ buggyQuadratic ++ + map use buggyRulesEquation ++ map use buggyRulesExpr + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder , strategy = higherDegreeStrategy + , navigation = termNavigator , examples = map (orList . return . build equationView) (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations]) } quadraticNoABCExercise :: Exercise (OrList (Relation Expr)) quadraticNoABCExercise = quadraticExercise - { description = "solve a quadratic equation without abc-formula" - , exerciseCode = makeCode "math" "quadreq-no-abc" + { exerciseId = describe "solve a quadratic equation without abc-formula" $ + newId "algebra.equations.quadratic.no-abc" , status = Alpha , strategy = configure cfg quadraticStrategy } where - cfg = [ (ByName (name prepareSplitSquare), Reinsert) - , (ByName (name bringAToOne), Reinsert) - , (ByName "abc form", Remove) - , (ByName (name simplerPoly), Remove) + cfg = [ (byName prepareSplitSquare, Reinsert) + , (byName bringAToOne, Reinsert) + , (byName (newId "abc form"), Remove) + , (byName simplerPolynomial, Remove) ] quadraticWithApproximation :: Exercise (OrList (Relation Expr)) quadraticWithApproximation = quadraticExercise - { description = "solve a quadratic equation with approximation" - , exerciseCode = makeCode "math" "quadreq-with-approx" + { exerciseId = describe "solve a quadratic equation with approximation" $ + newId "algebra.equations.quadratic.approximate" , status = Alpha , parser = parseExprWith (pOrList (pRelation pExpr)) , strategy = configure cfg quadraticStrategy , equivalence = equivalentApprox } where - cfg = [ (ByName "approximate result", Reinsert) - , (ByName "square root simplification", Remove) + cfg = [ (byName (newId "approximate result"), Reinsert) + , (byName (newId "square root simplification"), Remove) ] --- fixMe = checksForList quadraticWithApproximation - findFactorsExercise :: Exercise Expr findFactorsExercise = makeExercise - { description = "factorize the expression" - , exerciseCode = makeCode "math" "factor" + { exerciseId = describe "factorize the expression" $ + newId "algebra.manipulation.polynomial.factor" , status = Provisional , parser = parseExprWith pExpr , similarity = \a b -> cleanUpExpr a == cleanUpExpr b , equivalence = viewEquivalent (polyViewWith rationalView) , isReady = (`belongsTo` linearFactorsView) - , strategy = mapRules liftToContext findFactorsStrategy + , strategy = findFactorsStrategy + , navigation = termNavigator + , extraRules = map liftToContext buggyRulesExpr , examples = concat findFactors } @@ -180,11 +193,12 @@ toEq rel | relationType rel `elem` [EqualTo, Approximately] = Just (leftHandSide rel :==: rightHandSide rel) | otherwise = Nothing - toApprox (a :==: b) = - let f x = case match doubleView x of - Just d -> Number (precision 4 d) - Nothing -> x - in f a .~=. f b + +toApprox :: Equation Expr -> Relation Expr +toApprox (a :==: b) = f a .~=. f b + where + f x = maybe x (Number . precision 4) (match doubleView x) + equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool equivalentRelation f ra rb = fromMaybe False $ do @@ -196,32 +210,28 @@ (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -> Bool eqOrList f x y = normOrList f x == normOrList f y -eqRelation :: (Relational f, Eq (f Expr)) => - (Expr -> Expr) -> f Expr -> f Expr -> Bool -eqRelation f x y = normRelation f x == normRelation f y +eqRelation :: (Relational f, Eq (f Expr)) => (Expr -> Expr) -> f Expr -> f Expr -> Bool +eqRelation f x y = fmap f x == fmap f y +-- Normalize the order of disjunctions. Simplify the expression with the function +-- passed as argument, but do not change (flip) the sides of the relation. normOrList :: (Relational f, Ord (f Expr)) => (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -normOrList f = normalize . fmap (normRelation f) - -normRelation :: Relational f => (Expr -> Expr) -> f Expr -> f Expr -normRelation f rel - | leftHandSide new > rightHandSide new && isSymmetric new = flipSides new - | otherwise = new - where - new = fmap (normExpr f) rel +normOrList f = normalize . fmap (fmap (normExpr f)) normExpr :: (Expr -> Expr) -> Expr -> Expr -normExpr f = normalizeWith [plusOperator, timesOperator] . f +normExpr f = rec . f where - plusOperator = acOperator (+) isPlus - timesOperator = acOperator (*) isTimes + plusOperator = makeCommutative $ monoid + (makeBinary (getId plusSymbol) (+) isPlus) + (simpleConstant "zero" 0) + timesOperator = makeCommutative $ monoid + (makeBinary (getId timesSymbol) (*) isTimes) + (simpleConstant "one" 1) + make = simplifyWith (map rec) . magmaListView --- TODO: move this definition -buggyPlus :: Rule (Equation Expr) -buggyPlus = buggyRule $ makeSimpleRuleList "buggy plus" $ \(lhs :==: rhs) -> do - (a, b) <- matchM plusView lhs - [ a :==: rhs + b, b :==: rhs + a ] - `mplus` do - (a, b) <- matchM plusView rhs - [ lhs + a :==: b, lhs + b :==: a ] + rec expr = + case expr of + _ :+: _ -> make plusOperator expr + _ :*: _ -> make timesOperator expr + _ -> descend rec expr diff --git a/src/Domain/Math/Polynomial/IneqExercises.hs b/src/Domain/Math/Polynomial/IneqExercises.hs --- a/src/Domain/Math/Polynomial/IneqExercises.hs +++ b/src/Domain/Math/Polynomial/IneqExercises.hs @@ -15,20 +15,21 @@ import Common.Context import Common.Exercise +import Common.Rewriting import Common.Strategy hiding (not) import Common.Transformation -import Common.Uniplate (uniplate) +import Common.Uniplate (descend) import Common.View import Control.Monad import Data.List (nub, sort) import Data.Maybe (fromMaybe) import Domain.Math.Data.Interval -import Domain.Logic.Formula (Logic((:||:), (:&&:))) +import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic) import Domain.Math.Clipboard import Domain.Math.Data.OrList import Domain.Math.Data.Relation import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) -import Domain.Math.Polynomial.Exercises (eqRelation, normRelation) +import Domain.Math.Polynomial.Exercises (eqRelation, normExpr) import Domain.Math.Equation.Views import Domain.Math.Examples.DWO2 import Domain.Math.Expr @@ -40,17 +41,19 @@ import Domain.Math.SquareRoot.Views import Prelude hiding (repeat) import qualified Domain.Logic.Formula as Logic +import qualified Domain.Logic.Views as Logic ineqLinearExercise :: Exercise (Relation Expr) ineqLinearExercise = makeExercise - { description = "solve a linear inequation" - , exerciseCode = makeCode "math" "linineq" + { exerciseId = describe "solve a linear inequation" $ + newId "algebra.inequalities.linear" , status = Provisional , parser = parseExprWith (pRelation pExpr) , isReady = solvedRelation , equivalence = linEq - , similarity = eqRelation cleanUpExpr2 - , strategy = mapRules liftToContext ineqLinear + , similarity = eqRelation cleanUpExpr + , strategy = ineqLinear + , navigation = termNavigator , examples = let x = Var "x" extra = (x-12) / (-2) :>: (x+3)/3 in map (build inequalityView) (concat ineqLin1 ++ [extra]) @@ -58,33 +61,40 @@ ineqQuadraticExercise :: Exercise (Logic (Relation Expr)) ineqQuadraticExercise = makeExercise - { description = "solve a quadratic inequation" - , exerciseCode = makeCode "math" "quadrineq" + { exerciseId = describe "solve a quadratic inequation" $ + newId "algebra.inequalities.quadratic" , status = Provisional , parser = parseExprWith (pLogicRelation pExpr) , prettyPrinter = showLogicRelation , isReady = solvedRelations , eqWithContext = Just quadrEqContext - , similarity = simLogic (normRelation cleanUpExpr2 . flipGT) + , similarity = simLogic (fmap (normExpr cleanUpExpr) . flipGT) , strategy = ineqQuadratic + , navigation = termNavigator + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder , examples = map (Logic.Var . build inequalityView) (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad]) } ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr)) ineqHigherDegreeExercise = makeExercise - { description = "solve an inequation of higher degree" - , exerciseCode = makeCode "math" "ineqhigherdegree" + { exerciseId = describe "solve an inequation of higher degree" $ + newId "algebra.inequalities.polynomial" , status = Provisional , parser = parseExprWith (pLogicRelation pExpr) , prettyPrinter = showLogicRelation , isReady = solvedRelations , eqWithContext = Just highEqContext - , similarity = simLogic (normRelation cleanUpExpr2 . flipGT) + , similarity = simLogic (fmap (normExpr cleanUpExpr) . flipGT) , strategy = ineqHigherDegree + , navigation = termNavigator + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder , examples = map (Logic.Var . build inequalityView) ineqHigh } +ineq :: String +ineq = "algebra.inequalities" + showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String showLogicRelation logic = case logic of @@ -107,7 +117,7 @@ ineq2 <- match inequalityView r2 let g (a :>=: b) = b :<=: a g (a :>: b) = b :<: a - g ineq = ineq + g e = e make (g ineq1) (g ineq2) f _ = Nothing @@ -123,34 +133,42 @@ op _ = False h (x, o1, y, o2, z) = - let f b = if b then (.<=.) else (.<.) - in Logic.Var (f o1 x y) :&&: Logic.Var (f o2 y z) + let g b = if b then (.<=.) else (.<.) + in Logic.Var (g o1 x y) :&&: Logic.Var (g o2 y z) +ineqLinear :: LabeledStrategy (Context (Relation Expr)) +ineqLinear = cleanUpStrategy (applyTop (fmap cleanUpSimple)) ineqLinearG -ineqLinear :: LabeledStrategy (Relation Expr) -ineqLinear = cleanUpStrategy (fmap cleanUpSimple) $ - label "Linear inequation" $ - label "Phase 1" (repeat ( - removeDivision - <|> ruleMulti (ruleSomewhere distributeTimes) - <|> ruleMulti merge)) - <*> - label "Phase 2" ( - try varToLeft - <*> try (coverUpPlus id) - <*> try flipSign - <*> try coverUpTimesPositive) +ineqLinearG :: IsTerm a => LabeledStrategy (Context a) +ineqLinearG = label "Linear inequation" $ + label "Phase 1" (repeat + ( use removeDivision + <|> multi (showId distributeTimes) + (somewhere (useC parentNotNegCheck <*> use distributeTimes)) + <|> multi (showId merge) (once (use merge)) + )) + <*> + label "Phase 2" + ( try (use varToLeft) + <*> try coverUpPlus + <*> try (use flipSign) + <*> try (use coverUpTimesPositive) + ) --- helper strategy -coverUpPlus :: (Rule (Relation Expr) -> Rule a) -> Strategy a -coverUpPlus f = alternatives $ map (f . ($ oneVar)) - [ coverUpBinaryRule "plus" (commOp . isPlus) (-) - , coverUpBinaryRule "minus left" isMinus (+) - , coverUpBinaryRule "minus right" (flipOp . isMinus) (flip (-)) - ] -- [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] +-- helper strategy (todo: fix needed, because the original rules do not +-- work on relations) +coverUpPlus :: IsTerm a => Strategy (Context a) +coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps) + where + coverUps :: [ConfigCoverUp -> Rule (Relation Expr)] + coverUps = + [ coverUpBinaryRule "plus" (commOp . isPlus) (-) + , coverUpBinaryRule "minus-left" isMinus (+) + , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-)) + ] coverUpTimesPositive :: Rule (Relation Expr) -coverUpTimesPositive = coverUpBinaryRule "times positive" (commOp . m) (/) varConfig +coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp where m expr = do (a, b) <- matchM timesView expr @@ -159,7 +177,8 @@ return (a, b) flipSign :: Rule (Relation Expr) -flipSign = makeSimpleRule "flip sign" $ \r -> do +flipSign = describe "Flip sign of inequality" $ + makeSimpleRule (ineq, "flip-sign") $ \r -> do let lhs = leftHandSide r rhs = rightHandSide r guard (isNegative lhs) @@ -170,25 +189,41 @@ maybe False fst (match productView expr) ineqQuadratic :: LabeledStrategy (Context (Logic (Relation Expr))) -ineqQuadratic = label "Quadratic inequality" $ - try (liftRule (contextView (orView >>> justOneView)) turnIntoEquation) - <*> mapRules (liftRule (contextView orView)) quadraticStrategy - <*> solutionInequation +ineqQuadratic = cleanUpStrategy (applyTop cleanUpLogicRelation) $ + label "Quadratic inequality" $ + use trivialRelation + |> try (useC turnIntoEquation) + <*> quadraticStrategyG + <*> useC solutionInequation ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr))) -ineqHigherDegree = label "Inequality of a higher degree" $ - try (liftRule (contextView (orView >>> justOneView)) turnIntoEquation) - <*> mapRules (liftRule (contextView orView)) higherDegreeStrategy - <*> solutionInequation +ineqHigherDegree = cleanUpStrategy (applyTop cleanUpLogicRelation) $ + label "Inequality of a higher degree" $ + use trivialRelation + |> try (useC turnIntoEquation) + <*> higherDegreeStrategyG + <*> useC solutionInequation -justOneView :: View (OrList a) a -justOneView = makeView (f . disjunctions) return - where - f (Just [r]) = Just r - f _ = Nothing +-- First, cleanup expression. Then, cleanup equations only (there is an +-- explicit rule for the other relations). Finally, simplify the logical +-- proposition (including impotency or). +cleanUpLogicRelation :: Logic (Relation Expr) -> Logic (Relation Expr) +cleanUpLogicRelation = + let f a | relationType a == EqualTo = build orListView (cleanUpRelation a) + | otherwise = Logic.Var a + in simplifyWith idempotent orListView . Logic.simplify + . catLogic . fmap (f . fmap cleanUpExpr) + +trivialRelation :: Rule (OrList (Relation Expr)) +trivialRelation = + makeSimpleRule (ineq, "trivial") $ oneDisjunct $ \a -> do + let new = cleanUpRelation a + guard (isTrue new || isFalse new) + return new turnIntoEquation :: Rule (Context (Relation Expr)) -turnIntoEquation = makeSimpleRule "turn into equation" $ withCM $ \r -> do +turnIntoEquation = describe "Turn into equation" $ + makeSimpleRule (ineq, "to-equation") $ withCM $ \r -> do guard (relationType r `elem` ineqTypes) addToClipboard "ineq" (toExpr r) return (leftHandSide r .==. rightHandSide r) @@ -198,19 +233,20 @@ -- Todo: cleanup this function solutionInequation :: Rule (Context (Logic (Relation Expr))) -solutionInequation = makeSimpleRule "solution inequation" $ withCM $ \r -> do - ineq <- lookupClipboard "ineq" >>= fromExpr +solutionInequation = describe "Determine solution for inequality" $ + makeSimpleRule (ineq, "give-solution") $ withCM $ \r -> do + inEquation <- lookupClipboard "ineq" >>= fromExpr removeClipboard "ineq" - orv <- maybeCM (matchM orView r) + orv <- maybeCM (matchM orListView r) case disjunctions orv of Nothing -> -- both sides are the same - if relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] + if relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] then return Logic.T else return Logic.F Just [] -> do -- no solutions found for equations - let vs = collectVars (toExpr ineq) + let vs = vars (toExpr inEquation) guard (not (null vs)) - if evalIneq ineq (head vs) 0 + if evalIneq inEquation (head vs) 0 then return Logic.T else return Logic.F Just xs -> do @@ -220,9 +256,9 @@ ds <- matchM (listView doubleView) zs guard (all (==v) vs) let rs = makeRanges including (sort (zipWith A ds zs)) - including = relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] + including = relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] return $ fromIntervals v fromDExpr $ - fromList [ this | (d, isP, this) <- rs, isP || evalIneq ineq v d ] + fromList [ this | (d, isP, this) <- rs, isP || evalIneq inEquation v d ] where makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)] makeRanges b xs = @@ -248,9 +284,9 @@ evalIneq :: Relation Expr -> String -> Double -> Bool evalIneq r v d = fromMaybe False $ - liftM2 (evalType (relationType r)) (use leftHandSide) (use rightHandSide) + liftM2 (evalType (relationType r)) (useSide leftHandSide) (useSide rightHandSide) where - use f = match doubleView (sub (f r)) + useSide f = match doubleView (sub (f r)) evalType tp = case tp of @@ -263,8 +299,7 @@ Approximately -> \a b -> abs (a-b) < 0.001 sub (Var x) | x==v = Number d - sub expr = build (map sub cs) - where (cs, build) = uniplate expr + sub expr = descend sub expr data DExpr = A Double Expr diff --git a/src/Domain/Math/Polynomial/LeastCommonMultiple.hs b/src/Domain/Math/Polynomial/LeastCommonMultiple.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/LeastCommonMultiple.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) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.LeastCommonMultiple + ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM + , powerProductView + ) where + +import Prelude hiding ((^)) +import Common.TestSuite +import Common.View +import Control.Monad +import Data.List +import Data.Ratio +import Data.Maybe +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Views +import Test.QuickCheck + +-- | Returns the least common multiple of two expressions. +lcmExpr :: Expr -> Expr -> Expr +lcmExpr a b = fromMaybe (a*b) $ do + (ar, as) <- match powerProductView a + (br, bs) <- match powerProductView b + return $ build powerProductView (lcmR ar br, merge as bs) + where + lcmR :: Rational -> Rational -> Rational + lcmR r1 r2 = + let f r = numerator r * denominator r + in fromIntegral (lcm (f r1) (f r2)) + + merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)] + merge = foldr op id + where + op (e, n1) f ys = + let n2 = fromMaybe 0 (lookup e ys) + rest = filter ((/=e) . fst) ys + in (e, n1 `max` n2) : f rest + +-- | Only succeeds if there is no remainder +divisionExpr :: Expr -> Expr -> Maybe Expr +divisionExpr a b = do + (ar, as) <- match powerProductView a + (br, bs) <- match powerProductView b + xs <- as `without` bs + return $ build powerProductView (ar/br, xs) + where + without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)] + without [] ys = + guard (null ys) >> return [] + without ((e,n1):xs) ys = + let n2 = fromMaybe 0 (lookup e ys) + rest = filter ((/=e) . fst) ys + in liftM ((e,n1-n2):) (without xs rest) + +powerProductView :: View Expr (Rational, [(Expr, Integer)]) +powerProductView = makeView f g + where + f expr = do + (b, xs) <- match productView expr + let (r, ys) = collectPairs xs + return (if b then -r else r, merge ys) + + g (r, xs) = + build productView (False, fromRational r : map (build pvn) xs) + + pvn :: View Expr (Expr, Integer) + pvn = powerView >>> second integerView + + collectPairs :: [Expr] -> (Rational, [(Expr, Integer)]) + collectPairs = foldr op (1, []) + where + op e (r, xs) = + let mr = match rationalView e + h r2 = (r*r2, xs) + pair = fromMaybe (e,1) (match pvn e) + in maybe (r, pair:xs) h mr + + merge :: [(Expr, Integer)] -> [(Expr, Integer)] + merge [] = [] + merge xs@((e, _) : _) = + let (xs1, xs2) = partition ((==e) . fst) xs + n = sum (map snd xs1) + in (e, n) : merge xs2 + +testLCM :: TestSuite +testLCM = suite "lcmExpr" $ do + addProperty "transitivity" $ f3 $ \a b c -> + lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c + addProperty "commutativity" $ f2 $ \a b -> + lcmExpr a b ~= lcmExpr b a + addProperty "idempotency" $ f1 $ \a -> + lcmExpr a a ~= absExpr a + addProperty "zero" $ f1 $ \a -> + lcmExpr a 0 ~= 0 + addProperty "one" $ f1 $ \a -> + lcmExpr a 1 ~= absExpr a + addProperty "sign" $ f2 $ \a b -> + lcmExpr a b ~= lcmExpr (-a) b + where + f1 g = liftM g genExpr + f2 g = liftM2 g genExpr genExpr + f3 g = liftM3 g genExpr genExpr genExpr + + genExpr, genTerm, genAtom :: Gen Expr + genExpr = do + n <- choose (0, 10) + b <- arbitrary + xs <- replicateM n genTerm + return $ build productView (b, xs) + + genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)] + + genAtom = do + v <- oneof $ map (return . Var) ["a", "b", "c"] + i <- choose (-10, 10) + n <- choose (0, 10) + p <- frequency [(3, return v), (1, return (v .+. fromInteger i))] + frequency [(3, return p), (1, return (p^fromInteger n))] + + (~=) = equalFactors + absExpr = simplifyWith (first (const False)) productView + +noCommonFactor :: Expr -> Expr -> Bool +noCommonFactor x y = lcmExpr x y `equalFactors` (x*y) + +equalFactors :: Expr -> Expr -> Bool +equalFactors x y = f x == f y + where f = simplifyWith (second sort) powerProductView diff --git a/src/Domain/Math/Polynomial/RationalExercises.hs b/src/Domain/Math/Polynomial/RationalExercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/RationalExercises.hs @@ -0,0 +1,313 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.RationalExercises + ( rationalEquationExercise + , simplifyRationalExercise, divisionRationalExercise + , eqSimplifyRational + ) where + +import Common.Classes +import Common.Context +import Common.Exercise +import Common.Navigator +import Common.Rewriting +import Common.Strategy hiding (not) +import Common.Uniplate +import Common.Utils (fst3) +import Common.View +import Control.Monad +import Data.List hiding (repeat, replicate) +import Data.Maybe +import Domain.Logic.Formula hiding (disjunctions, Var) +import qualified Domain.Logic as Logic +import qualified Domain.Logic.Views as Logic +import Domain.Logic.Views hiding (simplify) +import Domain.Math.Clipboard +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Equation.Views +import Domain.Math.Examples.DWO4 +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Exercises (eqOrList) +import Domain.Math.Polynomial.LeastCommonMultiple +import Domain.Math.Polynomial.RationalRules +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.Polynomial.Views +import Domain.Math.SquareRoot.Views +import Domain.Math.Power.OldViews +import Prelude hiding (repeat, replicate, until, (^)) +import qualified Data.Set as S + +rationalEquationExercise :: Exercise (OrList (Equation Expr)) +rationalEquationExercise = makeExercise + { exerciseId = describe "solve a rational equation (with a variable in a divisor)" $ + newId "algebra.equations.rational" + , status = Provisional + , parser = parseExprWith (pOrList (pEquation pExpr)) + , isSuitable = isJust . rationalEquations + , isReady = solvedRelations + , eqWithContext = Just eqRationalEquation + , similarity = eqOrList cleanUpExpr + , strategy = rationalEquationStrategy + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , navigation = termNavigator + , examples = map return (concat brokenEquations) + } + +simplifyRationalExercise :: Exercise Expr +simplifyRationalExercise = makeExercise + { exerciseId = describe "simplify a rational expression (with a variable in a divisor)" $ + newId "algebra.manipulation.rational.simplify" + , status = Alpha -- Provisional + , parser = parseExpr +-- isSuitable + , isReady = simplifiedRational + -- , eqWithContext = Just eqSimplifyRational + , similarity = \x y -> cleanUpExpr x == cleanUpExpr y + , strategy = simplifyRationalStrategy + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , navigation = termNavigator + , examples = concat (normBroken ++ normBroken2) + } + +divisionRationalExercise :: Exercise Expr +divisionRationalExercise = simplifyRationalExercise + { exerciseId = describe "divide a rational expression ('uitdelen')" $ + newId "math.divrational" + , strategy = label "divide broken fraction" succeed + , examples = concat deelUit + } + +rationalEquationStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +rationalEquationStrategy = cleanUpStrategy (applyTop (fmap (fmap cleaner))) $ + label "Rational equation" $ + brokenFormToPoly <*> higherDegreeStrategyG <*> checkSolutionStrategy + where + -- a custom-made clean-up function. (Standard) cleanUpExpr function + -- has some strange interaction with the rules + cleaner = transform (simplify (powerFactorViewWith rationalView)) + . cleanUpSimple . transform smart + + brokenFormToPoly = label "rational form to polynomial" $ until allArePoly $ + ( useC divisionIsZero <|> useC divisionIsOne + <|> useC sameDivisor <|> useC sameDividend + <|> use coverUpPlus <|> use coverUpMinusLeft <|> use coverUpMinusRight + <|> use coverUpNegate + ) |> + ( useC crossMultiply <|> useC multiplyOneDiv ) + checkSolutionStrategy = label "check solutions" $ + try (multi (showId checkSolution) (somewhere checkSolution)) + +allArePoly :: Context (OrList (Equation Expr)) -> Bool +allArePoly = + let f a = a `belongsTo` polyView + in maybe False (all f . concatMap crush . crush) . fromContext + +simplifyRationalStrategy :: LabeledStrategy (Context Expr) +simplifyRationalStrategy = cleanUpStrategy (applyTop cleaner) $ + label "Simplify rational expression" $ + phaseOneDiv <*> phaseSimplerDiv + where + -- a custom-made clean-up function. (Standard) cleanUpExpr function + -- has some strange interaction with the rules + cleaner = transform (simplify (powerFactorViewWith rationalView)) . cleanUpSimple + + phaseOneDiv = label "Write as division" $ + until isDivC $ + use fractionPlus <|> use fractionScale <|> use turnIntoFraction + phaseSimplerDiv = label "Simplify division" $ + repeat $ + (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv) + <|> commit (onlyUpperDiv (repeat findFactorsStrategyG) <*> useC cancelTermsDiv)) + |> ( somewhere (use merge) + <|> multi (showId distributeTimes) (exceptLowerDiv (use distributeTimes)) + ) + +isDivC :: Context a -> Bool +isDivC = maybe False (isJust . isDivide :: Term -> Bool) . currentT + +-- First check that the whole strategy can be executed. Cleaning up is not +-- propagated correctly to predicate in check combinator, hence the use of +-- cleanUpStrategy (which is not desirable here). +commit :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr) +commit s = let cs = cleanUpStrategy (applyTop cleanUpExpr) (label "" s) + f a = fromMaybe a (do b <- top a; c <- current a; return (change (const c) b)) + in check (applicable cs . f) <*> s + +exceptLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) +exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> + if isDivC a then [1] else [0 .. arity a-1] + +onlyUpperDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) +onlyUpperDiv = onceWith "only-upper-div" $ \a -> [ 1 | isDivC a ] + +onlyLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) +onlyLowerDiv = onceWith "only-lower-div" $ \a -> [ 2 | isDivC a ] + +simplifiedRational :: Expr -> Bool +simplifiedRational expr = + case expr of + Negate a -> simplifiedRational a + _ -> f expr + where + f (a :/: b) = inPolyForm a && noCommonFactor a b && inFactorForm b + f _ = False + + inPolyForm :: Expr -> Bool + inPolyForm a = + a `belongsTo` polyNormalForm identity || + S.size (varSet expr) > 1 + + inFactorForm :: Expr -> Bool + inFactorForm = flip belongsTo $ + let v = first (polyNormalForm identity >>> second linearPolyView) + in powerProductView >>> second (listView v) + +rationalEquations :: OrList (Equation Expr) -> Maybe (OrList Expr) +rationalEquations = maybe (return true) f . disjunctions + where + f xs = do + yss <- mapM rationalEquation xs + return (join (orList yss)) + +rationalEquation :: Equation Expr -> Maybe (OrList Expr) +rationalEquation eq = do + let (lhs :==: rhs) = coverUp eq + (a, b, c) = rationalExpr (lhs .-. rhs) + (_, as) <- match productView a + (_, bs) <- match productView b + let condition = foldr ((.&&.) . notZero) c bs + new1 <- match higherDegreeEquationsView $ orList $ map (:==: 0) as + return (restrictOrList condition new1) + +restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr +restrictOrList p0 = maybe true (orList . filter p) . disjunctions + where + p zeroExpr = + case coverUp (zeroExpr :==: 0) of + Var x :==: a -> -- returns true if a contradiction was not found + substVar x (cleanUpExpr a) p0 /= F + _ -> True + + substVar x a = Logic.simplify . catLogic . fmap (simpler . fmap (cleanUpExpr . subst)) + where + subst (Var s) | x == s = a + subst expr = descend subst expr + + simpler r = fromMaybe (Logic.Var r) $ do + a <- match (squareRootViewWith rationalView) (leftHandSide r) + b <- match (squareRootViewWith rationalView) (rightHandSide r) + case (a==b, relationType r) of + (True, EqualTo) -> return T + (False, EqualTo) -> return F + (True, NotEqualTo) -> return F + (False, NotEqualTo) -> return T + _ -> Nothing + +eqRationalEquation :: Context (OrList (Equation Expr)) -> Context (OrList (Equation Expr)) -> Bool +eqRationalEquation ca cb = fromMaybe False $ + liftM2 (==) (solve ca) (solve cb) + where + solve ctx = do + let f = fromMaybe T . conditionOnClipboard + a <- fromContext ctx + xs <- rationalEquations a + ys <- disjunctions (restrictOrList (f ctx) xs) + return (sort (nub ys)) + +eqSimplifyRational :: Context Expr -> Context Expr -> Bool +eqSimplifyRational ca cb = fromMaybe False $ do + a <- fromContext ca + b <- fromContext cb + let a1c = cleanUpExpr (fst3 (rationalExpr a)) + b1c = cleanUpExpr (fst3 (rationalExpr b)) + manyVars = S.size (varSet a `S.union` varSet b) > 1 + if manyVars then return True else do + p1 <- match (polyViewWith rationalView) a1c + p2 <- match (polyViewWith rationalView) b1c + return (manyVars || p1==p2) + +conditionOnClipboard :: Context a -> Maybe (Logic (Relation Expr)) +conditionOnClipboard = evalCM $ const $ + lookupClipboardG "condition" + +-- write expression as a/b, under certain conditions +rationalExpr :: Expr -> (Expr, Expr, Logic (Relation Expr)) +rationalExpr expr = + case expr of + a :+: b -> rationalExpr a `fPlus` rationalExpr b + a :-: b -> rationalExpr (a :+: Negate b) + Negate a -> fNeg (rationalExpr a) + a :*: b -> rationalExpr a `fTimes` rationalExpr b + a :/: b -> rationalExpr a `fTimes` fRecip (rationalExpr b) + Sym s [a, b] | isPowerSymbol s -> + fPower (rationalExpr a) b + _ -> (expr, 1, T) + where + fNeg (a, b, p) = (neg a, b, p) + fRecip (a, b, p) = (b, a, notZero b .&&. p) + fPower (a, b, p) n = (a .^. n, b .^. n, p) + fTimes (a1, a2, p) (b1, b2, q) = (a1 .*. b1, a2 .*. b2, p .&&. q) + fPlus (a1, a2, p) (b1, b2, q) = + case (divisionExpr c2 a2, divisionExpr c2 b2) of + (Just a3, Just b3) + | a1 == b1 -> (a1 .*. (a3 .+. b3), c2, pq) + | a1 == neg b1 -> (a1 .*. (a3 .-. b3), c2, pq) + | otherwise -> (a1 .*. a3 .+. b1 .*. b3, c2, pq) + _ -> (a1 .*. b2 .+. b1 .*. a2, a2 .*. b2, pq) + where + c2 = lcmExpr a2 b2 + pq = p .&&. q + +notZero :: Expr -> Logic (Relation Expr) +notZero expr = + case match rationalView expr of + Just r | r /= 0 -> T + | otherwise -> F + _ -> Logic.Var (expr ./=. 0) + +----------------- +-- test code + +{- +raar = brokenExpr $ x^2/(5*x+6) + 1 + where x = Var "x" +- +go0 = checkExercise rationalEquationExercise + +go = checkExercise simplifyRationalExercise + +see n = printDerivation ex (examples ex !! (n-1)) + where ex = --rationalEquationExercise + simplifyRationalExercise + +go4 = printDerivation findFactorsExercise $ -a + 4 + where x = Var "x" + a = Var "a" + +test = e4 + where + a = Var "a" + b = Var "b" + + e1 = 6*a*b*a + e2 = -4*b^2*a*2 + e3 = lcmExpr e1 e2 + e4 = divisionExpr e3 e1 + e5 = divisionExpr e3 e2 + +go = putStrLn $ unlines $ map show $ zip [1..] $ map (brokenEq []) (concat brokenEquations) +-} diff --git a/src/Domain/Math/Polynomial/RationalRules.hs b/src/Domain/Math/Polynomial/RationalRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/RationalRules.hs @@ -0,0 +1,186 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.RationalRules + ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend + , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv + , fractionScale, turnIntoFraction, checkSolution + ) where + +import Common.Context +import Common.Id +import Common.Transformation +import Common.View +import Control.Monad +import Data.Maybe +import Domain.Logic.Formula hiding (disjunctions, Var) +import Domain.Logic.Views +import Domain.Math.Clipboard +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.LeastCommonMultiple +import Domain.Math.Polynomial.Views +import Domain.Math.Power.Views +import qualified Domain.Logic.Formula as Logic + +ratId :: Id +ratId = newId "algebra.equations.rational" + +--------------------------------------------------------------- +-- Rules for rational expressions and rational equations + +-- a/b = 0 iff a=0 (and b/=0) +divisionIsZero :: Rule (Context (Equation Expr)) +divisionIsZero = makeSimpleRule (ratId, "division-zero") $ withCM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (a, b) <- matchM divView lhs + conditionNotZero b + return (a :==: 0) + +-- a/b = 1 iff a=b (and b/=0) +divisionIsOne :: Rule (Context (Equation Expr)) +divisionIsOne = makeSimpleRule (ratId, "division-one") $ withCM $ \(lhs :==: rhs) -> do + guard (rhs == 1) + (a, b) <- matchM divView lhs + conditionNotZero b + return (a :==: b) + +-- a/c = b/c iff a=b (and c/=0) +sameDivisor :: Rule (Context (Equation Expr)) +sameDivisor = makeSimpleRule (ratId, "same-divisor") $ withCM $ \(lhs :==: rhs) -> do + (a, c1) <- matchM divView lhs + (b, c2) <- matchM divView rhs + guard (c1==c2) + conditionNotZero c1 + return (a :==: b) + +-- a/b = a/c iff a=0 or b=c (and b/=0 and c/=0) +sameDividend :: Rule (Context (OrList (Equation Expr))) +sameDividend = makeSimpleRule (ratId, "same-dividend") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do + (a1, b) <- matchM divView lhs + (a2, c) <- matchM divView rhs + guard (a1==a2) + conditionNotZero b + conditionNotZero c + return $ orList [a1 :==: 0, b :==: c] + +-- a/b = c/d iff a*d = b*c (and b/=0 and d/=0) +crossMultiply :: Rule (Context (Equation Expr)) +crossMultiply = makeSimpleRule (ratId, "cross-multiply") $ withCM $ \(lhs :==: rhs) -> do + (a, b) <- matchM divView lhs + (c, d) <- matchM divView rhs + conditionNotZero b + conditionNotZero d + return (a*d :==: b*c) + +-- a/b = c iff a = b*c (and b/=0) +multiplyOneDiv :: Rule (Context (Equation Expr)) +multiplyOneDiv = makeSimpleRule (ratId, "multiply-one-div") $ withCM $ \(lhs :==: rhs) -> + f (:==:) lhs rhs `mplus` f (flip (:==:)) rhs lhs + where + f eq ab c = do + guard (not (c `belongsTo` divView)) + (a, b) <- matchM divView ab + conditionNotZero b + return (a `eq` (b*c)) + +-- a/c + b/c = a+b/c (also see Numeric.Rules) +fractionPlus :: Rule Expr -- also minus +fractionPlus = makeSimpleRule (ratId, "rational-plus") $ \expr -> do + ((a, b), (c, d)) <- match myView expr + guard (b == d) + return (build divView (a+c, b)) + where + myView = plusView >>> (divView *** divView) + +-- ab/ac => b/c (if a/=0) +-- Note that the common term can be squared (in one of the parts) +cancelTermsDiv :: Rule (Context Expr) +cancelTermsDiv = makeSimpleRule (ratId, "cancel-div") $ withCM $ \expr -> do + ((b, xs), (c, ys)) <- matchM myView expr + let (ps, qs, rs) = rec (map f xs) (map f ys) + guard (not (null rs)) + conditionNotZero (build productView (False, map g rs)) + return $ build myView ((b, map g ps), (c, map g qs)) + where + myView = divView >>> (productView *** productView) + powInt = powerView >>> second integerView + f a = fromMaybe (a, 1) (match powInt a) + g = build powInt + rec ((_, 0):xs) ys = rec xs ys + rec (pair@(a, n):xs) ys = + case break ((==a) . fst) ys of + (ys1, (b, m):ys2) + | m == 0 -> + rec (pair:xs) (ys1++ys2) + | otherwise -> + let i = n `min` m + (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2) + in (ps, qs, (a,i):rs) + _ -> + let (ps,qs,rs) = rec xs ys + in (pair:ps, qs,rs) + rec xs ys = (xs, ys, []) + +fractionScale :: Rule Expr +fractionScale = liftRule myView $ + makeSimpleRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do + guard (e1 /= e2) + let e3 = lcmExpr e1 e2 + ma <- divisionExpr e3 e1 + mb <- divisionExpr e3 e2 + guard (ma /= 1 || mb /= 1) + return ((ma*a, e3), (mb*b, e3)) + where + myView = plusView >>> (divView *** divView) + +turnIntoFraction :: Rule Expr +turnIntoFraction = liftRule plusView $ + makeSimpleRule (ratId, "to-rational") $ \(a, b) -> + liftM (\c -> (c, b)) (f a b) `mplus` + liftM (\c -> (a, c)) (f b a) + where + f a b = do + guard (not (a `belongsTo` divView)) + (_, e) <- match divView b + return $ build divView (a*e, e) + +-- A simple implementation that considers the condition stored in the context +checkSolution :: Rule (Context (OrList (Equation Expr))) +checkSolution = makeSimpleRule (ratId, "check-solution") $ + withCM $ oneDisjunct $ \(x :==: a) -> do + c <- lookupClipboardG "condition" + xs <- matchM andView c + guard ((x ./=. a) `elem` xs) + return false + +--------------------------------------------------------------- +-- Helper-code + +condition :: Logic (Relation Expr) -> ContextMonad () +condition c = do + mp <- maybeOnClipboardG "condition" + let a = maybe id (.&&.) mp c + unless (a==T) (addToClipboardG "condition" a) + +conditionNotZero :: Expr -> ContextMonad () +conditionNotZero expr = condition (f xs) + where + f = pushNotWith (Logic.Var . notRelation) . nott + eq = expr :==: 0 + xs = fmap (build equationView . fmap cleanUpExpr) $ + case match higherDegreeEquationsView (return eq) of + Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys)) + Nothing -> Logic.Var (coverUp eq) 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 @@ -9,92 +9,95 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Math.Polynomial.Rules where +module Domain.Math.Polynomial.Rules + ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms + , commonFactorVar, commonFactorVarNew, defPowerNat, distributeDivision + , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare + , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero + , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar + , parentNotNegCheck, prepareSplitSquare, quadraticRuleOrder, removeDivision + , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational + , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRoot + , squareBothSides, substBackVar, varToLeft + ) where -import Common.Apply -import Common.Context -import Common.Rewriting -import Common.Transformation -import Common.Traversable -import Common.Uniplate (universe, uniplate) +import Common.Library hiding (terms, simplify) +import Common.Uniplate (universe, descend) import Common.Utils -import Common.View hiding (simplify) import Control.Monad -import Data.List (nub, (\\), sort, sortBy) +import Data.List import Data.Maybe +import Data.Ord import Data.Ratio import Domain.Math.Approximation (precision) import Domain.Math.Clipboard import Domain.Math.Data.OrList +import Domain.Math.Data.Polynomial import Domain.Math.Data.Relation -import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) +import Domain.Math.Equation.BalanceRules +import Domain.Math.Equation.CoverUpRules import Domain.Math.Expr import Domain.Math.Numeric.Views import Domain.Math.Polynomial.CleanUp import Domain.Math.Polynomial.Views -import Domain.Math.Power.Views -import Domain.Math.Simplification -import Prelude hiding (repeat, (^), replicate) -import qualified Domain.Math.Data.Polynomial as P -import qualified Domain.Math.SquareRoot.Views as SQ +import Domain.Math.Power.OldViews +import Domain.Math.Simplification hiding (simplifyWith) +import Domain.Math.SquareRoot.Views +import Prelude hiding ( (^) ) ------------------------------------------------------------- --- Rule collection +quadraticRuleOrder :: [Id] +quadraticRuleOrder = + [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar) + , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar) + , getId coverUpPower + , getId commonFactorVar, getId simplerPolynomial + , getId niceFactors, getId noLinFormula + , getId cancelTerms, getId sameConFactor, getId distributionSquare + , getId allPowerFactors + ] -linearRules :: [Rule (Context (Equation Expr))] -linearRules = map liftToContext $ - [ removeDivision, ruleMulti merge, ruleMulti distributeTimesSomewhere - , varToLeft, coverUpNegate, coverUpTimes - ] ++ - map ($ oneVar) - [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] +lineq, quadreq, polyeq :: String +lineq = "algebra.equations.linear" +quadreq = "algebra.equations.quadratic" +polyeq = "algebra.equations.polynomial" -quadraticRules :: [Rule (OrList (Equation Expr))] -quadraticRules = -- abcFormula - [ ruleOnce commonFactorVar, ruleOnce noLinFormula, ruleOnce niceFactors - , ruleOnce simplerPoly, mulZero, coverUpPower, squareBothSides - ] ++ - map (ruleOnce . ($ oneVar)) - [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] ++ - [ ruleOnce coverUpTimes, ruleOnce coverUpNegate, ruleOnce coverUpNumerator - , ruleOnce prepareSplitSquare, ruleOnce factorLeftAsSquare - , ruleOnce2 (ruleSomewhere merge), ruleOnce cancelTerms - , ruleOnce2 distributeTimesSomewhere - , ruleOnce2 (ruleSomewhere distributionSquare), ruleOnce flipEquation - , ruleOnce moveToLeft, ruleMulti2 (ruleSomewhere simplerSquareRoot) - ] - -higherDegreeRules :: [Rule (OrList (Equation Expr))] -higherDegreeRules = - [ allPowerFactors, sameFactor - ] ++ quadraticRules - ------------------------------------------------------------ -- General form rules: ax^2 + bx + c = 0 +quadraticNF :: View Expr (String, (Rational, Rational, Rational)) +quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView + -- ax^2 + bx = 0 commonFactorVar :: Rule (Equation Expr) commonFactorVar = rhsIsZero commonFactorVarNew +-- Maybe to be replaced by more general factorVariablePower?? commonFactorVarNew :: Rule Expr -commonFactorVarNew = makeSimpleRule "common factor var" $ \expr -> do - (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) expr - guard (c == 0 && b /= 0) - -- also search for constant factor - let d = (if a<0 && b<0 then negate else id) (gcdFrac a b) - return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) +commonFactorVarNew = describe "Common factor variable" $ + makeSimpleRule (quadreq, "common-factor") $ \expr -> do + (x, (a, b, c)) <- match quadraticNF expr + guard (b /= 0 && c == 0) + -- also search for constant factor + let d | a<0 && b<0 = -gcdFrac a b + | otherwise = gcdFrac a b + return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) +gcdFrac :: Rational -> Rational -> Rational +gcdFrac r1 r2 = + if denominator r1 == 1 && denominator r2 == 1 + then fromInteger (numerator r1 `gcd` numerator r2) + else 1 -- ax^2 + c = 0 noLinFormula :: Rule (Equation Expr) -noLinFormula = makeSimpleRule "no linear term b" $ \(lhs :==: rhs) -> do - guard (rhs == 0) - (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs - guard (b == 0 && c /= 0) - return $ - if a>0 then fromRational a .*. (Var x .^. 2) :==: fromRational (-c) - else fromRational (-a) .*. (Var x .^. 2) :==: fromRational c +noLinFormula = describe "No linear term ('b=0')" $ liftRule myView $ + makeSimpleRule (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do + guard (rhs == 0 && b == 0 && c /= 0) + return $ if a>0 then ((x, (a, 0, 0)), -c) + else ((x, (-a, 0, 0)), c) + where + myView = constantRight quadraticNF -- search for (X+A)*(X+B) decomposition niceFactors :: Rule (Equation Expr) @@ -102,12 +105,11 @@ -- search for (X+A)*(X+B) decomposition niceFactorsNew :: Rule Expr -niceFactorsNew = makeSimpleRuleList "nice factors" $ \expr -> do +niceFactorsNew = describe "Find a nice decomposition" $ + makeSimpleRuleList (quadreq, "nice-factors") $ \expr -> do let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t - (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) expr) + (x, (a, b, c)) <- liftM sign (matchM (polyNormalForm integerView >>> second quadraticPolyView) expr) guard (a==1) - b <- isInt rb - c <- isInt rc let ok (i, j) = i+j == b f (i, j) | i == j = -- special case @@ -115,67 +117,62 @@ | otherwise = (Var x + fromInteger i) * (Var x + fromInteger j) map f (filter ok (factors c)) - -rhsIsZero :: Rule Expr -> Rule (Equation Expr) -rhsIsZero r = makeSimpleRuleList (name r) $ \(lhs :==: rhs) -> do - guard (rhs == 0) - a <- applyAll r lhs - return (a :==: rhs) + where + factors :: Integer -> [(Integer, Integer)] + factors n = [ pair + | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n))) + , a <- [1..h], let b = n `div` a, a*b == n + , pair <- [(a, b), (negate a, negate b)] + ] -- Simplify polynomial by multiplying (or dividing) the terms: -- 1) If a,b,c are ints, then find gcd -- 2) If any of a,b,c is a fraction, find lcm of denominators -- 3) If a<0, then also suggest to change sign (return two solutions) -simplerPoly :: Rule (Equation Expr) -simplerPoly = makeSimpleRuleList "simpler polynomial" $ \(lhs :==: rhs) -> do - guard (rhs == 0) - let thisView = polyNormalForm rationalView >>> second quadraticPolyView - (x, (a, b, c)) <- matchM thisView lhs - r <- findFactor [a, b, c] - d <- if a >= 0 then [r] else [-r, r] - guard (d `notElem` [0, 1]) - return (build thisView (x, (a*d, b*d, c*d)) :==: 0) +simplerPolynomial :: Rule (Equation Expr) +simplerPolynomial = describe "simpler polynomial" $ + rhsIsZero $ liftRuleIn thisView $ + makeSimpleRuleList (quadreq, "simpler-poly") $ \(a, b, c) -> do + r <- findFactor (filter (/=0) [a, b, c]) + d <- if a >= 0 then [r] else [-r, r] + guard (d `notElem` [0, 1]) + return (a*d, b*d, c*d) where - findFactor :: Monad m => [Rational] -> m Rational - findFactor rs - | null rs || any (==0) rs = - fail "no factor" - | all ((==1) . denominator) rs = - return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs - | otherwise = - return $ fromIntegral $ foldr1 lcm $ map denominator rs - + thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView + -- Simplified variant of simplerPoly: just bring a to 1. -- Needed for quadratic strategy without square formula bringAToOne :: Rule (Equation Expr) -bringAToOne = makeSimpleRule "bring a to one" $ \(lhs :==: rhs) -> do - guard (rhs == 0) - let thisView = polyNormalForm rationalView >>> second quadraticPolyView - (x, (a, b, c)) <- matchM thisView lhs +bringAToOne = rhsIsZero $ liftRuleIn thisView $ + describe "Bring 'a' to one" $ + makeSimpleRule (quadreq, "scale") $ \(a, b, c) -> do guard (a `notElem` [0, 1]) - return (build thisView (x, (1, b/a, c/a)) :==: 0) + return (1, b/a, c/a) + where + thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView ------------------------------------------------------------ -- General form rules: expr = 0 -- Rule must be symmetric in side of equation mulZero :: Rule (OrList (Equation Expr)) -mulZero = makeSimpleRuleList "multiplication is zero" $ onceJoinM bothSides +mulZero = describe "multiplication is zero" $ + makeSimpleRuleList (quadreq, "product-zero") $ oneDisjunct bothSides where bothSides eq = oneSide eq `mplus` oneSide (flipSides eq) oneSide (lhs :==: rhs) = do guard (rhs == 0) (_, xs) <- matchM productView lhs guard (length xs > 1) - let f e = case match (polyNormalForm rationalView >>> second linearPolyView) e of - -- special cases (simplify immediately, as in G&R) - Just (x, (a, b)) - | a == 1 -> - Var x :==: fromRational (-b) - | a == -1 -> - Var x :==: fromRational b - _ -> e :==: 0 - return $ orList $ map f xs + return $ orList $ flip map xs $ \e -> + case match (polyNormalForm rationalView >>> second linearPolyView) e of + -- special cases (simplify immediately, as in G&R) + Just (x, (a, b)) + | a == 1 -> + Var x :==: fromRational (-b) + | a == -1 -> + Var x :==: fromRational b + _ -> e :==: 0 ------------------------------------------------------------ -- Constant form rules: expr = constant @@ -184,39 +181,40 @@ -- Prevent (x^2+3x)+5 = 0 to be covered up oneVar :: ConfigCoverUp oneVar = configCoverUp - { configName = Just "one var" + { configName = "onevar" , predicateCovered = \a -> p1 a || p2 a - , predicateCombined = noVars + , predicateCombined = hasNoVar , coverLHS = True , coverRHS = True } where - p1 = (==1) . length . collectVars + p1 = (==1) . length . vars -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56 p2 a = fromMaybe False $ do (x, y) <- match timesView a - return (hasVars x /= hasVars y) + return (hasSomeVar x /= hasSomeVar y) ------------------------------------------------------------ -- Top form rules: expr1 = expr2 -- Do not simplify (5+sqrt 53)/2 simplerSquareRoot :: Rule Expr -simplerSquareRoot = makeSimpleRule "simpler square root" $ \e -> do - xs <- f e - guard (not (null xs)) - new <- canonical (SQ.squareRootViewWith rationalView) e - ys <- f new - guard (xs /= ys) - return new +simplerSquareRoot = describe "simpler square root" $ + makeSimpleRule (quadreq, "simpler-sqrt") $ \e -> do + xs <- f e + guard (not (null xs)) + new <- canonical (squareRootViewWith rationalView) e + ys <- f new + guard (xs /= ys) + return new where -- return numbers under sqrt symbol f :: Expr -> Maybe [Rational] - f e = liftM sort $ sequence [ match rationalView e | Sqrt e <- universe e ] - + f e = liftM sort $ sequence [ match rationalView a | Sqrt a <- universe e ] cancelTerms :: Rule (Equation Expr) -cancelTerms = makeSimpleRule "cancel terms" $ \(lhs :==: rhs) -> do +cancelTerms = describe "Cancel terms" $ + makeSimpleRule (quadreq, "cancel") $ \(lhs :==: rhs) -> do xs <- match sumView lhs ys <- match sumView rhs let zs = filter (`elem` ys) (nub xs) @@ -226,148 +224,146 @@ -- Two out of three "merkwaardige producten" distributionSquare :: Rule Expr -distributionSquare = makeSimpleRule "distribution square" f - where - f (Sym s [a :+: b, Nat 2]) | s == powerSymbol = - return ((a .^. 2) .+. (2 .*. a .*. b) + (b .^. 2)) - f (Sym s [a :-: b, Nat 2]) | s == powerSymbol = - return ((a .^. 2) .-. (2 .*. a .*. b) + (b .^. 2)) - f _ = Nothing +distributionSquare = describe "distribution square" $ + ruleList (quadreq, "distr-square") + [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2 + , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2 + ] -- a^2 == b^2 squareBothSides :: Rule (OrList (Equation Expr)) -squareBothSides = makeSimpleRule "square both sides" $ onceJoinM f - where - f (Sym s1 [a, Nat 2] :==: Sym s2 [b, Nat 2]) | all (==powerSymbol) [s1, s2] = - return $ orList [a :==: b, a :==: -b] - f _ = Nothing +squareBothSides = describe "square both sides" $ + rule (quadreq, "square-both") $ \a b -> + orList [a^2 :==: b^2] :~> orList [a :==: b, a :==: -b] -- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c prepareSplitSquare :: Rule (Equation Expr) -prepareSplitSquare = makeSimpleRule "prepare split square" $ \(lhs :==: rhs) -> do - d <- match rationalView rhs - let myView = polyNormalForm rationalView >>> second quadraticPolyView - (x, (a, b, c)) <- match myView lhs - let newC = (b/2)*(b/2) - newRHS = d + newC - c - guard (a==1 && b/=0 && c /= newC) - return (build myView (x, (a, b, newC)) :==: build rationalView newRHS) +prepareSplitSquare = describe "prepare split square" $ + liftRule myView $ + makeSimpleRule (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do + let newC = (b/2)*(b/2) + newRHS = r + newC - c + guard (a==1 && b/=0 && c /= newC) + return ((x, (a, b, newC)), newRHS) + where + myView = constantRight quadraticNF -- factor left-hand side into (ax + c)^2 factorLeftAsSquare :: Rule (Equation Expr) -factorLeftAsSquare = makeSimpleRule "factor left as square" $ \(lhs :==: rhs) -> do - guard (noVars rhs) - (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs - let h = b/2 - guard (a==1 && b/=0 && h*h == c) - return ((Var x + build rationalView h)^2 :==: rhs) +factorLeftAsSquare = describe "factor left as square" $ + makeSimpleRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do + guard (hasNoVar rhs) + (x, (a, b, c)) <- match quadraticNF lhs + let h = b/2 + guard (a==1 && b/=0 && h*h == c) + return ((Var x + build rationalView h)^2 :==: rhs) -- flip the two sides of an equation flipEquation :: Rule (Equation Expr) flipEquation = doBeforeTrans condition $ - rule "flip equation" $ \a b -> + describe "flip equation" $ + rule (lineq, "flip") $ \a b -> (a :==: b) :~> (b :==: a) where condition = makeTrans $ \eq@(lhs :==: rhs) -> do - guard (hasVars rhs && noVars lhs) + guard (hasSomeVar rhs && hasNoVar lhs) return eq -- Afterwards, merge and sort moveToLeft :: Rule (Equation Expr) -moveToLeft = makeSimpleRule "move to left" $ \(lhs :==: rhs) -> do - guard (rhs /= 0) - let complex = case fmap (filter hasVars) $ match sumView (applyD merge lhs) of - Just xs | length xs >= 2 -> True - _ -> False - guard (hasVars lhs && (hasVars rhs || complex)) - let new = applyD mergeT $ applyD sortT $ lhs - rhs - return (new :==: 0) +moveToLeft = describe "Move to left" $ + makeSimpleRule (quadreq, "move-left") $ \(lhs :==: rhs) -> do + guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs)) + return (collectLikeTerms (sorted (lhs - rhs)) :==: 0) + where + isComplex = maybe False ((>= 2) . length . filter hasSomeVar) + . match sumView . applyD merge + + -- high exponents first, non power-factor terms at the end + sorted = simplifyWith (sortBy (comparing toPF)) sumView + toPF = fmap (negate . thd3) . match powerFactorView ruleApproximate :: Rule (Relation Expr) -ruleApproximate = makeSimpleRule "approximate" $ \relation -> do - lhs :==: rhs <- match equationView relation - guard (not (simplify rhs `belongsTo` rationalView)) - x <- getVariable lhs - d <- match doubleView rhs - let new = fromDouble (precision 4 d) - return (Var x .~=. new) +ruleApproximate = describe "Approximate irrational number" $ + makeSimpleRule (quadreq, "approx") $ \relation -> do + lhs :==: rhs <- match equationView relation + guard (not (simplify rhs `belongsTo` rationalView)) + x <- getVariable lhs + d <- match doubleView rhs + let new = fromDouble (precision 4 d) + return (Var x .~=. new) ruleNormalizeRational :: Rule Expr -ruleNormalizeRational = - ruleFromView "normalize rational number" rationalView +ruleNormalizeRational = + describe "normalize rational number" $ + ruleFromView (lineq, "norm-rational") rationalView ruleNormalizeMixedFraction :: Rule Expr ruleNormalizeMixedFraction = - ruleFromView "normalize mixed fraction" mixedFractionView - -ruleFromView :: Eq a => String -> View a b -> Rule a -ruleFromView s v = makeSimpleRuleList s $ \a -> do - b <- canonicalM v a - guard (a /= b) - return b - ------------------------------------------------------------- --- Helpers and Rest - -factors :: Integer -> [(Integer, Integer)] -factors n = concat [ [(a, b), (negate a, negate b)] | a <- [1..h], let b = n `div` a, a*b == n ] - where h = floor (sqrt (abs (fromIntegral n))) - -isInt :: MonadPlus m => Rational -> m Integer -isInt r = do - guard (denominator r == 1) - return (numerator r) - -gcdFrac :: Rational -> Rational -> Rational -gcdFrac r1 r2 = fromMaybe 1 $ do - a <- isInt r1 - b <- isInt r2 - return (fromInteger (gcd a b)) + describe "normalize mixed fraction" $ + ruleFromView (lineq, "norm-mixed") mixedFractionView ----------------------------------------------------------- -------- Rules From HDE -- X*A + X*B = X*C + X*D +-- New implementation, but slightly different than original +-- This one does not factor constants + allPowerFactors :: Rule (OrList (Equation Expr)) -allPowerFactors = makeSimpleRule "all power factors" $ onceJoinM $ \(lhs :==: rhs) -> do - xs <- match (sumView >>> listView powerFactorView) lhs - ys <- match (sumView >>> listView powerFactorView) rhs - case unzip3 (filter ((/=0) . snd3) (xs ++ ys)) of - (s:ss, _, ns) | all (==s) ss -> do - let m = minimum ns - make = build (sumView >>> listView powerFactorView) . map f - f (s, i, n) = (s, i, n-m) - guard (m > 0 && length ns > 1) - return $ orList [Var s :==: 0, make xs :==: make ys] - _ -> Nothing +allPowerFactors = describe "all power factors" $ + makeSimpleRule (polyeq, "power-factors") $ oneDisjunct $ + \(lhs :==: rhs) -> do + let myView = polyNormalForm rationalView + (s1, p1) <- match myView lhs + (s2, p2) <- match myView rhs + let n | p1 == 0 = lowestDegree p2 + | p2 == 0 = lowestDegree p1 + | otherwise = lowestDegree p1 `min` lowestDegree p2 + ts = terms p1 ++ terms p2 + f p = build myView (s1, raise (-n) p) + guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1) + return $ orList [Var s1 :==: 0, f p1 :==: f p2] +factorVariablePower :: Rule Expr +factorVariablePower = describe "factor variable power" $ + makeSimpleRule (polyeq, "factor-varpower") $ \expr -> do + let myView = polyNormalForm rationalView + (s, p) <- match (polyNormalForm rationalView) expr + let n = lowestDegree p + guard (n > 0 && length (terms p) > 1) + return $ Var s .^. fromIntegral n * build myView (s, raise (-n) p) + -- A*B = A*C implies A=0 or B=C sameFactor :: Rule (OrList (Equation Expr)) -sameFactor = makeSimpleRule "same factor" $ onceJoinM $ \(lhs :==: rhs) -> do - (b1, xs) <- match productView lhs - (b2, ys) <- match productView rhs - (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasVars x ] -- equality is too strong? - return $ orList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ] +sameFactor = describe "same factor" $ + makeSimpleRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do + (b1, xs) <- match productView lhs + (b2, ys) <- match productView rhs + (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong? + return $ orList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ] -- N*(A+B) = N*C + N*D recognize a constant factor on both sides -- Example: 3(x^2+1/2) = 6+6x sameConFactor :: Rule (Equation Expr) -sameConFactor = makeSimpleRule "same constant factor" $ \(lhs :==: rhs) -> do - xs <- match sumView lhs - ys <- match sumView rhs - ps <- mapM (match productView) (xs ++ ys) - let (bs, zs) = unzip ps - (rs, es) = unzip (map (f 1 []) zs) - f r acc [] = (r, reverse acc) - f r acc (x:xs) = case match rationalView x of - Just r2 -> f (r*r2) acc xs - Nothing -> f r (x:acc) xs - con <- whichCon rs - guard (con /= 1) - let make b r e = build productView (b, (fromRational (r/con):e)) - (newLeft, newRight) = splitAt (length xs) (zipWith3 make bs rs es) - return (build sumView newLeft :==: build sumView newRight) +sameConFactor = + describe "same constant factor" $ + liftRule myView $ + makeSimpleRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do + let (bs, zs) = unzip (ps1 ++ ps2) + (rs, es) = unzip (map (f 1 []) zs) + f r acc [] = (r, reverse acc) + f r acc (x:xs) = case match rationalView x of + Just r2 -> f (r*r2) acc xs + Nothing -> f r (x:acc) xs + c <- whichCon rs + guard (c /= 1) + let make b r e = (b, fromRational (r/c):e) + (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es) + return (newLeft :==: newRight) where + myView = bothSidesView (sumView >>> listView productView) + whichCon :: [Rational] -> Maybe Rational whichCon xs | all (\x -> denominator x == 1 && x /= 0) xs = @@ -375,9 +371,10 @@ | otherwise = Nothing abcFormula :: Rule (Context (OrList (Equation Expr))) -abcFormula = makeSimpleRule "abc formula" $ withCM $ onceJoinM $ \(lhs :==: rhs) -> do +abcFormula = describe "quadratic formula (abc formule)" $ + makeSimpleRule (quadreq, "abc") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do guard (rhs == 0) - (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs + (x, (a, b, c)) <- matchM quadraticNF lhs addListToClipboard ["a", "b", "c"] (map fromRational [a, b, c]) let discr = b*b - 4 * a * c sqD = sqrt (fromRational discr) @@ -392,7 +389,8 @@ ] higherSubst :: Rule (Context (Equation Expr)) -higherSubst = makeSimpleRule "higher subst" $ withCM $ \(lhs :==: rhs) -> do +higherSubst = describe "Substitute variable" $ + makeSimpleRule (polyeq, "subst") $ withCM $ \(lhs :==: rhs) -> do guard (rhs == 0) let myView = polyView >>> second trinomialPolyView (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs @@ -401,26 +399,26 @@ addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2)) return (new :==: 0) -substBackVar :: (Crush f, Crush g) => Rule (Context (f (g Expr))) -substBackVar = makeSimpleRule "subst back var" $ withCM $ \a -> do +substBackVar :: Rule (Context Expr) +substBackVar = describe "Substitute back a variable" $ + makeSimpleRule (polyeq, "back-subst") $ withCM $ \a -> do expr <- lookupClipboard "subst" case fromExpr expr of Just (Var p :==: rhs) -> do - guard (p `elem` concatMap collectVars (concatMap crush (crush a))) - return (fmap (fmap (subst p rhs)) a) + guard (hasVar p a) + return (subst p rhs a) _ -> fail "no subst in clipboard" where subst a b (Var c) | a==c = b - subst a b expr = build (map (subst a b) cs) - where (cs, build) = uniplate expr + subst a b expr = descend (subst a b) expr exposeSameFactor :: Rule (Equation Expr) -exposeSameFactor = makeSimpleRuleList "expose same factor" $ \(lhs :==: rhs) -> do - (bx, xs) <- matchM (productView) lhs - (by, ys) <- matchM (productView) rhs - (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] ++ - [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ] - return (build productView (bx, nx) :==: build productView (by, ny)) +exposeSameFactor = describe "expose same factor" $ + liftRule (bothSidesView productView) $ + makeSimpleRuleList (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do + (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] ++ + [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ] + return ((bx, nx) :==: (by, ny)) where suitable p = fromMaybe False $ do (_, _, b) <- match (linearViewWith rationalView) p @@ -433,32 +431,22 @@ expose a b = do (s1, p1) <- matchM (polyViewWith rationalView) a (s2, p2) <- matchM (polyViewWith rationalView) b - guard (s1==s2) - case P.division p2 p1 of + guard (s1==s2 && p1/=p2) + case division p2 p1 of Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3] Nothing -> [] --------------------------------------------------------- -- From LinearEquations -------------------------------------------------------- --- Transformations - -plusT, minusT :: Functor f => Expr -> Transformation (f Expr) -plusT e = makeTrans $ return . fmap (applyD mergeT . (.+. e)) -minusT e = makeTrans $ return . fmap (applyD mergeT . (.-. e)) - -timesT :: Functor f => Expr -> Transformation (f Expr) -timesT e = makeTrans $ \eq -> do - r <- match rationalView e - guard (r /= 0) - return $ fmap (applyD mergeT . applyD distributionOldT . (e .*.)) eq - -divisionT :: Expr -> Transformation (Equation Expr) -divisionT e = makeTrans $ \eq -> do - r <- match rationalView e - guard (r /= 0) - return $ fmap (applyD mergeT . applyD distributionOldT . (./. e)) eq +-- Only used for cleaning up +distributeAll :: Expr -> Expr +distributeAll expr = + case expr of + e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1) + bs = fromMaybe [e2] (match sumView e2) + in build sumView [ a .*. b | a <- as, b <- bs ] + _ -> expr -- This rule should consider the associativity of multiplication -- Combine bottom-up, for example: 5*(x-5)*(x+5) @@ -482,89 +470,123 @@ rec _ = [] g :: Expr -> Expr -> [Expr] - g a b = do - as <- matchM sumView a - bs <- matchM sumView b + g e1 e2 = do + as <- matchM sumView e1 + bs <- matchM sumView e2 guard (length as > 1 || length bs > 1) return $ build sumView [ a .*. b | a <- as, b <- bs ] -mergeT :: Transformation Expr -mergeT = makeTrans $ return . collectLikeTerms - --- high exponents first, non power-factor terms at the end -sortT :: Transformation Expr -sortT = makeTrans $ \e -> do - xs <- match sumView e - let f = fmap (negate . thd3) . match powerFactorView - ps = sortBy cmp $ zip xs (map f xs) - cmp (_, ma) (_, mb) = compare ma mb - return $ build sumView $ map fst ps - ------------------------------------------------------- -- Rewrite Rules -varToLeft :: Relational f => Rule (f Expr) -varToLeft = makeRule "variable to left" $ flip supply1 minusT $ \eq -> do - (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq) - guard (a/=0) - return (fromRational a * Var x) +varToLeft :: Rule (Relation Expr) +varToLeft = doAfter (fmap collectLikeTerms) $ + describe "variable to left" $ + makeRule (lineq, "var-left") $ flip supply1 minusT $ \eq -> do + (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq) + guard (a/=0) + return (fromRational a * Var x) -- factor is always positive due to lcm function -removeDivision :: Relational r => Rule (r Expr) -removeDivision = makeRule "remove division" $ flip supply1 timesT $ \eq -> do - xs <- match sumView (leftHandSide eq) - ys <- match sumView (rightHandSide eq) - -- also consider parts without variables - -- (but at least one participant should have a variable) - zs <- forM (xs ++ ys) $ \a -> do - (_, list) <- match productView a - return [ (hasVars a, e) | e <- list ] - let f (b, e) = do - (_, this) <- match (divView >>> second integerView) e - return (b, this) - case mapMaybe f (concat zs) of - [] -> Nothing - ps -> let (bs, ns) = unzip ps - in if or bs then return (fromInteger (foldr1 lcm ns)) - else Nothing - --- Bug fix for distribution in -2*(x+1) (duplicate result) --- This should be a temporary fix -distributeTimesSomewhere :: Rule Expr -distributeTimesSomewhere = makeSimpleRuleList (name distributeTimes) $ - nub . map cleanUpSimple . applyAll (ruleSomewhere distributeTimes) +removeDivision :: Rule (Relation Expr) +removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $ + describe "remove division" $ + makeRule (lineq, "remove-div") $ flip supply1 timesT $ \eq -> do + xs <- match sumView (leftHandSide eq) + ys <- match sumView (rightHandSide eq) + -- also consider parts without variables + -- (but at least one participant should have a variable) + zs <- forM (xs ++ ys) $ \a -> do + (_, list) <- match productView a + return [ (hasSomeVar a, e) | e <- list ] + let f (b, e) = do + (_, this) <- match (divView >>> second integerView) e + return (b, this) + case mapMaybe f (concat zs) of + [] -> Nothing + ps -> let (bs, ns) = unzip ps + in if or bs then return (fromInteger (foldr1 lcm ns)) + else Nothing distributeTimes :: Rule Expr -distributeTimes = makeSimpleRuleList "distribution multiplication" $ \expr -> do - new <- applyAll distributionT expr - return (applyD mergeT new) +distributeTimes = describe "distribution multiplication" $ + makeSimpleRuleList (lineq, "distr-times") $ + liftM collectLikeTerms . applyAll distributionT distributeDivision :: Rule Expr -distributeDivision = makeSimpleRule "distribution division" $ \expr -> do - (a, b) <- match divView expr - r <- match rationalView b - xs <- match sumView a - guard (length xs > 1) - let ys = map (/fromRational r) xs - return $ build sumView ys +distributeDivision = describe "distribution division" $ + makeSimpleRule (quadreq, "distr-div") $ \expr -> do + (xs, r) <- match (divView >>> (sumView *** rationalView)) expr + guard (length xs > 1) + let ys = map (/fromRational r) xs + return $ build sumView ys merge :: Rule Expr -merge = makeSimpleRule "merge similar terms" $ \old -> do - new <- apply mergeT old - guard (old /= new) - return new +merge = describe "merge similar terms" $ + makeSimpleRule (lineq, "merge") $ \old -> do + let new = collectLikeTerms old + f = maybe 0 length . match sumView + guard (f old > f new) + return new + +simplerLinearFactor :: Rule Expr +simplerLinearFactor = describe "simpler linear factor" $ + makeSimpleRule (polyeq, "simpler-linfactor") $ \expr -> do + let myView = polyNormalForm rationalView >>> second linearPolyView + (x, (a, b)) <- match myView expr + let d = (if a<0 then negate else id) (gcdFrac a b) + guard (a /= 0 && b /= 0 && d /= 1 && d /= -1) + return $ fromRational d * build myView (x, (a/d, b/d)) ------------------------- --- Old +ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a +ruleFromView s v = makeSimpleRuleList s $ \a -> do + b <- canonicalM v a + guard (a /= b) + return b + +rhsIsZero :: Rule Expr -> Rule (Equation Expr) +rhsIsZero r = makeSimpleRuleList (showId r) $ \(lhs :==: rhs) -> do + guard (rhs == 0) + a <- applyAll r lhs + return (a :==: rhs) + +constantRight :: View Expr a -> View (Equation Expr) (a, Rational) +constantRight v = makeView f g + where + f (lhs :==: rhs) = liftM2 (,) (match v lhs) (match rationalView rhs) + g (a, r) = build v a :==: build rationalView r --- Temporary fix: here we don't care about the terms we apply it to. Only --- use for cleaning up -distributionOldT :: Transformation Expr -distributionOldT = makeTrans f +bothSidesView :: View a b -> View (Equation a) (Equation b) +bothSidesView v = makeView f (fmap (build v)) where - f (a :*: b) = - case (match sumView a, match sumView b) of - (Just as, Just bs) | length as > 1 || length bs > 1 -> - return $ build sumView [ a .*. b | a <- as, b <- bs ] - _ -> Nothing + f (lhs :==: rhs) = liftM2 (:==:) (match v lhs) (match v rhs) + +findFactor :: Monad m => [Rational] -> m Rational +findFactor rs + | null rs = + fail "no factor" + | all ((==1) . denominator) rs = + return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs + | otherwise = + return $ fromIntegral $ foldr1 lcm $ map denominator rs + +parentNotNegCheck :: Rule (Context Expr) +parentNotNegCheck = minorRule $ makeSimpleRule "parent not negate check" $ \c -> + case up c >>= current of + Just (Negate _) -> Nothing + _ -> Just c + +noDivisionConstant :: Rule Expr +noDivisionConstant = makeSimpleRule (lineq, "no-div-con") f + where + f (a :/: b) | hasNoVar b && hasSomeVar a = + return ((1/b) * a) + f _ = Nothing + +defPowerNat :: Rule Expr +defPowerNat = makeSimpleRule (polyeq, "def-power-nat") f + where + f (Sym _ [Var _, _]) = Nothing -- should not work on x^5 + f (Sym s [a, Nat n]) | isPowerSymbol s = + return (build productView (False, replicate (fromInteger n) a)) f _ = Nothing 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 @@ -10,15 +10,16 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Strategies - ( linearStrategy, linearMixedStrategy, quadraticStrategy - , higherDegreeStrategy, findFactorsStrategy + ( linearStrategy, linearMixedStrategy, linearStrategyG + , quadraticStrategy, quadraticStrategyG + , higherDegreeStrategy, higherDegreeStrategyG + , findFactorsStrategy, findFactorsStrategyG ) where import Prelude hiding (repeat, replicate, fail) -import Common.Apply import Common.Strategy import Common.Navigator -import Common.Transformation +import Common.Id import Common.Uniplate (transform) import Common.View import Common.Context @@ -29,153 +30,154 @@ import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Polynomial.CleanUp +import Data.Maybe +import Common.Rewriting ------------------------------------------------------------ -- Linear equations -linearStrategy :: LabeledStrategy (Equation Expr) -linearStrategy = linearStrategyWith False +linearStrategy :: LabeledStrategy (Context (Equation Expr)) +linearStrategy = cleanUpStrategy (applyTop (fmap cleanUpSimple)) linearStrategyG -linearMixedStrategy :: LabeledStrategy (Equation Expr) -linearMixedStrategy = linearStrategyWith True +linearMixedStrategy :: LabeledStrategy (Context (Equation Expr)) +linearMixedStrategy = + let f = applyTop (fmap (transform (simplify mixedFractionView) . cleanUpSimple)) + cfg = [ (byName ruleNormalizeMixedFraction, Reinsert) + , (byName ruleNormalizeRational, Remove) + ] + in cleanUpStrategy f (configureNow (configure cfg linearStrategyG)) -linearStrategyWith :: Bool -> LabeledStrategy (Equation Expr) -linearStrategyWith mixed = cleanUpStrategy (fmap clean) $ - label "Linear Equation" - $ label "Phase 1" (repeat ( - removeDivision - <|> ruleMulti distributeTimesSomewhere - <|> ruleMulti merge)) +linearStrategyG :: IsTerm a => LabeledStrategy (Context a) +linearStrategyG = + label "Linear Equation" $ + label "Phase 1" (repeat ( + use removeDivision + <|> multi (showId distributeTimes) (somewhere (useC parentNotNegCheck <*> use distributeTimes)) + <|> multi (showId merge) (once (use merge)))) <*> label "Phase 2" (repeat ( - (flipEquation |> varToLeft) - <|> coverups)) - <*> try (ruleMulti final) - where - coverups = coverUpPlus id <|> coverUpTimes <|> coverUpNegate - (clean, final) - | mixed = - ( transform (simplify mixedFractionView) . cleanUpSimple - , ruleNormalizeMixedFraction - ) - | otherwise = - (cleanUpSimple, ruleNormalizeRational) - --- helper strategy -coverUpPlus :: (Rule (Equation Expr) -> Rule a) -> Strategy a -coverUpPlus f = alternatives $ map (f . ($ oneVar)) - [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] - + (use flipEquation |> use varToLeft) + <|> use (coverUpPlusWith oneVar) + <|> use (coverUpMinusLeftWith oneVar) + <|> use (coverUpMinusRightWith oneVar) + <|> use coverUpTimes + <|> use coverUpNegate + )) + <*> repeat (once + ( use ruleNormalizeRational + <|> remove (use ruleNormalizeMixedFraction) + )) + ------------------------------------------------------------ -- Quadratic equations quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) -quadraticStrategy = cleanUpStrategy (change cleanUpRelation) $ - label "Quadratic Equation Strategy" $ - repeat $ -- Relaxed strategy: even if there are "nice" factors, allow use of square formula - ( fromEquation generalForm - <|> mapRules (liftRule (contextView (switchView equationView))) generalABCForm - ) - |> fromEquation zeroForm - |> fromEquation constantForm - |> simplifyForm - |> fromEquation topForm +quadraticStrategy = + cleanUpStrategy (applyTop cleanUpRelations) quadraticStrategyG + +quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a) +quadraticStrategyG = + label "Quadratic Equation Strategy" $ repeat $ + -- Relaxed strategy: even if there are "nice" factors, allow use of quadratic formula + somewhere (generalForm <|> generalABCForm) + |> somewhere zeroForm + |> somewhere constantForm + |> simplifyForm + |> topForm where - fromEquation = mapRules (liftToContext . liftRule (switchView equationView)) - - -- ax^2 + bx + c == 0, without square formula + -- ax^2 + bx + c == 0, without quadratic formula generalForm = label "general form" $ - ruleOnce commonFactorVar - <|> ruleOnce noLinFormula{- or coverup -} - <|> ruleOnce simplerPoly <|> remove (ruleOnce bringAToOne) - <|> ruleOnce niceFactors - <|> coverUpPower -- to deal with special case x^2=0 + use commonFactorVar + <|> use noLinFormula + <|> use simplerPolynomial + <|> remove (use bringAToOne) + <|> use niceFactors + <|> use coverUpPower -- to deal with special case x^2=0 + + generalABCForm = label "abc form" $ + useC abcFormula - generalABCForm = label "abc form" abcFormula - zeroForm = label "zero form" $ - toStrategy mulZero + use mulZero -- expr == c - constantForm = label "constant form" $ - -- coverUpPower <|> -- never used, see coverUpPower rule in general form - ruleOnce coverUpTimes <|> coverUpPlus ruleOnce - <|> ruleOnce coverUpNegate <|> ruleOnce coverUpNumerator - <|> squareBothSides <|> ruleOnce factorLeftAsSquare - + constantForm = label "constant form" $ + use (coverUpPlusWith oneVar) + <|> use (coverUpMinusLeftWith oneVar) + <|> use (coverUpMinusRightWith oneVar) + <|> use coverUpTimes + <|> use coverUpNegate + <|> use coverUpNumerator + <|> use squareBothSides + <|> use factorLeftAsSquare + -- simplifies square roots, or do an approximation - simplifyForm = (fromEquation $ - label "square root simplification" $ - toStrategy (ruleMulti2 (ruleSomewhere simplerSquareRoot))) - <|> remove (label "approximate result" $ - toStrategy $ liftToContext (ruleMulti ruleApproximate)) + simplifyForm = + label "square root simplification" ( + multi (showId simplerSquareRoot) (somewhere (use simplerSquareRoot))) + <|> + remove (label "approximate result" ( + multi (showId ruleApproximate) (somewhere (use ruleApproximate)))) topForm = label "top form" $ - ( ruleOnce2 (ruleSomewhere merge) - <|> ruleOnce cancelTerms - <|> sameFactor <|> ruleOnce sameConFactor - <|> ruleMulti2 (ruleSomewhere distributionSquare) - <|> ruleMulti2 distributeTimesSomewhere - <|> ruleMulti2 (ruleSomewhere distributeDivision) - <|> ruleOnce flipEquation) - |> (ruleOnce moveToLeft <|> remove (ruleOnce prepareSplitSquare)) - -- to do: find a better location in the strategy for splitting the square - + somewhere (use cancelTerms <|> use sameFactor) + |> ( somewhere (use sameConFactor) + <|> multi (showId merge) (somewhere (use merge)) + <|> somewhere (use distributionSquare) + <|> multi (showId distributeTimes) (somewhere + (useC parentNotNegCheck <*> use distributeTimes)) + <|> multi (showId distributeDivision) (somewhere + (once (use distributeDivision))) + <|> somewhere (use flipEquation) + ) + |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare)) + ----------------------------------------------------------- -- Higher degree equations higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) -higherDegreeStrategy = - label "higher degree" $ - higherForm <*> label "quadratic" ({-option (check isQ2 <*> -} quadraticStrategy) - <*> - cleanUpStrategy (change cleanUpRelation) (label "afterwards" (try (substBackVar <*> f (repeat coverUpPower)))) - where - higherForm = cleanUpStrategy (change cleanUpRelation) $ - label "higher degree form" $ - repeat (f (toStrategy allPowerFactors) |> - (f (alternatives list) <|> liftRule specialV (ruleOrCtxOnce higherSubst)) - |> f (toStrategy (ruleOnce moveToLeft))) - list = map toStrategy - [ coverUpPower, ruleOnce coverUpTimes - , mulZero, {-ruleOnce2 powerFactor,-} sameFactor - , ruleOnce exposeSameFactor - ] ++ [coverUpPlus ruleOnce] ++ [toStrategy (ruleOnce sameConFactor)] - f = mapRulesS (liftToContext . liftRule (switchView equationView)) - - specialV :: View (Context (OrList (Relation Expr))) (Context (OrList (Equation Expr))) - specialV = contextView (switchView equationView) - -{- -isQ2 :: Context (OrList (Relation Expr)) -> Bool -isQ2 = maybe False isQ . match (switchView equationView) . fromContext - -isQ :: OrList (Equation Expr) -> Bool -isQ = (`belongsTo` quadraticEquationsView) --} +higherDegreeStrategy = + cleanUpStrategy (applyTop cleanUpRelations) higherDegreeStrategyG --- like ruleOnce: TODO, replace! -ruleOrCtxOnce :: Rule (Context a) -> Rule (Context (OrList a)) -ruleOrCtxOnce r = makeSimpleRuleList (name r) $ \ctx -> do - let env = getEnvironment ctx - a <- fromContext ctx - case disjunctions a of - Just xs -> f [] env xs - Nothing -> [] +higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a) +higherDegreeStrategyG = label "higher degree" $ + higherForm + <*> label "quadratic" quadraticStrategyG + <*> afterSubst where - f _ _ [] = [] - f acc env (a:as) = - case applyAll r (newContext env (noNavigator a)) of - [] -> f (a:acc) env as - new -> concatMap (fmapC $ \na -> orList (reverse acc++na:as)) new - fmapC g c = - case fromContext c of - Just a -> [newContext (getEnvironment c) (noNavigator (g a))] - Nothing -> [] + higherForm = label "higher degree form" $ repeat $ + somewhere (use allPowerFactors) + |> somewhere ( + use coverUpPower + <|> use mulZero + <|> use sameFactor + <|> use coverUpTimes + <|> use exposeSameFactor + <|> use (coverUpPlusWith oneVar) + <|> use (coverUpMinusLeftWith oneVar) + <|> use (coverUpMinusRightWith oneVar) + <|> use sameConFactor + <|> useC higherSubst) + |> somewhere (use moveToLeft) + + afterSubst = label "afterwards" $ try $ + useC substBackVar <*> repeat (somewhere (use coverUpPower)) ----------------------------------------------------------- -- Finding factors in an expression -findFactorsStrategy :: LabeledStrategy Expr -findFactorsStrategy = cleanUpStrategy cleanUpSimple $ - label "find factors" $ - repeat (niceFactorsNew <|> commonFactorVarNew) +findFactorsStrategy :: LabeledStrategy (Context Expr) +findFactorsStrategy = cleanUpStrategy (applyTop cleanUpSimple) $ + label "find factors" $ replicate 10 $ try findFactorsStrategyG + +findFactorsStrategyG :: IsTerm a => LabeledStrategy (Context a) +findFactorsStrategyG = label "find factor step" $ + somewhereTimes $ + use niceFactorsNew <|> use commonFactorVarNew + <|> use factorVariablePower <|> use simplerLinearFactor + +somewhereTimes :: IsStrategy f => f (Context a) -> Strategy (Context a) +somewhereTimes = somewhereWith "SomewhereTimes" $ \c -> + if isTimesC c then [0 .. arity c-1] else [] + +isTimesC :: Context a -> Bool +isTimesC = maybe False (isJust . isTimes :: Term -> Bool) . currentT diff --git a/src/Domain/Math/Polynomial/Tests.hs b/src/Domain/Math/Polynomial/Tests.hs --- a/src/Domain/Math/Polynomial/Tests.hs +++ b/src/Domain/Math/Polynomial/Tests.hs @@ -9,49 +9,37 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Math.Polynomial.Tests where +module Domain.Math.Polynomial.Tests (tests) where -import Control.Monad -import Common.Apply -import Common.Exercise -import Common.Context -import Common.Strategy -import Common.Derivation +import Common.TestSuite import Common.View -import Domain.Math.Data.Relation -import Domain.Math.Data.OrList -import Domain.Math.Clipboard -import Domain.Math.Expr -import Domain.Math.Examples.DWO1 -import Domain.Math.Examples.DWO2 -import Domain.Math.Polynomial.Exercises -import Domain.Math.Polynomial.IneqExercises import Domain.Math.Polynomial.Generators import Domain.Math.Polynomial.Views -import Domain.Math.Numeric.Laws import Domain.Math.Numeric.Views -import Domain.Logic.Formula +import Domain.Math.Numeric.Laws import Test.QuickCheck -import Data.Maybe ------------------------------------------------------------ -- Testing instances -tests :: IO () +tests :: TestSuite tests = do let v = viewEquivalent (polyViewWith rationalView) testNumLawsWith v "polynomial" (sized polynomialGen) -- see the derivations for the DWO exercise set +{- seeLE n = printDerivation linearExercise $ concat linearEquations !! (n-1) seeQE n = printDerivation quadraticExercise $ orList $ return $ build equationView $ concat quadraticEquations !! (n-1) seeHDE n = printDerivation higherDegreeExercise $ orList $ return $ build equationView $ higherDegreeEquations !! (n-1) -- test strategies with DWO exercise set +{- testLE = concat $ zipWith (f linearExercise) [1..] $ concat linearEquations testQE = concat $ zipWith (f quadraticExercise) [1..] $ map (orList . return . build equationView) $ concat quadraticEquations testHDE = concat $ zipWith (f higherDegreeExercise) [1..] $ map (orList . return . build equationView) higherDegreeEquations - +-} +f :: (Show b, Show a) => Exercise a -> b -> a -> [b] f s n e = map p (g (applyAll (strategy s) (inContext s e))) where g xs | null xs = error $ show n ++ ": " ++ show e | otherwise = xs @@ -84,13 +72,13 @@ goQE = eqTest ineqQuadraticExercise --eqTest :: Exercise a -> IO () -eqTest ex = do +eqTest ex = forM_ (examples ex) $ \eq -> do let tree = derivationTree (strategy ex) (inContext ex eq) forM_ (derivations tree) $ \d -> do let xs = terms d pp = maybe "??" (prettyPrinter ex) . fromContext - forM ([ (a, b) | a <- xs, b <- xs ]) $ \(a, b) -> do + forM [ (a, b) | a <- xs, b <- xs ] $ \(a, b) -> if equalityIneq a b -- equivalence ex (fromContext a) (fromContext b) then putChar '.' else error $ unlines ["", pp a, pp b] @@ -113,4 +101,4 @@ -- temporary fix g (p :&&: q) = g p :&&: g q g (p :||: q) = g p :||: g q - g p = p + g p = p -} 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 @@ -10,9 +10,9 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Views - ( polyView, polyViewFor, polyViewWith, polyViewForWith - , quadraticView, quadraticViewFor, quadraticViewWith, quadraticViewForWith - , linearView, linearViewFor, linearViewWith, linearViewForWith + ( polyView, polyViewWith -- polyViewFor, polyViewForWith + , quadraticView, quadraticViewWith --, quadraticViewFor quadraticViewForWith + , linearView, linearViewWith -- linearViewFor linearViewForWith , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView , monomialPolyView, binomialPolyView, trinomialPolyView , polyNormalForm @@ -22,22 +22,22 @@ import Prelude hiding ((^)) import Control.Monad -import Common.Apply import Common.View -import Common.Traversable -import Common.Uniplate (transform, uniplate, children) +import Common.Classes +import Common.Rewriting +import Common.Uniplate (transform, descend, children) import Common.Utils (distinct) import Domain.Math.Data.Polynomial import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Expr import Domain.Math.Numeric.Views -import Domain.Math.Equation.CoverUpRules import Domain.Math.Polynomial.CleanUp +import Domain.Math.Equation.CoverUpRules import Data.Maybe import qualified Domain.Math.Data.SquareRoot as SQ import Domain.Math.SquareRoot.Views -import Domain.Math.Power.Views (powerFactorViewForWith) +import Domain.Math.Power.OldViews (powerFactorViewForWith) ------------------------------------------------------------------- -- Polynomial view @@ -45,22 +45,15 @@ polyView :: View Expr (String, Polynomial Expr) polyView = polyViewWith identity -polyViewFor :: String -> View Expr (Polynomial Expr) -polyViewFor v = polyViewForWith v identity - polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a) -polyViewWith v = makeView f (uncurry g) +polyViewWith v = makeView matchPoly (uncurry buildPoly) where - f expr = do + matchPoly expr = do pv <- selectVar expr - p <- match (polyViewForWith pv v) expr + p <- matchPolyFor pv expr return (pv, p) - g pv = build (polyViewForWith pv v) - -polyViewForWith :: Fractional a => String -> View Expr a -> View Expr (Polynomial a) -polyViewForWith pv v = makeView f g - where - f expr = + + matchPolyFor pv expr = case expr of Var s | pv == s -> Just var Nat n -> Just (fromIntegral n) @@ -71,18 +64,22 @@ a :/: b -> do c <- match v b guard (c /= 0) - guard (pv `notElem` collectVars b) + guard (withoutVar pv b) p <- f a return (fmap (/c) p) - Sym s [a, n] | s == powerSymbol -> + Sym s [a, n] | isPowerSymbol s -> liftM2 power (f a) (matchNat n) _ -> do - guard (pv `notElem` collectVars expr) + guard (withoutVar pv expr) liftM con (match v expr) + where + f = matchPolyFor pv - g = build sumView . map h . reverse . terms - h (a, n) = build v a .*. (Var pv .^. fromIntegral n) + buildPoly pv = + let f (a, n) = build v a .*. (Var pv .^. fromIntegral n) + in build sumView . map f . reverse . terms + matchNat expr = do n <- match integralView expr guard (n >= 0) @@ -94,36 +91,24 @@ quadraticView :: View Expr (String, Expr, Expr, Expr) quadraticView = quadraticViewWith identity -quadraticViewFor :: String -> View Expr (Expr, Expr, Expr) -quadraticViewFor v = quadraticViewForWith v identity - quadraticViewWith :: Fractional a => View Expr a -> View Expr (String, a, a, a) quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> makeView f g where f (s, (a, b, c)) = return (s, a, b, c) g (s, a, b, c) = (s, (a, b, c)) -quadraticViewForWith :: Fractional a => String -> View Expr a -> View Expr (a, a, a) -quadraticViewForWith pv v = polyViewForWith pv v >>> quadraticPolyView - ------------------------------------------------------------------- -- Linear view linearView :: View Expr (String, Expr, Expr) linearView = linearViewWith identity -linearViewFor :: String -> View Expr (Expr, Expr) -linearViewFor v = linearViewForWith v identity - linearViewWith :: Fractional a => View Expr a -> View Expr (String, a, a) linearViewWith v = polyViewWith v >>> second linearPolyView >>> makeView f g where f (s, (a, b)) = return (s, a, b) g (s, a, b) = (s, (a, b)) -linearViewForWith :: Fractional a => String -> View Expr a -> View Expr (a, a) -linearViewForWith pv v = polyViewForWith pv v >>> linearPolyView - ------------------------------------------------------------------- -- Views on polynomials (degree) @@ -166,17 +151,31 @@ polynomialList p = map (`coefficient` p) [d, d-1 .. 0] where d = degree p -list1 (a) = [a] -list2 (a, b) = [a, b] -list3 (a, b, c) = [a, b, c] +list1 :: a -> [a] +list1 a = [a] + +list2 :: (a, a) -> [a] +list2 (a, b) = [a, b] + +list3 :: (a, a, a) -> [a] +list3 (a, b, c) = [a, b, c] + +list4 :: (a, a, a, a) -> [a] list4 (a, b, c, d) = [a, b, c, d] -isList1 [a] = Just a -isList1 _ = Nothing -isList2 [a, b] = Just (a, b) -isList2 _ = Nothing -isList3 [a, b, c] = Just (a, b, c) -isList3 _ = Nothing +isList1 :: [a] -> Maybe a +isList1 [a] = Just a +isList1 _ = Nothing + +isList2 :: [a] -> Maybe (a, a) +isList2 [a, b] = Just (a, b) +isList2 _ = Nothing + +isList3 :: [a] -> Maybe (a, a, a) +isList3 [a, b, c] = Just (a, b, c) +isList3 _ = Nothing + +isList4 :: [a] -> Maybe (a, a, a, a) isList4 [a, b, c, d] = Just (a, b, c, d) isList4 _ = Nothing @@ -248,85 +247,77 @@ in build productView (False, map make xs) :==: 0 higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr) -higherDegreeEquationsView = makeView f (fmap g) +higherDegreeEquationsView = makeView f (fmap (:==: 0)) where - f = let make (a :==: b) = orList (filter (not . hasNegSqrt) $ map cleanUpExpr2 (normHDE (a-b))) - in Just . normalize . join . fmap make . cuRules + f = Just . normalize . join . fmap make . coverUpOrs + make = orList . filter (not . hasNegSqrt) + . map (cleanUpExpr . distr) . normHDE . sub + sub (a :==: b) = a-b - g = (:==: 0) - - cuRules :: OrList (Equation Expr) -> OrList (Equation Expr) - cuRules xs = - let new = fmap (fmap (cleanUpExpr2 . distr)) xs in - case msum (map (`apply` new) coverUpRulesOr) of - Just ys -> cuRules ys - Nothing -> new + distr = transform g + where + g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c) + g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c) + g a = a hasNegSqrt :: Expr -> Bool hasNegSqrt (Sqrt a) = case match rationalView a of Just r | r < 0 -> True _ -> hasNegSqrt a -hasNegSqrt (Sym s [a, b]) | s == rootSymbol = +hasNegSqrt (Sym s [a, b]) | isRootSymbol s = case (match rationalView a, match integerView b) of (Just r, Just n) | r < 0 && even n -> True _ -> hasNegSqrt a || hasNegSqrt b hasNegSqrt a = any hasNegSqrt (children a) -distr :: Expr -> Expr -distr = transform f - where - f ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c) - f ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c) - f a = a - normHDE :: Expr -> [Expr] normHDE e = case match (polyViewWith rationalView) e of - Just (x, p) -> g x p + Just (x, p) -> normPolynomial x p Nothing -> fromMaybe [e] $ do (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0) return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] - where - g :: String -> Polynomial Rational -> [Expr] - g x p - | d==0 = [] - | length (terms p) <= 1 = [Var x] - | d==1 = [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)] - | d==2 = let [a,b,c] = [ coefficient n p | n <- [2,1,0] ] - discr = b*b - 4*a*c - sdiscr = SQ.sqrtRational discr - in if discr < 0 then [] else - map ((Var x .+.) . build (squareRootViewWith rationalView)) - [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr) - , SQ.scale (1/(2*a)) (SQ.con b - sdiscr) - ] - | otherwise = - case terms p of - [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> - let list = [(c, 0), (b, 1), (a, e2 `div` e1)] - newp = sum (map (\(x, y) -> scale x (power var y)) list) - sub = map (substitute (x, Var x^fromIntegral e1)) - in concatMap normHDE (sub (g x newp)) - [(c, 0), (a, n)] - | odd n -> if c/a >= 0 - then [Var x + root (fromRational (c/a)) (fromIntegral n)] - else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)] - | even n -> if c/a > 0 - then [] - else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n) - , Var x - root (fromRational (abs (c/a))) (fromIntegral n) - ] - _ -> - case factorize p of - ps | length ps > 1 -> concatMap (g x) ps - _ -> [build (polyViewWith rationalView) (x, p)] - where - d = degree p - + +normPolynomial :: String -> Polynomial Rational -> [Expr] +normPolynomial x p + | degree p == 0 = + [] + | length (terms p) <= 1 = + [Var x] + | degree p == 1 = + [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)] + | degree p == 2 = + let [a,b,c] = [ coefficient n p | n <- [2,1,0] ] + discr = b*b - 4*a*c + sdiscr = SQ.sqrtRational discr + in if discr < 0 then [] else + map ((Var x .+.) . build (squareRootViewWith rationalView)) + [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr) + , SQ.scale (1/(2*a)) (SQ.con b - sdiscr) + ] + | otherwise = + case terms p of + [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> + let list = [(c, 0), (b, 1), (a, e2 `div` e1)] + newp = sum (map (\(y, z) -> scale y (power var z)) list) + sub = map (substitute (x, Var x^fromIntegral e1)) + in concatMap normHDE (sub (normPolynomial x newp)) + [(c, 0), (a, n)] + | odd n -> if c/a >= 0 + then [Var x + root (fromRational (c/a)) (fromIntegral n)] + else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)] + | even n -> if c/a > 0 + then [] + else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n) + , Var x - root (fromRational (abs (c/a))) (fromIntegral n) + ] + _ -> + case factorize p of + ps | length ps > 1 -> concatMap (normPolynomial x) ps + _ -> [build (polyViewWith rationalView) (x, p)] + substitute :: (String, Expr) -> Expr -> Expr substitute (s, a) (Var b) | s==b = a -substitute pair expr = f (map (substitute pair) cs) - where - (cs, f) = uniplate expr +substitute pair expr = descend (substitute pair) expr diff --git a/src/Domain/Math/Power/Equation/Exercises.hs b/src/Domain/Math/Power/Equation/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Equation/Exercises.hs @@ -0,0 +1,101 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Equation.Exercises + ( powerEqExercise + , expEqExercise + , logEqExercise + , higherPowerEqExercise + ) where + +import Prelude hiding ( (^) ) + +import Common.Context +import Common.Exercise +import Common.View +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.Views +import Domain.Math.Examples.DWO4 +import Domain.Math.Expr hiding (isPower) +import Domain.Math.Numeric.Views +import Domain.Math.Power.Rules +import Domain.Math.Power.Equation.Strategies +import Domain.Math.Power.Equation.NormViews + + +------------------------------------------------------------ +-- Exercises + +powerEqExercise :: Exercise (Relation Expr) +powerEqExercise = let precision = 2 in makeExercise + { status = Provisional + , parser = parseExprWith (pRelation pExpr) + , strategy = powerEqApproxStrategy + , navigation = termNavigator + , exerciseId = describe "solve power equation algebraically with x > 0" $ + newId "algebra.manipulation.exponents.equation" + , examples = concatMap (map $ build equationView) $ + powerEquations ++ [last higherPowerEquations] + , isReady = solvedRelation + , isSuitable = (`belongsTo` (normPowerEqApproxView precision)) + , equivalence = viewEquivalent (normPowerEqApproxView precision) + } + +expEqExercise :: Exercise (Equation Expr) +expEqExercise = makeExercise + { status = Provisional + , parser = parseExprWith (pEquation pExpr) + , strategy = expEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve exponential equation algebraically" $ + newId "algebra.manipulation.exponential.equation" + , examples = concat expEquations + , isReady = \ rel -> isVariable (leftHandSide rel) + && rightHandSide rel `belongsTo` rationalView + , isSuitable = (`belongsTo` normExpEqView) + , equivalence = viewEquivalent normExpEqView + , ruleOrdering = ruleOrderingWithId [ getId root2power ] + } + +logEqExercise :: Exercise (OrList (Relation Expr)) +logEqExercise = makeExercise + { status = Provisional + , parser = parseExprWith (pOrList (pRelation pExpr)) + , strategy = logEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve logarithmic equation algebraically" $ + newId "algebra.manipulation.logarithmic.equation" + , examples = map (orList . return . build equationView) (concat logEquations) + , isReady = solvedRelations + , isSuitable = (`belongsTo` (switchView equationView >>> normLogEqView)) + , equivalence = viewEquivalent (switchView equationView >>> normLogEqView) + , ruleOrdering = ruleOrderingWithId [ getId calcPower + , getId calcRoot ] + } + +higherPowerEqExercise :: Exercise (OrList (Equation Expr)) +higherPowerEqExercise = makeExercise + { status = Provisional + , parser = parseExprWith (pOrList (pEquation pExpr)) + , strategy = higherPowerEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve higher power equation algebraically" $ + newId "algebra.manipulation.exponents.equation" + , examples = map (orList . return) $ concat $ init higherPowerEquations + , isReady = solvedRelations + , isSuitable = maybe False and . disjunctions . fmap (`belongsTo` normPowerEqView) + , equivalence = let f = normalize . fmap (simplify normPowerEqView') + in \ x y -> f x == f y + , ruleOrdering = ruleOrderingWithId [ getId calcPower + , getId calcRoot ] + } + diff --git a/src/Domain/Math/Power/Equation/NormViews.hs b/src/Domain/Math/Power/Equation/NormViews.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Equation/NormViews.hs @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Equation.NormViews +{- ( normPowerEqApproxView + , normPowerEqView + , normExpEqView + , normLogEqView +-- , normLogView + ) -} where + +import Common.Classes +import Common.View +import Common.Rewriting hiding (rewrite) +import Control.Arrow ( (>>^) ) +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ratio +import Domain.Math.Approximation +import Domain.Math.Data.OrList +import Domain.Math.Data.PrimeFactors +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Views +import Domain.Math.Power.NormViews +import Domain.Math.Power.Utils +import Domain.Math.Power.Views +import Domain.Math.Simplification hiding (simplify, simplifyWith) + +import Common.Uniplate + +-- Change to configurable strategy! +normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr) +normPowerEqApproxView d = makeView f (uncurry (.~=.)) + where + f rel = case relationType rel of + EqualTo -> fmap (second (simplifyWith (precision d) doubleView)) + $ match (equationView >>> normPowerEqView) rel + Approximately -> return (leftHandSide rel, rightHandSide rel) + _ -> Nothing + +normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0! +normPowerEqView = makeView f (uncurry (:==:)) + where + f expr = do + -- selected var to the left, the rest to the right + (lhs :==: rhs) <- varLeft expr >>= constRight + -- match power + (c, ax) <- match (timesView <&> (identity >>^ (,) 1)) $ + simplify normPowerView lhs + (a, x) <- match myPowerView ax + -- simplify, scale and take root + let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x) + return (a, simplify rationalView y) + + myPowerView = powerView + <&> (rootView >>> second (makeView (\a->Just (1 ./. a)) (1 ./.))) + <&> (identity >>^ \a->(a,1)) + +normPowerEqView' :: View (Equation Expr) (Expr, Expr) -- with x>0! +normPowerEqView' = makeView f (uncurry (:==:)) + where + f expr = do + -- selected var to the left, the rest to the right + (lhs :==: rhs) <- varLeft expr >>= constRight + -- match power + (c, (a, x)) <- match unitPowerView lhs + -- simplify, scale and take root + let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x) + return (a, simplify myRationalView y) + +constRight :: Equation Expr -> Maybe (Equation Expr) +constRight (lhs :==: rhs) = do + (vs, cs) <- fmap (partition hasSomeVar) (match sumView lhs) + let rhs' = rhs .+. build sumView (map neg cs) + return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs' + +negateEq :: Equation Expr -> Equation Expr +negateEq (lhs :==: rhs) = + case lhs of + Negate lhs' -> lhs' :==: neg rhs + _ -> lhs :==: rhs + +varLeft :: Equation Expr -> Maybe (Equation Expr) +varLeft (lhs :==: rhs) = do + (vs, cs) <- fmap (partition hasSomeVar) (match sumView rhs) + return $ lhs .+. build sumView (map neg vs) :==: build sumView cs + +scaleLeft :: Equation Expr -> Maybe (Equation Expr) +scaleLeft (lhs :==: rhs) = + match timesView lhs >>= \(c, x) -> return $ + x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c) + +normExpEqView :: View (Equation Expr) (String, Rational) +normExpEqView = makeView f id >>> linearEquationView + where + try g a = fromMaybe a $ g a + f e = do + let (l :==: r) = try scaleLeft $ try constRight e + return $ case match powerView l of + Just (b, x) -> x :==: simplify normLogView (logBase b r) + Nothing -> l :==: r + +normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr)) +normLogEqView = makeView (liftM g . switch . fmap f) id -- AG: needs to be replaced by higherOrderEqView + where + f expr@(lhs :==: rhs) = return $ + case match logView lhs of + Just (b, x) -> x :==: simplify myRationalView (b .^. rhs) + Nothing -> expr + g = fmap (fmap (simplify myRationalView) . simplify normPowerEqView) + . simplify quadraticEquationsView + +-- liftToOrListView :: View a b -> View (OrList a) (OrList b) +-- liftToOrListView v = makeView (switch . fmap (match v)) () + +normLogView :: View Expr Expr +normLogView = makeView g id + where + g expr = + case expr of + Sym s [x, y] + | isLogSymbol s -> do + b <- match integerView x + let divExp (be, n) = return $ f be y ./. fromInteger n + maybe (Just $ f b y) divExp $ greatestPower b + | otherwise -> Nothing + _ -> Nothing + f b expr= + case expr of + Nat 1 -> Nat 0 + Nat n + | n == b -> Nat 1 + | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) Nat + $ lookup b (allPowers n) + e1 :*: e2 -> f b e1 .+. f b e2 + e1 :/: e2 -> f b e1 .-. f b e2 + Sqrt e -> f b (e .^. (1 ./. 2)) + Negate e -> Negate $ f b e + Sym s [x,y] + | isPowerSymbol s -> y .*. f b x + | isRootSymbol s -> f b (x .^. (1 ./. y)) + _ -> expr + +myRationalView :: View Expr Rational +myRationalView = makeView (return . rewrite simplerPower) id >>> rationalView + +simplerPower :: Expr -> Maybe Expr +simplerPower expr = + case expr of + Sqrt x -> simplerPower $ x .^. (1/2) + Sym s [x, y] + | isRootSymbol s -> simplerPower $ x .^. (1/y) + | isPowerSymbol s -> f + | otherwise -> Nothing + where f | y == 0 || x == 1 = Just 1 + | y == 1 = Just x + | x == 0 = Just 0 + | otherwise = + -- geheel getal + liftM fromRational (match rationalView expr) + `mplus` + -- wortel + do + ry <- match rationalView y + rx <- match rationalView x + guard $ numerator ry == 1 && denominator rx == 1 + liftM fromInteger $ takeRoot (numerator rx) (denominator ry) + `mplus` + -- (a/b)^y -> a^x/b^y + do + (a, b) <- match divView x + return $ build divView (a .^. y, b .^. y) + _ -> Nothing + +-- myRationalView = makeView (exprToNum f) id >>> rationalView +-- where +-- f s [x, y] +-- | isDivideSymbol s = +-- fracDiv x y +-- | isPowerSymbol s = do +-- ry <- match rationalView y +-- rx <- match rationalView x +-- if ry == 0 then return 1 -- 0 +-- else if ry == 1 then return rx -- 1 +-- else if denominator ry == 1 then -- geheel getal +-- let a = x Prelude.^ abs (numerator ry) +-- in return $ if numerator ry < 0 then 1 / a else a +-- else if numerator ry == 1 then -- breuk / root +-- if denominator ry > 1 then +-- if denominator rx == 1 then +-- takeRoot (numerator rx) (denominator ry) -- breuk/root +-- else +-- f powerSymbol [numerator rx, ] / f powerSymbol [] +-- else +-- take +-- else -- no calculation +-- | isRootSymbol s = do +-- n <- match integerView y +-- b <- match integerView x +-- liftM fromInteger $ lookup b $ map swap (allPowers n) +-- f _ _ = Nothing + diff --git a/src/Domain/Math/Power/Equation/Rules.hs b/src/Domain/Math/Power/Equation/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Equation/Rules.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Equation.Rules + ( -- * Power equation rules + commonPower, nthRoot, sameBase, equalsOne, greatestPower + , approxPower, reciprocalFor + ) where + +import Common.Transformation +import Common.Rewriting +import Common.View hiding (simplify) +import Control.Monad +import Domain.Math.Approximation (precision) +import qualified Domain.Math.Data.PrimeFactors as PF +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Utils +import Domain.Math.Power.Views +import Domain.Math.Simplification (simplify) + + +-- | Identifier prefix -------------------------------------------------------- + +powereq :: String +powereq = "algebra.manipulation.exponents.equation" + +-- | Power relation rules ----------------------------------------------------- + +-- | a^x = b^y => a^(x/c) = b^(y/c) where c = gcd x y +commonPower :: Rule (Equation Expr) +commonPower = makeSimpleRule (powereq, "common-power") $ \expr -> do + let v = eqView (powerView >>> second integerView) + ((a, x), (b, y)) <- match v expr + let c = gcd x y + guard $ c > 1 + return $ build v ((a, x `div` c), (b, y `div` c)) + +-- | a^x = n => a^x = b^e +greatestPower :: Rule (Equation Expr) +greatestPower = makeSimpleRule (powereq, "greatest-power") $ \(lhs :==: rhs) -> do + n <- match integerView rhs + (_, x) <- match (powerView >>> second integerView) lhs + (b, e) <- PF.greatestPower n + guard $ gcd x e > 1 + return $ lhs :==: fromInteger b .^. fromInteger e + +-- a^x = c*b^y => a = c*b^(y/x) +nthRoot :: Rule (Equation Expr) +nthRoot = makeSimpleRule (powereq, "nth-root") $ \(lhs :==: rhs) -> do + guard $ hasSomeVar lhs + (a, x) <- match powerView lhs + (c, (b, y)) <- match unitPowerView rhs + return $ a :==: build unitPowerView (c, (b, simplify (y ./. x))) + +-- -- root a x = b => a = b^x +-- nthPower :: Rule (Equation Expr) +-- nthPower = makeSimpleRule (powereq, "nth-power") $ \(lhs :==: rhs) -> do +-- guard $ hasSomeVar lhs +-- (a, x) <- match rootView lhs +-- return $ a :==: rhs .^. x + +-- x = a^x => x ~= d +approxPower :: Rule (Relation Expr) +approxPower = makeRule (powereq, "approx-power") $ approxPowerT 2 + +-- x = a^x => x ~= d +approxPowerT :: Int -> Transformation (Relation Expr) +approxPowerT n = makeTrans $ \ expr -> + match equationView expr >>= f + where + f (Var x :==: d) = + match doubleView d >>= Just . (Var x .~=.) . Number . precision n + f (d :==: Var x) = + match doubleView d >>= Just . (.~=. Var x) . Number . precision n + f _ = Nothing + +-- -- a*x + c = b*y + d => a*x - b*y = d - c (move vars to the left, cons to the right) +-- varLeftConRight :: Rule (Equation Expr) +-- varLeftConRight = makeSimpleRule (powereq, "var-left-con-right") $ +-- \(lhs :==: rhs) -> do +-- (xs, cs) <- fmap (partition hasSomeVar) (match sumView lhs) +-- (ys, ds) <- fmap (partition hasSomeVar) (match sumView rhs) +-- guard $ length cs > 0 || length ys > 0 +-- return $ fmap collectLikeTerms $ +-- build sumView (xs ++ map neg ys) :==: build sumView (ds ++ map neg cs) + +-- a^x = a^y => x = y +sameBase :: Rule (Equation Expr) +sameBase = makeSimpleRule (powereq, "same-base") $ \ expr -> do + ((a, x), (b, y)) <- match (eqView powerView) expr + guard $ a == b + return $ x :==: y + +-- | c*a^x = d*(1/a)^y => c*a^x = d*a^-y +-- this reciprocal rule is more strict, it demands a same base on the lhs +-- of the equation. Perhaps do this via the enviroment? +reciprocalFor :: Rule (Equation Expr) +reciprocalFor = makeSimpleRule (powereq, "reciprocal-for-base") $ + \ (lhs :==: rhs) -> do + (_, (a, _)) <- match unitPowerView lhs + (one, _) <- match divView rhs + (d, (a'', y)) <- match consPowerView rhs + guard $ one == 1 && a'' == a + return $ lhs :==: d .*. a'' .^. negate y + +-- | a^x = 1 => x = 0 +equalsOne :: Rule (Equation Expr) +equalsOne = makeSimpleRule (powereq, "equals-one") $ \ (lhs :==: rhs) -> do + guard $ rhs == 1 + (_, x) <- match powerView lhs + return $ x :==: 0 + diff --git a/src/Domain/Math/Power/Equation/Strategies.hs b/src/Domain/Math/Power/Equation/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Equation/Strategies.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Equation.Strategies + -- ( powerEqStrategy + -- , powerEqApproxStrategy + -- , expEqStrategy + -- , logEqStrategy + -- , higherPowerEqStrategy + -- ) + where + +import Prelude hiding (repeat, not) + +import Common.Classes +import Common.Context +import Common.Id +import Common.Navigator +import Common.Rewriting +import Common.Strategy +import Common.View (belongsTo) +import Control.Arrow +import Data.Maybe +import Domain.Math.Data.Relation +import Domain.Math.Data.OrList +import Domain.Math.Expr +import Domain.Math.Equation.CoverUpExercise +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy) +import Domain.Math.Polynomial.Rules (flipEquation) +import Domain.Math.Power.Rules +import Domain.Math.Power.Utils +import Domain.Math.Power.Equation.Rules +import Domain.Math.Numeric.Rules + +-- | Strategies --------------------------------------------------------------- + +powerEqStrategy :: IsTerm a => LabeledStrategy (Context a) +powerEqStrategy = cleanUpStrategy clean strat + where + strat = label "Power equation" $ repeat + $ myCoverUpStrategy + <*> option (use greatestPower <*> use commonPower) + <*> use nthRoot + <*> remove (label "useApprox" $ try $ use approxPower) + + clean = applyD $ exhaustiveUse rules + rules = onePower : fractionPlus : naturalRules ++ rationalRules + +powerEqApproxStrategy :: LabeledStrategy (Context (Relation Expr)) +powerEqApproxStrategy = label "Power equation with approximation" $ + configureNow (configure cfg powerEqStrategy) + where + cfg = [ (byName (newId "useApprox"), Reinsert) ] + +expEqStrategy :: LabeledStrategy (Context (Equation Expr)) +expEqStrategy = cleanUpStrategy cleanup strat + where + strat = label "Exponential equation" + $ myCoverUpStrategy + <*> repeat (somewhereNotInExp (use factorAsPower)) + <*> repeat (somewhereNotInExp (use reciprocal)) + <*> powerS + <*> (use sameBase <|> use equalsOne) + <*> linearStrategy + + cleanup = applyD (exhaustiveUse $ naturalRules ++ rationalRules) + . applyTop (fmap (mergeConstantsWith isIntRatio)) + + isIntRatio x = x `belongsTo` myIntegerView || x `belongsTo` v + where v = divView >>> first myIntegerView >>> second myIntegerView + + powerS = exhaustiveUse [ root2power, addExponents, subExponents + , mulExponents, simpleAddExponents ] + +logEqStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) +logEqStrategy = label "Logarithmic equation" + $ use logarithm + <*> try (use flipEquation) + <*> repeat (somewhere $ use nthRoot + <|> use calcPower + <|> use calcPowerPlus + <|> use calcPowerMinus + <|> use calcPlainRoot + <|> use calcPowerRatio) + <*> quadraticStrategy + + +higherPowerEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +higherPowerEqStrategy = cleanUpStrategy cleanup coverUpStrategy + where + cleanup = applyTop $ fmap $ fmap cleanUpExpr + + + +-- | Help functions ----------------------------------------------------------- + +myCoverUpStrategy :: IsTerm a => Strategy (Context a) +myCoverUpStrategy = repeat $ alternatives $ map use coverUpRules + +somewhereNotInExp :: IsStrategy f => f (Context a) -> Strategy (Context a) +somewhereNotInExp = somewhereWith "somewhere but not in exponent" f + where + f a = if isPowC a then [1] else [0 .. arity a-1] + isPowC = maybe False (isJust . isPower :: Term -> Bool) . currentT diff --git a/src/Domain/Math/Power/Exercises.hs b/src/Domain/Math/Power/Exercises.hs --- a/src/Domain/Math/Power/Exercises.hs +++ b/src/Domain/Math/Power/Exercises.hs @@ -9,32 +9,37 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- + module Domain.Math.Power.Exercises - ( simplifyPowerExercise + ( -- * Power exercises + simplifyPowerExercise , powerOfExercise - , nonNegExpExercise + , nonNegBrokenExpExercise , calcPowerExercise ) where -import Common.Apply +import Prelude hiding ( (^) ) + +import Common.Classes import Common.Context import Common.Exercise import Common.Navigator +import Common.Rewriting import Common.Strategy hiding (not, replicate) import Common.Utils (distinct) import Common.View import Data.Maybe import Domain.Math.Examples.DWO3 -import Domain.Math.Expr +import Domain.Math.Expr hiding (isPower) import Domain.Math.Numeric.Views import Domain.Math.Power.Rules import Domain.Math.Power.Strategies +import Domain.Math.Power.NormViews import Domain.Math.Power.Views -import Prelude hiding ( (^) ) ------------------------------------------------------------- --- Exercises +-- | Exercises ---------------------------------------------------------------- + powerExercise :: LabeledStrategy (Context Expr) -> Exercise Expr powerExercise s = makeExercise { status = Provisional @@ -44,82 +49,84 @@ } simplifyPowerExercise :: Exercise Expr -simplifyPowerExercise = (powerExercise powerStrategy) - { description = "simplify expression (powers)" - , exerciseCode = makeCode "math" "simplifyPower" +simplifyPowerExercise = (powerExercise simplifyPowerStrategy) + { exerciseId = describe "simplify expression (powers)" $ + newId "algebra.manipulation.exponents.simplify" , isReady = isPowerAdd - , isSuitable = (`belongsTo` normPowerView') - , equivalence = viewEquivalent normPowerView' - , examples = concat $ simplerPowers ++ powers1 ++ powers2 + , isSuitable = (`belongsTo` normPowerMapView) + , equivalence = viewEquivalent normPowerMapView + , examples = concat $ simplerPowers + ++ powers1 ++ powers2 ++ negExp1 ++ negExp2 ++ normPower1 ++ normPower2 ++ normPower3 + , ruleOrdering = ruleOrderingWithId $ map getId + [ root2power, subExponents, reciprocalVar, addExponents + , mulExponents, distributePower ] } powerOfExercise :: Exercise Expr powerOfExercise = (powerExercise powerOfStrategy) - { description = "write as a power of a" - , exerciseCode = makeCode "math" "powerOf" + { exerciseId = describe "write as a power of a" $ + newId "algebra.manipulation.exponents.powerof" , isReady = isSimplePower , isSuitable = (`belongsTo` normPowerView) , equivalence = viewEquivalent normPowerNonNegRatio - , examples = concat $ powersOfA ++ powersOfX ++ brokenExp1' - ++ brokenExp2 ++ brokenExp3 ++ normPower5' - ++ normPower6 + , examples = concat $ powersOfA ++ powersOfX + ++ brokenExp1' ++ brokenExp2 ++ brokenExp3 + ++ normPower5' ++ normPower6 + , ruleOrdering = ruleOrderingWithId $ map getId + [ root2power, addExponents, subExponents, mulExponents + , distributePower, reciprocalVar ] } -nonNegExpExercise :: Exercise Expr -nonNegExpExercise = (powerExercise nonNegExpStrategy) - { description = "write with a non-negative exponent" - , exerciseCode = makeCode "math" "nonNegExp" - , isReady = isPower natView +nonNegBrokenExpExercise :: Exercise Expr +nonNegBrokenExpExercise = (powerExercise nonNegBrokenExpStrategy) + { exerciseId = describe "write with a non-negative exponent" $ + newId "algebra.manipulation.exponents.nonnegative" + , isReady = isPower plainNatView , isSuitable = (`belongsTo` normPowerNonNegDouble) , equivalence = viewEquivalent normPowerNonNegDouble , examples = concat $ nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 - ++ brokenExp1 ++ normPower4' ++ normPower5 + ++ brokenExp1 + ++ normPower4' ++ normPower5 + , ruleOrdering = ruleOrderingWithId [ getId mulExponents + , getId reciprocalFrac + , getId reciprocalInv + , getId power2root + , getId distributePower ] } calcPowerExercise :: Exercise Expr calcPowerExercise = (powerExercise calcPowerStrategy) - { description = "simplify expression (powers)" - , exerciseCode = makeCode "math" "calcPower" + { exerciseId = describe "simplify expression (powers)" $ + newId "arithmetic.exponents" , isReady = isPowerAdd - , isSuitable = (`belongsTo` normPowerView') - , equivalence = viewEquivalent normPowerView' + , isSuitable = (`belongsTo` normPowerMapView) + , equivalence = viewEquivalent normPowerMapView , examples = concat $ negExp3 ++ normPower3' ++ normPower4 } ----------------------------------------------------------------------- --- Ready checks +-- | Ready checks ------------------------------------------------------------- isSimplePower :: Expr -> Bool -isSimplePower (Sym s [Var _,y]) | s==powerSymbol = y `belongsTo` rationalView +isSimplePower (Sym s [Var _, y]) + | isPowerSymbol s = y `belongsTo` rationalView isSimplePower _ = False isPower :: View Expr a -> Expr -> Bool isPower v expr = - let Just (_, xs) = match productView expr - f (Nat 1 :/: a) = g a - f a = g a - g (Sym s [Var _, a]) | s==powerSymbol = isJust (match v a) - g (Sym s [x, Nat _]) | s==rootSymbol = isPower v x - g (Sqrt x) = g x - g (Var _) = True - g a = a `belongsTo` rationalView - in distinct (concatMap collectVars xs) && all f xs + let Just (_, xs) = match productView expr + f (Nat 1 :/: a) = g a + f a = g a + g (Sym s [Var _, a]) | isPowerSymbol s = isJust (match v a) + g (Sym s [x, Nat _]) | isRootSymbol s = isPower v x + g (Sqrt x) = g x + g (Var _) = True + g a = a `belongsTo` rationalView + in distinct (concatMap vars xs) && all f xs isPowerAdd :: Expr -> Bool isPowerAdd expr = let Just xs = match sumView expr in all (isPower rationalView) xs && not (applicable calcPowerPlus expr) - --- test stuff -{- -showDerivations ex = mapM_ (putStrLn . showDerivation ex) - -showAllDerivations ex = - mapM_ (\es -> putStrLn (replicate 80 '-') >> showDerivations ex es) - -a = Var "a" -b = Var "b" --} diff --git a/src/Domain/Math/Power/NormViews.hs b/src/Domain/Math/Power/NormViews.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/NormViews.hs @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.NormViews + ( -- * Normalising views + normPowerView, normPowerMapView, normPowerNonNegRatio + , normPowerNonNegDouble + ) where + +import Prelude hiding ((^), recip) +import qualified Prelude +import Control.Monad +import Common.View +import Data.List +import qualified Data.Map as M +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Utils + +type PowerMap = (M.Map String Rational, Rational) + + +normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational) +normPowerNonNegRatio = makeView (liftM swap . f) (g . swap) + where + f expr = + case expr of + Sym s [a,b] + | isPowerSymbol s -> do + (r, m) <- f a + if r==1 + then do + r2 <- match rationalView b + return (1, M.map (*r2) m) + else do + n <- match integerView b + if n >=0 + then return (r Prelude.^ n, M.map (*fromIntegral n) m) + else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m) + | isRootSymbol s -> + f (Sym powerSymbol [a, 1/b]) + Sqrt a -> + f (Sym rootSymbol [a,2]) + a :*: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + return (r1*r2, M.unionWith (+) m1 m2) + a :/: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + guard (r2 /= 0) + return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) + Var s -> return (1, M.singleton s 1) + Nat n -> return (toRational n, M.empty) + Negate x -> do + (r, m) <- f x + return (negate r, m) + _ -> do + r <- match rationalView expr + return (fromRational r, M.empty) + g (r, m) = + let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ] + in build productView (False, fromRational r : xs) + +-- | AG: todo: change double to norm view for rationals +normPowerNonNegDouble :: View Expr (Double, M.Map String Rational) +normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g + where + roundof n (x, m) = (fromInteger (round (x * 10.0 ** n)) / 10.0 ** n, m) + f expr = + case expr of + Sym s [a,b] + | isPowerSymbol s -> do + (x, m) <- f a + y <- match rationalView b + return (x ** fromRational y, M.map (*y) m) + | isRootSymbol s -> f (Sym powerSymbol [a, 1/b]) + Sqrt a -> f (Sym rootSymbol [a,2]) + a :*: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + return (r1*r2, M.unionWith (+) m1 m2) + a :/: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + guard (r2 /= 0) + return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) + Var s -> return (1, M.singleton s 1) + Negate x -> do + (r, m) <- f x + return (negate r, m) + _ -> do + d <- match doubleView expr + return (d, M.empty) + g (r, m) = + let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ] + in build productView (False, fromDouble r : xs) + +normPowerMapView :: View Expr [PowerMap] +normPowerMapView = makeView (liftM h . f) g + where + f = (mapM (match normPowerNonNegRatio) =<<) . match sumView + g = build sumView . map (build normPowerNonNegRatio) + h :: [PowerMap] -> [PowerMap] + h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy (\x y -> fst x == fst y) . sort + +normPowerView :: View Expr (String, Rational) +normPowerView = makeView f g + where + f expr = + case expr of + Sym s [x,y] + | isPowerSymbol s -> do + (s2, r) <- f x + r2 <- match rationalView y + return (s2, r*r2) + | isRootSymbol s -> + f (x^(1/y)) + Sqrt x -> + f (Sym rootSymbol [x, 2]) + Var s -> return (s, 1) + x :*: y -> do + (s1, r1) <- f x + (s2, r2) <- f y + guard (s1==s2) + return (s1, r1+r2) + Nat 1 :/: y -> do + (s, r) <- f y + return (s, -r) + x :/: y -> do + (s1, r1) <- f x + (s2, r2) <- f y + guard (s1==s2) + return (s1, r1-r2) + _ -> Nothing + + g (s, r) = Var s .^. fromRational r + diff --git a/src/Domain/Math/Power/OldViews.hs b/src/Domain/Math/Power/OldViews.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/OldViews.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.OldViews where + +import Common.Rewriting +import Common.View +import Control.Monad +import Domain.Math.Expr hiding ( (^) ) + +powerFactorView :: View Expr (String, Expr, Int) +powerFactorView = powerFactorViewWith identity + +powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int) +powerFactorViewWith v = makeView f g + where + f expr = do + pv <- selectVar expr + (e, n) <- match (powerFactorViewForWith pv v) expr + return (pv, e, n) + g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n) + +powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int) +powerFactorViewForWith pv v = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just (1, 1) + Negate e -> do + (a, b) <- f e + return (negate a, b) + e1 :*: e2 -> do + (a1, b1) <- f e1 + (a2, b2) <- f e2 + return (a1*a2, b1+b2) + Sym s [e1, Nat n] + | isPowerSymbol s -> do + (a1, b1) <- f e1 + a <- match v (build v a1 ^ toInteger n) + return (a, b1 * fromInteger n) + _ -> do + guard (withoutVar pv expr) + a <- match v expr + return (a, 0) + + g (a, b) = build v a .*. (Var pv .^. fromIntegral b) diff --git a/src/Domain/Math/Power/Rules.hs b/src/Domain/Math/Power/Rules.hs --- a/src/Domain/Math/Power/Rules.hs +++ b/src/Domain/Math/Power/Rules.hs @@ -9,46 +9,97 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- + module Domain.Math.Power.Rules ( -- * Power rules calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents - , subExponents, distributePower, distributePowerDiv, zeroPower, reciprocal - , reciprocalInv + , subExponents, distributePower, distributePowerDiv, reciprocal + , reciprocalInv, reciprocalFrac, calcPowerRatio, calcRoot, simplifyPower + , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar + , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents -- * Root rules - , power2root, root2power, distributeRoot, mulRoot, mulRootCom, divRoot - , simplifyRoot + , power2root, root2power + -- * Log rules + , logarithm -- * Common rules - , myFractionTimes, simplifyFraction, pushNegOut - -- * Help functions - , smartRule + , myFractionTimes, pushNegOut ) where import Prelude hiding ( (^) ) import qualified Prelude -import Common.Apply + +import Common.Classes import Control.Arrow ( (>>^) ) +import Common.Id import Common.Transformation import Common.View import Control.Monad import Data.List import Data.Maybe +import qualified Domain.Math.Data.PrimeFactors as PF +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Numeric.Views +import Domain.Math.Power.Utils import Domain.Math.Power.Views -import Domain.Math.Polynomial.CleanUp +-- | Identifier prefixes ------------------------------------------------------ + +power, logarithmic :: String +power = "algebra.manipulation.exponents" +logarithmic = "algebra.manipulation.logarithmic" + + -- | Power rules -------------------------------------------------------------- +-- n => a^e (with e /= 1) +factorAsPower :: Rule Expr +factorAsPower = makeSimpleRuleList (power, "factor-as-power") $ \ expr -> do + n <- matchM myIntegerView expr + (a, x) <- PF.allPowers $ toInteger n + if n > 0 + then return $ fromInteger a .^. fromInteger x + else if odd x + then return $ fromInteger (negate a) .^. fromInteger x + else fail "Could not factorise number." + calcPower :: Rule Expr -calcPower = makeSimpleRule "calculate power" $ \ expr -> do - (e1, e2) <- match simplePowerView expr - a <- match rationalView e1 - x <- match integralView e2 - if x > 0 - then return $ fromRational $ a Prelude.^ x - else return $ 1 ./. (e1 .^. neg e2) +calcPower = makeSimpleRule "arithmetic.operation.rational.power" $ \ expr -> do + (a, x) <- match (powerViewWith rationalView plainNatView) expr + return $ fromRational $ a Prelude.^ x +-- | a^(x/y) => (a^x)^(1/y) +calcPowerRatio :: Rule Expr +calcPowerRatio = makeSimpleRule (power, "power-ratio") $ \ expr -> do + let v = powerView >>> second (rationalView >>> plainRationalView) + (a, (x, y)) <- match v expr + guard $ x /= 1 && y /= 1 + return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y) + +-- -- | root n x +calcPlainRoot :: Rule Expr +calcPlainRoot = makeSimpleRule (power, "root") $ \ expr -> do + (n, x) <- match (rootView >>> (integerView *** integerView)) expr + y <- takeRoot n x + return $ fromInteger y + +-- | [root n x, ... ] +calcRoot :: Rule (OrList Expr) +calcRoot = makeSimpleRuleList (power, "root") $ \ ors -> + fromMaybe [] (disjunctions ors) >>= maybeToList . f + where + f expr = do + (n, x) <- match (rootView >>> (integerView *** integerView)) expr + y <- liftM fromInteger $ lookup n $ map swap $ PF.allPowers (abs x) + let ys | x > 0 && even n = [y, negate y] + | x > 0 && odd n = [y] + | x < 0 && odd n = [negate y] + | otherwise = [] + roots <- toMaybe (not. null) ys + return $ orList roots + calcPowerPlus :: Rule Expr calcPowerPlus = makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus @@ -57,227 +108,213 @@ calcPowerMinus = makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus --- | a*x^y * b*x^q = a*b * x^(y+q) -addExponents :: Rule Expr -addExponents = makeSimpleRuleList "add exponents" $ \ expr -> do - case match (powerFactorisationView unitPowerView) expr of - Just (s, fs) -> do - (e, es) <- split (*) fs - case apply addExponents' e of - Just e' -> return $ build productView (s, e' : es) - Nothing -> fail "" - Nothing -> fail "" +addExponents :: Rule Expr +addExponents = makeSimpleRuleList (power, "add-exponents") $ \ expr -> do + (sign, fs) <- matchM (powerFactorView isPow) expr + ((x, y), fill) <- twoNonAdjacentHoles fs + prod <- applyM addExponentsT $ x * y + return $ build productView (sign, fill prod) +isPow :: Expr -> Expr -> Bool +isPow x y = x `belongsTo` myIntegerView && + (y `belongsTo` varView || y `belongsTo` powerView) + -- | a*x^y * b*x^q = a*b * x^(y+q) -addExponents' :: Rule Expr -addExponents' = makeSimpleRule "add exponents" $ \ expr -> do - x <- selectVar expr - (e1, e2) <- match timesView expr - (a, y) <- match (unitPowerForView x) e1 - (b, q) <- match (unitPowerForView x) e2 - return $ build (unitPowerForView x) (a .*. b, y + q) - +addExponentsT :: Transformation Expr +addExponentsT = makeTrans $ \ expr -> do + (e1, e2) <- match timesView expr + (a, (x, y)) <- match unitPowerView e1 + (b, (x', q)) <- match unitPowerView e2 + guard $ x == x' + return $ build unitPowerView (a .*. b, (x, y .+. q)) + +simpleAddExponents :: Rule Expr +simpleAddExponents = makeRule (power, "simple-add-exponents") addExponentsT + -- | a*x^y / b*x^q = a/b * x^(y-q) subExponents :: Rule Expr -subExponents = forallVars rule - where - rule x = makeSimpleRule "sub exponents" $ \ expr -> do - (e1, e2) <- match divView expr - (a, y) <- match (unitPowerForView x) e1 - (b, q) <- match (unitPowerForView x) e2 - return $ build (unitPowerForView x) (a ./. b, y - q) +subExponents = makeSimpleRule (power, "sub-exponents") $ \ expr -> do + (e1, e2) <- match divView expr + (a, (x, y)) <- match unitPowerView e1 + (b, (x', q)) <- match unitPowerView e2 + guard $ x == x' + return $ build unitPowerView (a ./. b, (x, y .-. q)) --- | (c*a^x)^y = c*a^(x*y) +-- | (a^x)^y = a^(x*y) mulExponents :: Rule Expr -mulExponents = makeSimpleRule "mul exponents" $ \ expr -> do - (cax, y) <- match simplePowerView expr - (c, (a, x)) <- match strictPowerView cax - guard (c == 1 || c == -1) - selectVar a - return $ build strictPowerView (c, (a, x .*. y)) +mulExponents = makeSimpleRule (power, "mul-exponents") $ \ expr -> do + ((a, x), y) <- match (strictPowerView >>> first powerView) expr + return $ build powerView (a, x .*. y) --- | c*(a0..an)^y = c * a0^y * a1^y .. * an^y +-- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x distributePower :: Rule Expr -distributePower = makeSimpleRule "distribute power" $ \ expr -> do - (c, (as', y)) <- match strictPowerView expr - y' <- match integerView y - (sign, as) <- match productView as' - guard (length as > 1) - return $ build productView - (if sign then odd y' else False, c : map (\a -> a .^. y) as) +distributePower = makeSimpleRule (power, "distr-power") $ \ expr -> do + ((sign, as), x) <- match (powerViewWith productView identity) expr + guard $ length as > 1 + let y = build productView (False, map (\a -> build powerView (a, x)) as) + return $ + maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x --- | c * (a/b)^y = c * (a^y / b^y) +-- | (a/b)^y = (a^y / b^y) distributePowerDiv :: Rule Expr -distributePowerDiv = makeSimpleRule "distribute power" $ \ expr -> do - (c, (ab, y)) <- match strictPowerView expr - match integerView y - (a, b) <- match divView ab - return $ c .*. build divView (a .^. y, b .^. y) +distributePowerDiv = makeSimpleRule (power, "distr-power-div") $ \ expr -> do + ((a, b), y) <- match (powerViewWith divView identity) expr + return $ build divView (build powerView (a, y), build powerView (b, y)) --- | c*a^0 = c +-- | a^0 = 1 zeroPower :: Rule Expr -zeroPower = makeSimpleRule "zero power" $ \ expr -> do - (_, (c, y)) <- match strictPowerView expr - y' <- match integerView y - guard (y'==0) - return c +zeroPower = makeSimpleRule (power, "power-zero") $ \ expr -> do + (_, x) <- match powerView expr + guard $ x == 0 + return 1 --- | d/c*a^x = d*a^(-x)/c -reciprocal :: Rule Expr -reciprocal = makeSimpleRule "reciprocal" $ \ expr -> do - a <- selectVar expr - (d, cax) <- match divView expr - (c, x) <- match (unitPowerForView a) cax - return $ build (unitPowerForView a) (d ./. c, negate x) +-- a ^ 1 = a +onePower :: Rule Expr +onePower = makeSimpleRule (power, "power-one") $ \ expr -> do + (a, x) <- match powerView expr + guard $ x == 1 + return a --- | c*a^x = c/a^(-x) -reciprocalInv :: (Expr -> Bool) -> Rule Expr -reciprocalInv p = makeSimpleRule "reciprocal" $ \ expr -> do - guard (p expr) --- a <- selectVar expr - (c, (a, x)) <- match strictPowerView expr - return $ c ./. build strictPowerView (1, (a, neg x)) +-- 1 ^ x = 1 +powerOne :: Rule Expr +powerOne = makeSimpleRule (power, "one-power") $ \ expr -> do + (a, _) <- match powerView expr + guard $ a == 1 + return a +-- 0 ^ x = 0 with x > 0 +powerZero :: Rule Expr +powerZero = makeSimpleRule (power, "one-power") $ \ expr -> do + (a, x) <- match (powerViewWith identity integerView) expr + guard $ x > 0 && a == 0 + return 0 +-- | all of the above simplification rules +simplifyPower :: Rule Expr +simplifyPower = makeSimpleRuleList (power, "simplify") $ \ expr -> + mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero] + +-- | e/a = e*a^(-1) where a is an variable +reciprocalVar :: Rule Expr +reciprocalVar = makeSimpleRule (power, "reciprocal-var") $ \ expr -> do + (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr + return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c + +-- | c/a^x = c*a^x^(-1) +reciprocalPower :: Rule Expr +reciprocalPower = makeSimpleRule (power, "reciprocal-power") $ \ expr -> do + (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr + return $ (e .*. build consPowerView (1, (a, neg x))) ./. c + +-- | Use with care, will match any fraction! +reciprocal :: Rule Expr +reciprocal = makeSimpleRule (power, "reciprocal") $ + apply (reciprocalForT identity) + +-- | a/b = a*b^(-1) +reciprocalForT :: View Expr a -> Transformation Expr +reciprocalForT v = makeTrans $ \ expr -> do + (a, b) <- match divView expr + guard $ b `belongsTo` v + return $ a .*. build powerView (b, -1) + +-- | a^x = 1/a^(-x) +reciprocalInv :: Rule Expr +reciprocalInv = makeSimpleRule (power, "reciprocal-inverse") $ \ expr -> do + guard $ hasNegExp expr + (a, x) <- match strictPowerView expr + return $ 1 ./. build strictPowerView (a, neg x) + +-- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r... +reciprocalFrac :: Rule Expr +reciprocalFrac = makeSimpleRule (power, "reciprocal-frac") $ \ expr -> do + (e1, e2) <- match divView expr + (s, xs) <- match productView e2 + let (ys, zs) = partition hasNegExp xs + guard (not $ null ys) + return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs) + where + f e = case match consPowerView e of + Just (c, (a, x)) -> build consPowerView (c, (a, neg x)) + Nothing -> e + +-- | a^x / b^x = (a/b)^x +divBase :: Rule Expr +divBase = describe "divide base of root" $ + makeSimpleRule (power, "divide-base") $ \ expr -> do + (e1, e2) <- match divView expr + (c1, (a, x)) <- match consPowerView e1 + (c2, (b, x')) <- match consPowerView e2 + guard $ x == x' && b /= 0 + return $ build consPowerView (c1 .*. c2, (a ./. b, x)) + +-- | (-a)^x = -(a^x) +pushNegOut :: Rule Expr +pushNegOut = makeSimpleRule (power, "push-negation-out") $ \ expr -> do + (a, x) <- match (powerViewWith identity integerView) expr + a' <- isNegate a + return $ (if odd x then neg else id) $ build powerView (a', fromInteger x) + + -- | Root rules ---------------------------------------------------------------- -- | a^(p/q) = root (a^p) q -power2root :: Rule Expr -power2root = makeSimpleRule "write as root" $ \ expr -> do - (a, pq) <- match simplePowerView expr - (p, q) <- match (rationalView >>> ratioView) pq - guard (q /= 1) - return $ let n = Nat . fromIntegral in root (a .^. n p) $ n q +power2root :: Rule Expr +power2root = makeSimpleRule (power, "write-as-root") $ \ expr -> do + (a, (p, q)) <- match (strictPowerView >>> second divView) expr + guard $ q /= 1 + return $ root (a .^. p) q --- | root (a^p) q = a^(p/q) +-- | root a q = a^(1/q) root2power :: Rule Expr -root2power = makeSimpleRule "write as power" $ \ expr -> do - (ap, q) <- match rootView expr - a <- selectVar ap - p <- match (powerViewFor' a) ap - return $ build (powerViewFor' a) (fromRational (p / q)) +root2power = makeSimpleRule (power, "write-as-power") $ \ expr -> do + (a, q) <- match strictRootView expr + return $ a .^. (1 ./. q) --- | root (a/b) x = root a x / root b x -distributeRoot :: Rule Expr -distributeRoot = makeSimpleRule "distribute root" $ \ expr -> do - (ab, x) <- match rootView expr - (a, b) <- match divView ab - return $ build divView (build rootView (a, x), build rootView (b, x)) --- | c1 root a x * c2 root b x = c1*c2 * root (a*b) x -mulRoot :: Rule Expr -mulRoot = makeSimpleRule "multipy base of root" $ \ expr -> do - (r1, r2) <- match timesView expr - (c1, (a, x)) <- match rootConsView r1 - (c2, (b, x')) <- match rootConsView r2 - guard (x == x') - return $ build rootConsView (c1 .*. c2, (a .*. b, x)) - --- | commutative version of the mulRoot rule -mulRootCom :: Rule Expr -mulRootCom = makeCommutative (myProductView (powerFactorisationView rootView)) (.*.) mulRoot - where - myProductView :: View Expr (Bool, [Expr]) -> View Expr [Expr] - myProductView v = v >>> makeView f g - where - f (s, (x:xs)) = return $ if s then neg x : xs else x:xs - f _ = fail "" - g = (,) False - --- | c1 * root a x / c2 * root b x = c1*c2 * root (a/b) x -divRoot :: Rule Expr -divRoot = makeSimpleRule "divide base of root" $ \ expr -> do - (r1, r2) <- match divView expr - (c1, (a, x)) <- match rootConsView r1 - (c2, (b, x')) <- match rootConsView r2 - guard (x == x' && b /= 0) - return $ build rootConsView (c1 .*. c2, (a ./. b, x)) +-- | Logarithmic relation rules ----------------------------------------------- --- | root 0 x = 0 ; root 1 x = 1 ; root a 1 = a -simplifyRoot :: Rule Expr -simplifyRoot = makeSimpleRule "simplify root" $ \e -> f e `mplus` g e - where - f expr = do - (e1, _) <- match rootView expr - x <- match integerView e1 - case x of - 0 -> Just 0 - 1 -> Just 1 - _ -> Nothing - g expr = do - (e1, e2) <- match rootView expr - if e2 == 1 then Just e1 else Nothing +logarithm :: Rule (Equation Expr) +logarithm = makeSimpleRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do + (b, x) <- match logView lhs + return $ x :==: build powerView (b, rhs) -- | Common rules -------------------------------------------------------------- -- | a/b * c/d = a*c / b*d (b or else d may be one) myFractionTimes :: Rule Expr -myFractionTimes = smartRule $ makeSimpleRule "fraction times" $ \ expr -> do +myFractionTimes = smartRule $ makeSimpleRule (power, "fraction-times") $ \ expr -> do (e1, e2) <- match timesView expr - guard $ isJust $ match divView e1 `mplus` match divView e2 + guard $ e1 `belongsTo` divView || e2 `belongsTo` divView (a, b) <- match (divView <&> (identity >>^ \e -> (e,1))) e1 (c, d) <- match (divView <&> (identity >>^ \e -> (e,1))) e2 --- (a, b) <- match divView e1 --- (c, d) <- match divView e2 return $ build divView (a .*. c, b .*. d) --- | simplify expression -simplifyFraction :: Rule Expr -simplifyFraction = makeSimpleRule "simplify fraction" $ \ expr -> do - let expr' = simplifyWith (second normalizeProduct) productView $ expr - guard (expr /= expr') - guard $ not $ applicable myFractionTimes expr' -- a hack, need to come up with a constructive solution - return expr' --- | (-a)^x = (-)a^x -pushNegOut :: Rule Expr -pushNegOut = makeSimpleRule "push negation out" $ \ expr -> do - (a, x) <- match simplePowerView expr - a' <- isNegate a - x' <- match integerView x - return $ (if odd x' then neg else id) $ build simplePowerView (a', x) - - -- | Help functions ----------------------------------------------------------- -smartRule :: Rule Expr -> Rule Expr -smartRule = doAfter f - where - f (a :*: b) = a .*. b - f (a :/: b) = a ./. b - f (Negate a) = neg a - f (a :+: b) = a .+. b - f (a :-: b) = a .-. b - f e = e - calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr calcBinPowerRule opName op m = - makeSimpleRule ("calculate power " ++ opName) $ \e -> do - (e1, e2) <- m e - (a, (c1, x)) <- match unitPowerView e1 - (b, (c2, y)) <- match unitPowerView e2 - guard (a == b && x == y) - return (build unitPowerView (a, ((op c1 c2), x))) + makeSimpleRule (power, "calc-power", opName) $ \e -> do + (e1, e2) <- m e + (c1, (a, x)) <- match unitPowerViewVar e1 + (c2, (b, y)) <- match unitPowerViewVar e2 + guard $ a == b && x == y + return $ build unitPowerViewVar (op c1 c2, (a, x)) +-- use twoNonAdHoles instead of split ??? makeCommutative :: View Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr -makeCommutative view op rule = - makeSimpleRuleList (name rule) $ \ expr -> do +makeCommutative view op r = + makeSimpleRuleList (getId r) $ \ expr -> case match view expr of Just factors -> do (e, es) <- split op factors - case apply rule e of + case apply r e of Just e' -> return $ build view (e' : es) - Nothing -> fail "" - Nothing -> fail "" - -split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])] -split op xs = f xs - where - f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys - | otherwise = [] - f [] = [] + Nothing -> [] + Nothing -> [] -forallVars :: (String -> Rule Expr) -> Rule Expr -forallVars ruleFor = makeSimpleRuleList (name (ruleFor "")) $ \ expr -> - mapMaybe (\v -> apply (ruleFor v) expr) $ collectVars expr +hasNegExp :: Expr -> Bool +hasNegExp expr = fromMaybe False $ + fmap ((< 0) . snd . snd) (match consPowerView expr) diff --git a/src/Domain/Math/Power/Strategies.hs b/src/Domain/Math/Power/Strategies.hs --- a/src/Domain/Math/Power/Strategies.hs +++ b/src/Domain/Math/Power/Strategies.hs @@ -9,148 +9,77 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- + module Domain.Math.Power.Strategies - ( powerStrategy + ( -- * Power strategies + simplifyPowerStrategy , powerOfStrategy , calcPowerStrategy - , nonNegExpStrategy + , nonNegBrokenExpStrategy ) where -import Common.Apply +import Prelude hiding (repeat, not) + +import Common.Classes import Common.Context +import Common.Id +import Common.Navigator import Common.Strategy import Common.Transformation -import Common.View import Domain.Math.Expr +import Domain.Math.Numeric.Rules (divisionNumerator, divisionDenominator) import Domain.Math.Power.Rules -import Domain.Math.Power.Views -import Domain.Math.Numeric.Rules -import Domain.Math.Numeric.Views -import Prelude hiding (repeat) +import Domain.Math.Power.Utils +import Domain.Math.Simplification ------------------------------------------------------------- --- Strategies -powerStrategy :: LabeledStrategy (Context Expr) -powerStrategy = makeStrategy "simplify" rules cleanupRules - where - rules = powerRules - cleanupRules = calcPower : naturalRules ++ rationalRules +-- | Strategies --------------------------------------------------------------- +simplifyPowerStrategy :: LabeledStrategy (Context Expr) +simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules + powerOfStrategy :: LabeledStrategy (Context Expr) -powerOfStrategy = makeStrategy "write as power of" rules cleanupRules - where - rules = powerRules - cleanupRules = calcPower - : simplifyRoot - : simplifyFraction - : naturalRules - ++ rationalRules +powerOfStrategy = cleanUpStrategyRules "Write as power of" powerRules -nonNegExpStrategy :: LabeledStrategy (Context Expr) -nonNegExpStrategy = makeStrategy "non negative exponent" rules cleanupRules +nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr) +nonNegBrokenExpStrategy = cleanUpStrategy (change cleanup . applyTop cleanup) strategy where - rules = [ addExponents - , subExponents - , mulExponents - , reciprocalInv hasNegExp - , distributePower - , distributePowerDiv - , power2root - , distributeRoot - , zeroPower - , calcPowerPlus - , calcPowerMinus - , myFractionTimes - ] ++ fractionRules - cleanupRules = calcPower : simplifyFraction : naturalRules + rs = [ addExponents, subExponents, mulExponents, reciprocalInv + , distributePower, distributePowerDiv, power2root, zeroPower + , calcPowerPlus, calcPowerMinus + ] + strategy = label "Write with non-negative exponent" $ exhaustiveStrategy rs + cleanup = applyD divisionNumerator + . applyD myFractionTimes + . mergeConstants + . simplifyWith simplifyConfig {withMergeAlike = False} calcPowerStrategy :: LabeledStrategy (Context Expr) -calcPowerStrategy = makeStrategy "calcPower" rules cleanupRules +calcPowerStrategy = cleanUpStrategy cleanup strategy where - rules = calcPower - : mulRootCom - : divRoot - : rationalRules - cleanupRules = rationalRules ++ naturalRules + strategy = label "Calculate power" $ exhaustiveStrategy rules + rules = calcPower : divisionDenominator : reciprocalInv : divBase : rationalRules + cleanup = applyTop (applyD myFractionTimes) + . applyD (exhaustiveStrategy $ myFractionTimes : naturalRules) ------------------------------------------------------------- --- | Help functions -makeStrategy :: String -> [Rule Expr] -> [Rule Expr] -> LabeledStrategy (Context Expr) -makeStrategy l rs cs = cleanUpStrategy f $ strategise l rs - where - f = applyD $ strategise l cs - strategise l = label l . repeat . alternatives . map (somewhere . liftToContext) +-- | Rule collections --------------------------------------------------------- +powerRules :: [Rule Expr] powerRules = - [ addExponents - , subExponents - , mulExponents - , distributePower - , zeroPower - , reciprocal - , root2power - , distributeRoot - , calcPower - , calcPowerPlus - , calcPowerMinus - , myFractionTimes - , pushNegOut - ] + [ addExponents, subExponents, mulExponents, distributePower, zeroPower + , reciprocalVar, root2power, calcPower, calcPowerPlus, calcPowerMinus + , pushNegOut + ] -hasNegExp expr = - case match strictPowerView expr of - Just (_, (_, x)) -> case match rationalView x of - Just x' -> x' < 0 - _ -> False - _ -> False +-- | Help functions ----------------------------------------------------------- --- | Allowed numeric rules -naturalRules = - [ calcPlusWith "nat" natView - , calcMinusWith "nat" natView - , calcTimesWith "nat" natView - , calcDivisionWith "nat" natView - , doubleNegate - , negateZero - , plusNegateLeft - , plusNegateRight - , minusNegateLeft - , minusNegateRight - , timesNegateLeft - , timesNegateRight - , divisionNegateLeft - , divisionNegateRight - ] - where - natView = makeView f fromInteger - where - f (Nat n) = Just n - f _ = Nothing - -rationalRules = - [ calcPlusWith "rational" rationalRelaxedForm - , calcMinusWith "rational" rationalRelaxedForm - , calcTimesWith "rational" rationalRelaxedForm - , calcDivisionWith "int" integerNormalForm - , doubleNegate - , negateZero - , divisionDenominator - , divisionNumerator - , simplerFraction - ] - -fractionRules = - [ fractionPlus, fractionPlusScale, fractionTimes - , calcPlusWith "int" integerNormalForm - , calcMinusWith "int" integerNormalForm - , calcTimesWith "int" integerNormalForm -- not needed? - , calcDivisionWith "int" integerNormalForm - , doubleNegate - , negateZero - , smartRule divisionDenominator - , smartRule divisionNumerator - , simplerFraction - ] +cleanUpStrategyRules :: IsId n => n -> [Rule Expr] -> LabeledStrategy (Context Expr) +cleanUpStrategyRules l = + cleanUpStrategy (change cleanUp. applyTop cleanUp) . label l . exhaustiveStrategy + +cleanUp :: Expr -> Expr +cleanUp = mergeConstants + . simplifyWith simplifyConfig {withMergeAlike = False} + diff --git a/src/Domain/Math/Power/Utils.hs b/src/Domain/Math/Power/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Utils.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- some of these help functions may have a broader scope and could be +-- moved to other parts of the framework (eg. Common) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Utils where + +import Prelude hiding (repeat, replicate) + +import Common.Context +import Common.Rewriting +import Common.Strategy hiding (not) +import Common.Transformation +import Common.View +import Control.Monad +import Data.List hiding (repeat, replicate) +import Data.Ratio +import qualified Domain.Math.Data.PrimeFactors as PF +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Rules +import Domain.Math.Numeric.Views + + +-- | Strategy functions ------------------------------------------------------- + +exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a) +exhaustiveStrategy = exhaustiveSomewhere . map liftToContext + +exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b) +exhaustiveUse = exhaustiveSomewhere . map use + +exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a) +exhaustiveSomewhere = repeat . somewhere . alternatives + +-- | Rule functions ----------------------------------------------------------- + +smartRule :: Rule Expr -> Rule Expr +smartRule = doAfter f + where + f (a :*: b) = a .*. b + f (a :/: b) = a ./. b + f (Negate a) = neg a + f (a :+: b) = a .+. b + f (a :-: b) = a .-. b + f e = e + +mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr +mergeConstantsWith p = simplifyWith f productView + where + f (sign, xs) = + let (cs, ys) = partition p xs + c = simplify rationalView $ build productView (False, cs) + in if maybe False (> 1) (match rationalView c) + then (sign, c:ys) + else (sign, xs) + +mergeConstants :: Expr -> Expr +mergeConstants = mergeConstantsWith (`belongsTo` rationalView) + +-- | View functions ----------------------------------------------------------- + +(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b +v <&> w = makeView (\x -> match v x `mplus` match w x) (build v) + +infixl 1 <&> + +plainNatView :: View Expr Integer +plainNatView = makeView f Nat + where + f (Nat n) = Just n + f _ = Nothing + +myIntegerView :: View Expr Integer +myIntegerView = makeView f fromInteger + where + f (Nat n) = Just n + f (Negate (Nat n)) = Just $ negate n + f _ = Nothing + +plainRationalView :: View Rational (Integer, Integer) +plainRationalView = + makeView (\x -> return (numerator x, denominator x)) (uncurry (%)) + +eqView :: View a b -> View (Equation a) (b, b) +eqView v = eqv >>> v *** v + where + eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:)) + + +-- | Rule collections --------------------------------------------------------- + +naturalRules :: [Rule Expr] +naturalRules = + [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView + , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView + , doubleNegate, negateZero , plusNegateLeft, plusNegateRight +-- , minusNegateLeft + , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft + , divisionNegateRight + ] + +rationalRules :: [Rule Expr] +rationalRules = + [ calcPlusWith "rational" rationalRelaxedForm + , calcMinusWith "rational" rationalRelaxedForm + , calcTimesWith "rational" rationalRelaxedForm + , calcDivisionWith "integer" integerNormalForm + , doubleNegate, negateZero, divisionDenominator, divisionNumerator + , simplerFraction + ] + +fractionRules :: [Rule Expr] +fractionRules = + [ fractionPlus, fractionPlusScale, fractionTimes + , calcPlusWith "integer" integerNormalForm + , calcMinusWith "integer" integerNormalForm + , calcTimesWith "integer" integerNormalForm -- not needed? + , calcDivisionWith "integer" integerNormalForm + , doubleNegate, negateZero, smartRule divisionDenominator + , smartRule divisionNumerator, simplerFraction + ] + + +-- | Common functions --------------------------------------------------------- + +takeRoot :: Integer -> Integer -> Maybe Integer +takeRoot n x = do + y <- if (abs n == 1) + then Just 1 + else lookup x $ map swap $ PF.allPowers (abs n) + guard $ n > 0 || (n < 0 && odd x) + return $ if n > 0 then y else negate y + +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) + +split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])] +split op xs = f xs + where + f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys + | otherwise = [] + f [] = [] + +toMaybe :: (a -> Bool) -> a -> Maybe a +toMaybe p x = if p x then Just x else Nothing + +joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]] +joinBy _ [] = [] +joinBy eq xs = ys : joinBy eq (xs \\ ys) + where + ys = dropUntil eq xs + +dropUntil :: (a -> a -> Bool) -> [a] -> [a] +dropUntil _ [] = [] +dropUntil _ [x] = [x] +dropUntil p (x:y:ys) | p x y = x : dropUntil p (y:ys) + | otherwise = [x] + +holes :: [a] -> [(a, [a], a -> [a])] +holes xs = map f [0 .. length xs - 1] + where + f i = let (ys, z:zs) = splitAt i xs + in (z, ys ++ zs, \x -> ys ++ x:zs) + +twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])] +twoNonAdjacentHoles xs = concatMap g pairs + where + pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]] + g (x, y) = let (ys, z:zs) = splitAt x xs + (ps, q:qs) = splitAt (y - x - 1) zs + in if null ps + then [ ((z, q), \a -> ys ++ a:ps ++ qs) ] + else [ ((z, q), \a -> ys ++ a:ps ++ qs) + , ((z, q), \a -> ys ++ ps ++ a:qs) ] 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 @@ -10,345 +10,151 @@ -- ----------------------------------------------------------------------------- -module Domain.Math.Power.Views +module Domain.Math.Power.Views ( -- * Power views - strictPowerView, strictPowerViewFor, powerConsViewFor, powerConsView - , unitPowerView, unitPowerForView, simplePowerView, powerFactorisationView - , powerFactorViewWith, powerViewFor', powerFactorViewForWith - , powerViewFor, powerFactorView - -- * Root views - , rootView, rootConsView - -- * View combinator - , (<&>) - -- * Normalising views - , normPowerView, normPowerView', normPowerNonNegRatio - , normPowerNonNegDouble + powerView, powerViewWith, powerViewForWith, powerViewFor, powerFactorView + , consPowerView, consPowerViewForWith, consPowerViewFor,consPowerViewForVar + , unitPowerViewForVar, unitPowerViewVar, unitPowerView, strictPowerView + , rootView, strictRootView + -- * Log view + , logView -- * Other views - , ratioView, natView + , plainNatView, plainRationalView, varView ) where -import Prelude hiding ((^), recip) -import qualified Prelude import Control.Arrow ( (>>^) ) import Control.Monad +import Common.Rewriting import Common.View -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Ratio import Domain.Math.Expr -import Domain.Math.Numeric.Views +import Domain.Math.Power.Utils --- | Combinator function -(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b -v <&> w = makeView f g - where - f x = match v x `mplus` match w x - g = build v -infixl <&> +-- | Power views with constant factor ----------------------------------------- +consPowerView :: View Expr (Expr, (Expr, Expr)) +consPowerView = addNegativeView $ addUnitTimesView powerView --- | Power views -------------------------------------------------------------- -strictPowerView :: View Expr (Expr, (Expr, Expr)) -strictPowerView = strictPowerConsView - <&> (simplePowerView >>^ (,) 1) - <&> negPowerView - where - strictPowerConsView = timesView >>> second simplePowerView - negPowerView = makeView f g - where - f (Negate expr) = do - (c, ax) <- match (strictPowerConsView <&> (simplePowerView >>^ (,) 1)) expr - return (negate c, ax) - f _ = Nothing - g = build strictPowerView +consPowerViewForWith :: Num a => View Expr a -> View Expr b -> a -> View Expr (Expr, b) +consPowerViewForWith va vb a = + addNegativeView $ addUnitTimesView (powerViewForWith va vb a) -strictPowerViewFor :: String -> View Expr (Expr, Expr) -strictPowerViewFor pv = makeView f g +consPowerViewFor :: Expr -> View Expr (Expr, Expr) +consPowerViewFor = consPowerViewForWith identity identity + +consPowerViewForVar :: String -> View Expr (Expr, Expr) +consPowerViewForVar = consPowerViewFor . Var + +unitPowerViewForVar :: String -> View Expr (Expr, Expr) +unitPowerViewForVar s = makeView f g where f expr = do - (c, (a, x)) <- match strictPowerView expr - guard (Var pv == a) + (c, (s', x)) <- match unitPowerViewVar expr + guard $ s == s' return (c, x) - g (c, x) = build strictPowerView (c, (Var pv, x)) + g (c, x) = build unitPowerViewVar (c , (s, x)) -powerConsViewFor :: String -> View Expr (Expr, Rational) -powerConsViewFor pv = timesView >>> second (powerViewFor' pv) +unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr)) +unitPowerViewWith v = addNegativeView $ addUnitTimesView $ + powerViewWith v identity <&> (unitTimes v >>^ swap) -powerConsView :: View Expr (String, (Expr, Rational)) -powerConsView = makeView f g - where - f expr = do - pv <- selectVar expr - cn <- match (powerConsViewFor pv) expr - return (pv, cn) - g (pv, cn) = build (powerConsViewFor pv) cn - -unitPowerForView :: String -> ViewM Maybe Expr (Expr, Rational) -unitPowerForView pv = powerConsViewFor pv <&> (powerViewFor' pv >>^ (,) 1) +unitPowerViewVar :: View Expr (Expr, (String, Expr)) +unitPowerViewVar = unitPowerViewWith varView -unitPowerView :: ViewM Maybe Expr (String, (Expr, Rational)) -unitPowerView = unitView <&> negUnitView +-- | Careful! This view will match anything, so use it wise and with care. +unitPowerView :: View Expr (Expr, (Expr, Expr)) +unitPowerView = unitPowerViewWith identity + +-- | A root view +rootView :: View Expr (Expr, Expr) +rootView = makeView f (uncurry root) where - unitView = powerConsView <&> (powerView >>^ \(pv, n) -> (pv, (1, n))) - negUnitView = makeView f g - where - f (Negate expr) = do - (a, (c, x)) <- match unitView expr - return (a, (negate c, x)) - f _ = Nothing - g = build unitView + f expr = do + (a, (x, y)) <- match (powerView >>> second divView) expr + guard (x == 1 || x == -1) + return $ if x == 1 then (a, y) else (a, negate y) -simplePowerView :: View Expr (Expr, Expr) -simplePowerView = makeView f g +-- | only matches sqrt and root +strictRootView :: View Expr (Expr, Expr) +strictRootView = makeView f g where f expr = case expr of - Sym s [a, b] | s == powerSymbol -> return (a, b) + Sym s [a, b] | isRootSymbol s -> return (a, b) + Sqrt e -> return (e, 2) _ -> Nothing - g (a, b) = a .^. b + + g (a, b) = if b == 2 then Sqrt a else root a b -powerFactorisationView :: View Expr a -> View Expr (Bool, [Expr]) -powerFactorisationView v = productView >>> second (makeView f id) - where - f es = return $ map (\x -> build productView (False, x)) $ factorise es - factorise :: [Expr] -> [[Expr]] - factorise es = maybe [es] split $ findIndex isPower es - where - split i = let (xs, ys) = splitAt (i+1) es in xs : factorise ys - isPower = isJust . match v --- | Root views --------------------------------------------------------------- +-- | Power views -------------------------------------------------------------- -rootView :: View Expr (Expr, Rational) -rootView = makeView f g - where - f expr = case expr of - Sqrt e -> return (e, 2) - Sym s [a, Nat b] | s == rootSymbol -> return (a, toRational b) +strictPowerView :: View Expr (Expr, Expr) +strictPowerView = makeView f (uncurry (.^.)) + where + f expr = + case expr of + Sym s [a, b] | isPowerSymbol s -> return (a, b) _ -> Nothing - g (a, b) = if b==2 then Sqrt a else root a (fromRational b) -rootConsView :: View Expr (Expr, (Expr, Rational)) -rootConsView = timesView >>> second rootView - <&> (rootView >>^ (,) 1) - +powerView :: View Expr (Expr, Expr) +powerView = makeView f g + where + f = match ((strictRootView >>^ h) <&> strictPowerView) + h (a, b) = (a, 1 ./. b) + g (a, b) = + case b of + (Nat 1 :/: b') -> build strictRootView (a, b') + _ -> build strictPowerView (a, b) --- | Bastiaan's power views --------------------------------------------------- +powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b) +powerViewWith va vb = powerView >>> first va >>> second vb --- | AG: todo: integrate these views with the views above +powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b +powerViewForWith va vb a = makeView f ((build va a .^.) . build vb) + where + f expr = do + (a', b) <- match (powerViewWith va vb) expr + guard $ a == a' + return b -natView :: View Expr Int -natView = makeView f fromIntegral - where - f (Nat n) = Just $ fromInteger n - f _ = Nothing +powerViewFor :: Expr -> View Expr Expr +powerViewFor = powerViewForWith identity identity -ratioView :: View Rational (Int, Int) -ratioView = makeView f g +powerFactorView :: (Expr -> Expr -> Bool) -> View Expr (Bool, [Expr]) +powerFactorView p = productView >>> second (makeView f id) where - f x = return (fromIntegral (numerator x), fromIntegral (denominator x)) - g (n,d) = fromIntegral n % fromIntegral d - -powerView :: View Expr (String, Rational) -powerView = powerViewWith rationalView + f = Just . map (build productView . (,) False) . joinBy p -powerViewWith :: View Expr b -> View Expr (String, b) -powerViewWith v = makeView f g - where - f expr = do - pv <- selectVar expr - n <- match (powerViewForWith' v pv) expr - return (pv, n) - g (pv, n) = build (powerViewForWith' v pv) n - -powerViewFor :: String -> View Expr Int -powerViewFor = powerViewForWith natView -powerViewFor' = powerViewForWith' rationalView +-- | Log views ---------------------------------------------------------------- -powerViewForWith :: Num a => View Expr a -> String -> View Expr a -powerViewForWith v pv = makeView f g - where - f expr = - case expr of - Var s | pv == s -> match v 1 - e1 :*: e2 -> liftM2 (+) (f e1) (f e2) - Sym s [e, n] | s == powerSymbol -> do - n'<- match v n - liftM (* n') (f e) - _ -> Nothing - - g a = Var pv .^. build v a - -powerViewForWith' v pv = makeView f g - where - f expr = - case expr of - Var s | pv == s -> match v 1 - Sym s [Var s', n] | s' == pv && s == powerSymbol -> match v n +logView :: View Expr (Expr, Expr) +logView = makeView f (uncurry logBase) + where + f expr = case expr of + Sym s [a, b] | isLogSymbol s -> return (a, b) _ -> Nothing - - g a = Var pv .^. build v a -powerFactorView :: View Expr (String, Expr, Int) -powerFactorView = powerFactorViewWith identity -powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int) -powerFactorViewWith v = makeView f g - where - f expr = do - pv <- selectVar expr - (e, n) <- match (powerFactorViewForWith pv v) expr - return (pv, e, n) - g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n) - -powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int) -powerFactorViewForWith pv v = makeView f g - where - f expr = - case expr of - Var s | pv == s -> Just (1, 1) - Negate e -> do - (a, b) <- f e - return (negate a, b) - e1 :*: e2 -> do - (a1, b1) <- f e1 - (a2, b2) <- f e2 - return (a1*a2, b1+b2) - Sym s [e1, Nat n] - | s == powerSymbol -> do - (a1, b1) <- f e1 - a <- match v (build v a1 ^ Nat n) - return (a, b1 * fromInteger n) - _ -> do - guard (pv `notElem` collectVars expr) - a <- match v expr - return (a, 0) - - g (a, b) = build v a .*. (Var pv .^. fromIntegral b) - +-- | Help (non-power) views --------------------------------------------------- --- | Normalising views --------------------------------------------------------- +unitTimes :: Num t => View a b -> View a (t, b) +unitTimes = (>>^ (,) 1) -normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational) -normPowerNonNegRatio = makeView (liftM swap . f) (g . swap) - where - swap (x,y) = (y,x) - f expr = - case expr of - Sym s [a,b] - | s==powerSymbol -> do - (r, m) <- f a - if r==1 - then do - r2 <- match rationalView b - return (1, M.map (*r2) m) - else do - n <- match integerView b - if n >=0 - then return (r Prelude.^ n, M.map (*fromIntegral n) m) - else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m) - | s==rootSymbol -> - f (Sym powerSymbol [a, 1/b]) - Sqrt a -> - f (Sym rootSymbol [a,2]) - a :*: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - return (r1*r2, M.unionWith (+) m1 m2) - a :/: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - guard (r2 /= 0) - return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) - Var s -> return (1, M.singleton s 1) - Nat n -> return (toRational n, M.empty) - Negate x -> do - (r, m) <- f x - return (negate r, m) - _ -> do - r <- match rationalView expr - return (fromRational r, M.empty) - g (r, m) = - let xs = map f (M.toList m) - f (s, r) = Var s .^. fromRational r - in build productView (False, fromRational r : xs) +addTimesView :: View Expr a -> View Expr (Expr, a) +addTimesView v = timesView >>> second v --- | AG: todo: change double to norm view for rationals -normPowerNonNegDouble :: View Expr (Double, M.Map String Rational) -normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g - where - roundof n (x, m) = (fromIntegral (round (x * 10.0 ** n)) / 10.0 ** n, m) - f expr = - case expr of - Sym s [a,b] - | s==powerSymbol -> do - (x, m) <- f a - y <- match rationalView b - return (x ** fromRational y, M.map (*y) m) - | s==rootSymbol -> f (Sym powerSymbol [a, 1/b]) - Sqrt a -> f (Sym rootSymbol [a,2]) - a :*: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - return (r1*r2, M.unionWith (+) m1 m2) - a :/: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - guard (r2 /= 0) - return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) - Var s -> return (1, M.singleton s 1) - Negate x -> do - (r, m) <- f x - return (negate r, m) - _ -> do - d <- match doubleView expr - return (d, M.empty) - g (r, m) = - let xs = map f (M.toList m) - f (s, r) = Var s .^. fromRational r - in build productView (False, fromDouble r : xs) +addUnitTimesView :: View Expr a -> View Expr (Expr, a) +addUnitTimesView v = addTimesView v <&> unitTimes v +negateView :: (Num a, WithFunctions a) => View a a +negateView = makeView isNegate negate -type PowerMap = (M.Map String Rational, Rational) +addNegativeView :: View Expr a -> View Expr a +addNegativeView v = v <&> (negateView >>> v) -normPowerView' :: View Expr [PowerMap] -normPowerView' = makeView (liftM h . f) g +varView :: View Expr String +varView = makeView f Var where - f = (mapM (match normPowerNonNegRatio) =<<) . match sumView - g = build sumView . map (build normPowerNonNegRatio) - h :: [PowerMap] -> [PowerMap] - h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy (\x y -> fst x == fst y) . sort - -normPowerView :: View Expr (String, Rational) -normPowerView = makeView f g - where - f expr = - case expr of - Sym s [x,y] - | s==powerSymbol -> do - (s, r) <- f x - r2 <- match rationalView y - return (s, r*r2) - | s==rootSymbol -> - f (x^(1/y)) - Sqrt x -> - f (Sym rootSymbol [x, 2]) - Var s -> return (s, 1) - x :*: y -> do - (s1, r1) <- f x - (s2, r2) <- f y - guard (s1==s2) - return (s1, r1+r2) - Nat 1 :/: y -> do - (s, r) <- f y - return (s, -r) - x :/: y -> do - (s1, r1) <- f x - (s2, r2) <- f y - guard (s1==s2) - return (s1, r1-r2) - _ -> Nothing - - g (s, r) = Var s .^. fromRational r + f (Var s) = Just s + f _ = Nothing 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 @@ -10,16 +10,19 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Simplification - ( Simplify(..), smartConstructors + ( Simplify(..), SimplifyConfig(..), smartConstructors + , simplifyConfig , Simplified, simplified, liftS, liftS2 , simplifyRule + , mergeAlike, distribution, constantFolding + , mergeAlikeSum, mergeAlikeProduct ) where import Common.Context import Common.Navigator import Common.Transformation import Common.Uniplate -import Common.View hiding (simplify) +import Common.View hiding (simplify, simplifyWith) import Control.Monad import Data.List import Data.Maybe @@ -29,29 +32,47 @@ import Domain.Math.SquareRoot.Views import Test.QuickCheck import qualified Common.View as View -import Common.Rewriting + +data SimplifyConfig = SimplifyConfig + { withSmartConstructors :: Bool + , withMergeAlike :: Bool + , withDistribution :: Bool + , withSimplifySquareRoot :: Bool + , withConstantFolding :: Bool + } + class Simplify a where + simplifyWith :: SimplifyConfig -> a -> a simplify :: a -> a + simplify = simplifyWith simplifyConfig +simplifyConfig :: SimplifyConfig +simplifyConfig = SimplifyConfig True True True True True + instance Simplify a => Simplify (Context a) where - simplify = change simplify + simplifyWith cfg = change $ simplifyWith cfg instance Simplify a => Simplify (Equation a) where - simplify = fmap simplify + simplifyWith cfg = fmap $ simplifyWith cfg +instance Simplify a => Simplify (Relation a) where + simplifyWith cfg = fmap $ simplifyWith cfg + instance Simplify a => Simplify [a] where - simplify = fmap simplify + simplifyWith cfg = fmap $ simplifyWith cfg instance Simplify Expr where - simplify = smartConstructors - . mergeAlike - . distribution - . View.simplify (squareRootViewWith rationalView) - . constantFolding + simplifyWith cfg = let optional p f = if p then f else id in + optional (withSmartConstructors cfg) smartConstructors + . optional (withMergeAlike cfg) mergeAlike + . optional (withDistribution cfg) distribution + . optional (withSimplifySquareRoot cfg) (View.simplify + (squareRootViewWith rationalView)) + . optional (withConstantFolding cfg) constantFolding instance Simplify a => Simplify (Rule a) where - simplify = doAfter simplify -- by default, simplify afterwards + simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards data Simplified a = S a deriving (Eq, Ord) @@ -93,7 +114,7 @@ acosh = liftS acosh instance Simplify (Simplified a) where - simplify = id + simplifyWith _ = id instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where toTerm (S x) = toTerm x @@ -127,7 +148,7 @@ Negate a -> neg a a :*: b -> a .*. b a :/: b -> a ./. b - Sym s [a, b] | s == powerSymbol -> + Sym s [a, b] | isPowerSymbol s -> a .^. b _ -> expr @@ -135,8 +156,10 @@ -- Distribution of constants distribution :: Expr -> Expr -distribution = transformTD $ \expr -> - fromMaybe expr $ do +distribution = descend distribution . f + where + f expr = + fromMaybe expr $ case expr of a :*: b -> do (x, y) <- match plusView a @@ -160,8 +183,7 @@ constantFolding expr = case match rationalView expr of Just r -> fromRational r - Nothing -> let (xs, f) = uniplate expr - in f (map constantFolding xs) + Nothing -> descend constantFolding expr ---------------------------------------------------------------------- -- merge alike for sums and products @@ -177,12 +199,13 @@ mergeAlikeProduct :: [Expr] -> [Expr] mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ] - where f [] = [] - f ((Nothing , e):xs) = e:f xs - f ((Just r , _):xs) = - let cs = r : [ c | (Just c , _) <- xs ] - rest = [ x | (Nothing , x) <- xs ] - in build rationalView (product cs):rest + where + f [] = [] + f ((Nothing , e):xs) = e:f xs + f ((Just r , _):xs) = + let cs = r : [ c | (Just c, _) <- xs ] + rest = [ x | (Nothing, x) <- xs ] + in build rationalView (product cs):rest mergeAlikeSum :: [Expr] -> [Expr] mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ] @@ -198,10 +221,10 @@ Nothing -> (r, e) rec [] = [] - rec ((Nothing, e):xs) = e:rec xs - rec ((Just (r, a), e):xs) = new:rec rest + rec ((Nothing, e):ys) = e:rec ys + rec ((Just (r, a), e):ys) = new:rec rest where - (js, rest) = partition (maybe False ((==a) . snd) . fst) xs + (js, rest) = partition (maybe False ((==a) . snd) . fst) ys rs = r:map fst (mapMaybe fst js) new | null js = e | otherwise = build rationalView (sum rs) .*. a diff --git a/src/Domain/Math/SquareRoot/Tests.hs b/src/Domain/Math/SquareRoot/Tests.hs --- a/src/Domain/Math/SquareRoot/Tests.hs +++ b/src/Domain/Math/SquareRoot/Tests.hs @@ -15,12 +15,12 @@ import Test.QuickCheck import Domain.Math.Data.SquareRoot import Domain.Math.Numeric.Laws -import Common.Utils () +import Common.TestSuite ------------------------------------------------------------------- -- Testing -tests :: IO () +tests :: TestSuite tests = testNumLaws "square roots" squareRootGen -- testFracLaws "square roots" squareRootGen 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 @@ -34,7 +34,7 @@ a :*: b -> liftM2 (*) (f a) (f b) a :/: b -> join $ liftM2 fracDiv (f a) (f b) Sqrt a -> fmap sqrtRational (match rationalView a) - Sym s [a, b] | s == powerSymbol -> + Sym s [a, b] | isPowerSymbol s -> liftM2 (^) (f a) (match integerView b) _ -> fmap con (match v expr) diff --git a/src/Domain/RegularExpr/Definitions.hs b/src/Domain/RegularExpr/Definitions.hs deleted file mode 100644 --- a/src/Domain/RegularExpr/Definitions.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.RegularExpr.Definitions where - -import Domain.RegularExpr.Expr -import Common.Uniplate -import Common.Utils (distinct) - -deterministic :: (Show a, Eq a) => RE a -> Bool -deterministic r = deterministicSimple r {- - case (deterministicSimple r, det r) of - (b1, b2) | b1==b2 -> b1 - _ -> error $ show r -} - -deterministicSimple :: Eq a => RE a -> Bool -deterministicSimple regexp = - distinct (lookahead regexp) && all deterministicSimple (children regexp) - -det :: Eq a => RE a -> Bool -det regexp = - case regexp of - EmptySet -> True - Epsilon -> True - Atom _ -> True - Option r -> det (r :|: Epsilon) - Star r -> det r - Plus r -> det (r :*: Star r) - r :|: s -> lookahead r `disj` lookahead s && det r && det s - EmptySet :*: r -> det r - Epsilon :*: r -> det r - Atom _ :*: r -> det r - Option s :*: r -> det ((s :|: Epsilon) :*: r) - Star s :*: r -> lookahead s `disj` lookahead r && det s && det r - Plus s :*: r -> det ((s :*: Star s) :*: r) - (q :|: s) :*: r -> det ((q :*: r) :|: (s :*: r)) - (q :*: s) :*: r -> det (q :*: (s :*: r)) - - -disj xs ys = all (`notElem` xs) ys - -empty :: RE a -> Bool -empty = foldRE (False, True, const (False), const True, const True, id, (&&), (||)) - -lookahead :: RE a -> [a] -lookahead = map fst . firsts - -firsts :: RE a -> [(a, RE a)] -firsts regexp = - case regexp of - EmptySet -> [] - Epsilon -> [] - Atom a -> [(a, Epsilon)] - Option r -> firsts r - Star r -> firsts (nonempty r :*: Star r) - Plus r -> firsts (r :*: Star r) - r :*: s -> [ (a, q :*: s) | (a, q) <- firsts r ] ++ - (if empty r then firsts s else []) - r :|: s -> firsts r ++ firsts s - -nonempty :: RE a -> RE a -nonempty regexp = foldr (:|:) EmptySet [ Atom a :*: r | (a, r) <- firsts regexp ] diff --git a/src/Domain/RegularExpr/Exercises.hs b/src/Domain/RegularExpr/Exercises.hs deleted file mode 100644 --- a/src/Domain/RegularExpr/Exercises.hs +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.RegularExpr.Exercises (regexpExercise) where - -import Common.Exercise -import Common.Navigator -import Common.Traversable -import Common.Rewriting hiding (difference) -import Domain.RegularExpr.Expr -import Domain.RegularExpr.Parser -import Domain.RegularExpr.Strategy -import Domain.RegularExpr.Definitions -import Control.Monad -import System.Random -import Test.QuickCheck - -regexpExercise :: Exercise RegExp -regexpExercise = makeExercise - { description = "Rewrite a regular expression" - , exerciseCode = makeCode "regexp" "normalform" - , status = Experimental - , parser = parseRegExp - , prettyPrinter = ppRegExp --- , equivalence = eqRE - , similarity = equalWith operators -- modulo associativity - , isReady = deterministic - , isSuitable = (>1) . length . crush - , difference = differenceMode eqRE - , strategy = deterministicStrategy - , navigation = navigator --- , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy - , testGenerator = Just startFormGen -- arbitrary - , randomExercise = simpleGenerator startFormGen -- myGen - , examples = generate 5 (mkStdGen 2805) (replicateM 15 startFormGen) - } - --- myGen :: Gen RegExp --- myGen = restrictGenerator (isSuitable regexpExercise) arbitrary - -startFormGen :: Gen RegExp -startFormGen = do - i <- oneof $ map return [1..10] - xs <- replicateM i $ do - j <- oneof $ map return [1..5] - ys <- replicateM j $ oneof $ map (return . Atom . return) "abcd" - return $ foldr1 (:*:) ys - return $ foldr1 (:|:) xs - --- equivalence of regular expressions -eqRE :: Eq a => RE a -> RE a -> Bool -eqRE = (==) - -{- -checkUntil :: Ord a => Int -> RE a -> RE a -> Bool -checkUntil n r s = empty r == empty s && (n==0 || next) - where - make = groupBy eqFst . sortBy cmpFst . firsts - eqFst (a, _) (b, _) = a==b - cmpFst (a, _) (b, _) = compare a b - - as = make r - bs = make s - next = and ((length as == length bs) : zipWith f as bs) - - -- f ((a, _): - f _ _ = False -} diff --git a/src/Domain/RegularExpr/Expr.hs b/src/Domain/RegularExpr/Expr.hs deleted file mode 100644 --- a/src/Domain/RegularExpr/Expr.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# OPTIONS -XTypeSynonymInstances #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.RegularExpr.Expr where - -import Common.Rewriting -import Common.Traversable -import Common.Uniplate -import Control.Monad -import Domain.Math.Expr.Symbolic -import Test.QuickCheck - --------------------------------------------------------------------- --- Data type declaration - -infixl 4 :|: -infixl 5 :*: - -type RegExp = RE String - -data RE a = EmptySet | Epsilon | Atom a | Option (RE a) | Star (RE a) - | Plus (RE a) | RE a :*: RE a | RE a :|: RE a - deriving (Show, Eq, Ord) - --------------------------------------------------------------------- --- Fold - -foldRE (es, eps, at, opt, st, pl, sq, ch) = rec - where - rec regexp = - case regexp of - EmptySet -> es - Epsilon -> eps - Atom a -> at a - Option r -> opt (rec r) - Star r -> st (rec r) - Plus r -> pl (rec r) - r :*: s -> sq (rec r) (rec s) - r :|: s -> ch (rec r) (rec s) - --------------------------------------------------------------------- --- General instances - -instance Functor RE where - fmap f = foldRE (EmptySet, Epsilon, Atom . f, Option, Star, Plus, (:*:), (:|:)) - -instance Crush RE where - crush (Atom a) = [a] - crush regexp = concatMap crush (children regexp) - -instance Arbitrary RegExp where - arbitrary = sized (arbRE $ oneof $ map return ["a", "b", "c", "d"]) -instance CoArbitrary RegExp where - coarbitrary = foldRE - ( variant 0 - , variant 1 - , \a -> variant 2 . coarbitrary a - , \a -> variant 3 . a - , \a -> variant 4 . a - , \a -> variant 5 . a - , \a b -> variant 6 . a . b - , \a b -> variant 7 . a . b - ) - -arbRE :: Gen a -> Int -> Gen (RE a) -arbRE g n - | n == 0 = frequency - [ (6, liftM Atom g) - , (3, return Epsilon) - , (1, return EmptySet) - ] - | otherwise = frequency - [ (3, arbRE g 0) - , (2, unop Star) -- (1, unop Option), (1, unop Plus) - , (3, binop (:*:)), (3, binop (:|:)) - ] - where - rec = arbRE g (n `div` 2) - unop f = liftM f rec - binop f = liftM2 f rec rec - --------------------------------------------------------------------- --- Pretty-printer - -ppRegExp :: RegExp -> String -ppRegExp = ppWith (const id) - -ppWith :: (Int -> a -> String) -> RE a -> String -ppWith f = ($ 0) . foldRE - (const "F", const "T", flip f, unop "?", unop "*", unop "+", binop 5 "", binop 4 "|") - where - unop s a _ = parIf False (a 6 ++ s) - binop i s a b n = parIf (n > i) (a i ++ s ++ b i) - parIf b s = if b then "(" ++ s ++ ")" else s - ---testje = ppWith (const id) (Star (Plus (Atom "P")) :*: (Option (Atom "Q" :*: Option (Atom "S")) :|: Atom "R")) - --------------------------------------------------------------------- --- Function for associative operators - -concatOp :: Operator (RE a) -concatOp = associativeOperator (:*:) isConcat - where - isConcat (r :*: s) = Just (r, s) - isConcat _ = Nothing - -choiceOp :: Operator (RE a) -choiceOp = associativeOperator (:|:) isChoice - where - isChoice (r :|: s) = Just (r, s) - isChoice _ = Nothing - --------------------------------------------------------------------- --- Instances for rewriting - -instance Uniplate (RE a) where - uniplate regexp = - case regexp of - EmptySet -> ([], \[] -> EmptySet) - Epsilon -> ([], \[] -> Epsilon) - Atom a -> ([], \[] -> Atom a) - Option r -> ([r], \[a] -> Option a) - Star r -> ([r], \[a] -> Star a) - Plus r -> ([r], \[a] -> Plus a) - r :*: s -> ([r, s], \[a, b] -> a :*: b) - r :|: s -> ([r, s], \[a, b] -> a :|: b) - -instance Eq a => ShallowEq (RE a) where - shallowEq re1 re2 = - case (re1, re2) of - (EmptySet, EmptySet) -> True - (Epsilon, Epsilon ) -> True - (Atom a, Atom b ) -> a==b - (Option _, Option _) -> True - (Star _, Star _ ) -> True - (Plus _, Plus _ ) -> True - (_ :*: _, _ :*: _ ) -> True - (_ :|: _, _ :|: _ ) -> True - _ -> False - -instance Different (RE a) where - different = (EmptySet, Epsilon) - -instance IsTerm RegExp where - toTerm = foldRE - ( nullary "EmptySet", nullary "Epsilon", variable, unary "Option" - , unary "Star", unary "Plus", binary ":*:", binary ":|:" - ) - - fromTerm a = fromTermWith f a `mplus` liftM Atom (getVariable a) - where - f s [] - | s == "EmptySet" = return EmptySet - | s == "Epsilon" = return Epsilon - f s [x] - | s == "Option" = return (Option x) - | s == "Star" = return (Star x) - | s == "Plus" = return (Plus x) - f s [x, y] - | s == ":*:" = return (x :*: y) - | s == ":|:" = return (x :|: y) - f _ _ = fail "fromExpr" - -instance Rewrite RegExp where - operators = [concatOp, choiceOp] - associativeOps = const $ map toSymbol [":*:", ":|:"] diff --git a/src/Domain/RegularExpr/Parser.hs b/src/Domain/RegularExpr/Parser.hs deleted file mode 100644 --- a/src/Domain/RegularExpr/Parser.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.RegularExpr.Parser (parseRegExp) where - -import Domain.RegularExpr.Expr -import Text.Parsing - -logicScanner :: Scanner -logicScanner = (specialSymbols "+*?|" defaultScanner) - { keywords = ["T", "F"] - , keywordOperators = ["+", "*", "?", "|"] - , isIdentifierCharacter = const False - } - -parseRegExp :: String -> Either String RegExp -parseRegExp = parseWithM logicScanner pRE - -pRE :: TokenParser RegExp -pRE = pOr - where - pOr = pChainl ((:|:) <$ pKey "|") pSeq - pSeq = foldl1 (:*:) <$> pList1 pPost - pPost = foldl (flip ($)) <$> pAtom <*> pList pUnop - pUnop = Star <$ pKey "*" <|> Plus <$ pKey "+" <|> Option <$ pKey "?" - pAtom = Atom <$> (pVarid <|> pConid) - <|> Epsilon <$ pKey "T" - <|> EmptySet <$ pKey "F" - <|> pSpec '(' *> pRE <* pSpec ')' - --- testje = parseRegExp "P+*((QS?)?|R)" diff --git a/src/Domain/RegularExpr/Strategy.hs b/src/Domain/RegularExpr/Strategy.hs deleted file mode 100644 --- a/src/Domain/RegularExpr/Strategy.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.RegularExpr.Strategy (deterministicStrategy) where - -import Domain.RegularExpr.Expr -import Common.Context -import Common.Strategy -import Common.Rewriting -import Common.Transformation -import Prelude hiding (repeat, replicate) - -deterministicStrategy :: LabeledStrategy (Context RegExp) -deterministicStrategy = label "deterministic and precise" $ - repeat (somewhere - ((liftToContext ruleLeftFactor1 <|> - liftToContext ruleLeftFactor2 <|> - liftToContext ruleIdempOr <|> - -- liftToContext ruleEpsilonSeq <|> - -- liftToContext ruleEmptySeq <|> - -- liftToContext ruleEmptyChoice <|> - liftToContext ruleDefOption) |> - liftToContext ruleCommFactor)) - <*> - repeat (somewhere (liftToContext ruleIntroOption)) - -ruleLeftFactor1 :: Rule RegExp -ruleLeftFactor1 = rule "LeftFactor1" $ \a x y -> - (a :*: x) :|: (a :*: y) :~> a :*: (x :|: y) - -ruleLeftFactor2 :: Rule RegExp -ruleLeftFactor2 = ruleList "LeftFactor2" $ - [ \a x -> (a :*: x) :|: a :~> a :*: Option x - , \a x -> a :|: (a :*: x) :~> a :*: Option x - ] - -ruleIdempOr :: Rule RegExp -ruleIdempOr = rule "IdempOr" $ \a -> - a :|: a :~> a - -ruleCommFactor :: Rule RegExp -ruleCommFactor = ruleList "CommFactor" - [ \a b _ _ -> a :|: b :|: a :~> a :|: a :|: b - , \a b x _ -> (a :*: x) :|: b :|: a :~> (a :*: x) :|: a :|: b - , \a b y _ -> a :|: b :|: (a :*: y) :~> a :|: (a :*: y) :|: b - , \a b x y -> (a :*: x) :|: b :|: (a :*: y) :~> (a :*: x) :|: (a :*: y) :|: b - ] - - - -ruleDefOption :: Rule RegExp -ruleDefOption = rule "DefOption" $ \a -> - Option a :~> Epsilon :|: a - -ruleIntroOption :: Rule RegExp -ruleIntroOption = ruleList "IntroOption" - [ \a -> Epsilon :|: a :~> Option a - , \a -> a :|: Epsilon :~> Option a - ] - ---- -{- -ruleEpsilonSeq :: Rule RegExp -ruleEpsilonSeq = ruleList "EpsilonSeq" - [ \a -> Epsilon :*: a :~> a - , \a -> a :*: Epsilon :~> a - ] - -ruleEmptySeq :: Rule RegExp -ruleEmptySeq = ruleList "EmptySeq" - [ \a -> EmptySet :*: a :~> EmptySet - , \a -> a :*: EmptySet :~> EmptySet - ] - -ruleEmptyChoice :: Rule RegExp -ruleEmptyChoice = ruleList "EmptyChoice" - [ \a -> EmptySet :|: a :~> a - , \a -> a :|: EmptySet :~> a - ] --} ------------------ -{- -ruleComm :: Rule RegExp -ruleComm = makeSimpleRuleList "Comm" $ \re -> do - let xs = collectWithOperator choiceOp re - i <- [0..length xs-1] - j <- [i+2..length xs-1] - let (as, b:bs) = splitAt i xs - (cs, d:ds) = splitAt (j-i-1) bs - guard (all (`notElem` (lookahead b)) (lookahead d)) - let new = as++[b,d]++cs++ds - return (buildWithOperator choiceOp new)-} diff --git a/src/Domain/RelationAlgebra.hs b/src/Domain/RelationAlgebra.hs --- a/src/Domain/RelationAlgebra.hs +++ b/src/Domain/RelationAlgebra.hs @@ -30,7 +30,7 @@ import Test.QuickCheck import System.Random import Data.List -import Common.Apply +import Common.Classes import Common.Context import Control.Monad diff --git a/src/Domain/RelationAlgebra/Equivalence.hs b/src/Domain/RelationAlgebra/Equivalence.hs deleted file mode 100644 --- a/src/Domain/RelationAlgebra/Equivalence.hs +++ /dev/null @@ -1,189 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.RelationAlgebra.Equivalence (isEquivalent) where - -import Data.List -import Data.Maybe -import Domain.RelationAlgebra.Formula -import Common.Apply -import Common.Context -import Domain.RelationAlgebra.Strategies -{- -infixr 1 :.: -infixr 2 :+: -infixr 3 :||: -infixr 4 :&&: --} -{- --- | The data type RelAlg is the abstract syntax for the domain --- | of logic expressions. -data RelAlg = Var String - | RelAlg :.: RelAlg -- composition - | RelAlg :+: RelAlg -- relative addition - | RelAlg :&&: RelAlg -- and (conjunction) - | RelAlg :||: RelAlg -- or (disjunction) - | Not RelAlg -- not - | Inv RelAlg -- inverse - | U -- universe - | E -- empty - deriving (Show, Eq, Ord) - -------------------------------------- - - -isAtom :: RelAlg -> Bool -isAtom r = - case r of - Var x -> True - Not (Var x) -> True - Inv (Var x) -> True - Not (Inv (Var x)) -> True - U -> True - E -> True - otherwise -> False - -isMolecule :: RelAlg -> Bool -isMolecule (r :.: s) = isMolecule r && isMolecule s -isMolecule (r :+: s) = isMolecule r && isMolecule s -isMolecule r = isAtom r - -isDisj :: RelAlg -> Bool -isDisj (r :||: s) = isDisj r && isDisj s -isDisj r = isMolecule r - -isCNF :: RelAlg -> Bool -isCNF (r :&&: s) = isCNF r && isCNF s -isCNF r = isDisj r --} --- | maak er een cnf van -isEquivalent :: RelAlg -> RelAlg -> Bool -isEquivalent x1 x2 = - let res1 = fromContext (applyD toCNF (inContext x1)) -- cnf van x1 - res2 = fromContext (applyD toCNF (inContext x2)) -- cnf van x2 - mols = union (getSetOfMolecules res1) (getSetOfMolecules res2) - (rs, r1, r2) = remCompls mols res1 res2 - vals = createValuations rs - in all (\ v -> evalFormula r1 v == evalFormula r2 v) vals -{- --- | zet 'm in cnf -solve (Inv (Inv (Not (Var "p")) :+: Not (Var "q"))) = Not (Var "p") :+: Not (Inv (Var "q")) -solve (Not (Not (Var "p") :+: Not (Inv (Var "q")))) = undefined -solve (Not (Inv (Inv (Not (Var "p")) :+: Not (Var "q")))) = undefined -solve (Not (Var "p" :.: Inv (Var "q"))) = Inv (Inv (Not (Var "p")) :+: Not (Var "q")) -solve x = x --} - -{- -ra1 = Var "a" :||: (Var "p" :.: Inv (Var "q")) -ra2 = Var "a" :||: (Inv (Inv (Not (Var "p")) :+: Not (Var "q"))) - -fa1 = Inv (Var "r" :+: Var "s") -fa2 = Inv (Var "s") :+: Inv (Var "r") --} - -{- -mols = union (getSetOfMolecules ra1) (getSetOfMolecules ra2) -triple@(t1, t2, t3) = remCompls mols ra1 ra2 -vs = createValuations t1 -bb = and (map (\v -> evalFormula ra1 v == evalFormula ra2 v) vs) --} -remCompls :: [RelAlg] -> RelAlg -> RelAlg -> ([RelAlg], RelAlg, RelAlg) -remCompls rs r1 r2 = - let complements = searchForComplements rs - -- sub = [ (r1, Not r2) | (r1, r2) <- complements ] - in ( removeCompls rs complements - , substCompls r1 complements - , substCompls r2 complements - ) - --- | -substCompls :: RelAlg -> [(RelAlg, RelAlg)] -> RelAlg -substCompls = foldl subst - - - -subst :: RelAlg -> (RelAlg, RelAlg) -> RelAlg -subst r (r1, r2) = - case r of - p :&&: q -> subst p (r1, r2) :&&: subst q (r1, r2) - p :||: q -> subst p (r1, r2) :||: subst q (r1, r2) - _ -> if r == r1 - then Not r2 - else r - - -removeCompls :: [RelAlg] -> [(RelAlg, RelAlg)] -> [RelAlg] -removeCompls xs ys = [ x | x <- xs, notElem x (map snd ys)] - --- | Search for complements -searchForComplements ::[RelAlg] -> [(RelAlg, RelAlg)] -searchForComplements [] = [] -searchForComplements (x:xs) = [(x,z) | z <- xs, isComplement x z] ++ searchForComplements xs - -isComplement :: RelAlg -> RelAlg -> Bool -isComplement = (==) . fromContext . applyD toCNF . inContext . Not - --- FIXME: what should we do with the identity relation? -evalFormula :: RelAlg -> [(RelAlg, Bool)] -> Bool -evalFormula f val = - case lookup f val of - Just b -> b - Nothing -> - case f of - f1 :&&: f2 -> evalFormula f1 val && evalFormula f2 val - f1 :||: f2 -> evalFormula f1 val || evalFormula f2 val - Not f -> not (evalFormula f val) - V -> True - E -> False - x -> let value = lookup x val - in if value == Nothing - then error $ "evalFormula: molecule not in valuation " ++ show (f, val) - else fromJust value - - - - - - --- | Get the set of molecules of an expression in CNF as list. -getSetOfMolecules :: RelAlg -> [RelAlg] -getSetOfMolecules = nub . getMolecules - where - getMolecules :: RelAlg -> [RelAlg] - getMolecules expr = - case expr of - p :&&: q -> getMolecules p ++ getMolecules q - p :||: q -> getMolecules p ++ getMolecules q - Not p -> getMolecules p - V -> [] - E -> [] - I -> [] - p -> [p] - - -{------------------------------------------------------------------- - Given a varList, for example [x,y], function createValuations - creates all valuations: - [[(x,0),(y,0)],[(x,0),(y,1)],[(x,1),(y,0)],[(x,1),(y,1)]], - where (x,0) means: variable x equals 0. ---------------------------------------------------------------------} - -type Molecule = RelAlg --- type Valuation = (RelAlg, Bool) - - -createValuations :: [a] -> [[(a, Bool)]] -createValuations = foldr op [[]] - where op a vs = [ (a, b):v | v <- vs, b <- [True, False] ] - -prop :: RelAlg -> RelAlg -> Bool -prop p q = isEquivalent p q == probablyEqual p q 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 @@ -17,7 +17,7 @@ import Domain.RelationAlgebra.Strategies import Domain.RelationAlgebra.Rules import Domain.RelationAlgebra.Parser -import Common.Apply +import Common.Classes import Common.Exercise import Common.Context import Data.Maybe @@ -29,8 +29,8 @@ cnfExercise :: Exercise RelAlg cnfExercise = testableExercise - { description = "To conjunctive normal form" - , exerciseCode = makeCode "relationalg" "cnf" + { exerciseId = describe "To conjunctive normal form" $ + newId "relationalgebra.cnf" , status = Alpha , parser = parseRelAlg , prettyPrinter = ppRelAlg 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 @@ -11,16 +11,15 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Formula where -import Domain.Math.Expr.Symbolic -import Common.Exercise (generate) import Common.Uniplate (Uniplate(..)) import Common.Rewriting import Common.Utils import Control.Monad import Data.List import qualified Data.Set as S -import System.Random (StdGen, mkStdGen, split) +import System.Random (StdGen, mkStdGen, split, randomR) import Test.QuickCheck +import Test.QuickCheck.Gen infixr 2 :.: infixr 3 :+: @@ -79,7 +78,7 @@ -- | foldRelAlg is the standard folfd for RelAlg. foldRelAlg :: RelAlgAlgebra a -> RelAlg -> a -foldRelAlg (var, comp, add, conj, disj, not, inverse, universe, ident) = rec +foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) = rec where rec term = case term of @@ -88,26 +87,27 @@ p :+: q -> rec p `add` rec q p :&&: q -> rec p `conj` rec q p :||: q -> rec p `disj` rec q - Not p -> not (rec p) - Inv p -> inverse (rec p) - V -> universe + Not p -> neg (rec p) + Inv p -> inv (rec p) + V -> univ I -> ident type Relation a = S.Set (a, a) evalRelAlg :: Ord a => (String -> Relation a) -> [a] -> RelAlg -> Relation a -evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, not, inverse, universe, ident) +evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) where pairs = cartesian as as + comp p q = let f (a1, a2) c = (a1, c) `S.member` p && (c, a2) `S.member` q in S.fromAscList [ x | x <- pairs, any (f x) as ] add p q = let f (a1, a2) c = (a1, c) `S.member` p || (c, a2) `S.member` q in S.fromAscList [ x | x <- pairs, all (f x) as ] conj = S.intersection disj = S.union - not p = S.fromAscList [ x | x <- pairs, x `S.notMember` p ] - inverse = S.map (\(x, y) -> (y, x)) - universe = S.fromAscList pairs + neg p = S.fromAscList [ x | x <- pairs, x `S.notMember` p ] + inv = S.map (\(x, y) -> (y, x)) + univ = S.fromAscList pairs ident = S.fromAscList [ (x, x) | x <- as ] -- | Try to find a counter-example showing that the two formulas are not equivalent. @@ -118,16 +118,17 @@ probablyEqualWith rng p q = all (\i -> eval i p == eval i q) (makeRngs 50 rng) where -- size of (co-)domain - as = [0..1] + as :: [Int] + as = [0..1] -- number of attemps (with different randomly generated relations) + makeRngs :: Int -> StdGen -> [StdGen] makeRngs n g | n == 0 = [] | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2 - eval g = evalRelAlg (generate 100 g (arbRelations as)) as - -inspect :: [Int] -inspect = map f [1..100] - where f i = S.size $ generate 100 (mkStdGen i) (arbRelations [0..9]) "p" + eval g = + let MkGen f = arbRelations as + (size, a) = randomR (0, 100) g + in evalRelAlg (f a size) as arbRelations :: Eq a => [a] -> Gen (String -> Relation a) arbRelations as = promote (\s -> coarbitrary s (arbRelation as)) @@ -168,42 +169,44 @@ Not s -> ([s], \[a] -> Not a) Inv s -> ([s], \[a] -> Inv a) _ -> ([], \[] -> term) - -instance ShallowEq RelAlg where - shallowEq expr1 expr2 = - case (expr1, expr2) of - (Var a , Var b ) -> a==b - (_ :.: _ , _ :.: _ ) -> True - (_ :+: _ , _ :+: _ ) -> True - (_ :&&: _, _ :&&: _) -> True - (_ :||: _, _ :||: _) -> True - (Not _ , Not _ ) -> True - (Inv _ , Inv _ ) -> True - (V , V ) -> True - (I , I ) -> True - _ -> False instance Different RelAlg where different = (V, I) - + --(var, comp, add, conj, disj, not, inverse, universe, ident) instance IsTerm RelAlg where toTerm = foldRelAlg - ( variable, binary ".", binary "+", binary "&&", binary "||" - , unary "~", unary "-", nullary "V", nullary "I" + ( variable, binary compSymbol, binary addSymbol + , binary conjSymbol + , binary disjSymbol, unary notSymbol, unary invSymbol + , symbol universeSymbol, symbol identSymbol ) fromTerm a = fromTermWith f a `mplus` liftM Var (getVariable a) where f s [] - | s == "V" = return V - | s == "I" = return I + | s == universeSymbol = return V + | s == identSymbol = return I f s [x] - | s == "~" = return (Not x) - | s == "-" = return (Inv x) + | s == notSymbol = return (Not x) + | s == invSymbol = return (Inv x) f s [x, y] - | s == "." = return (x :.: y) - | s == "+" = return (x :+: y) - | s == "&&" = return (x :&&: y) - | s == "||" = return (x :||: y) - f _ _ = fail "fromTerm" + | s == compSymbol = return (x :.: y) + | s == addSymbol = return (x :+: y) + | s == conjSymbol = return (x :&&: y) + | s == disjSymbol = return (x :||: y) + f _ _ = fail "fromTerm" + +compSymbol, addSymbol, conjSymbol, disjSymbol, + notSymbol, invSymbol, universeSymbol, identSymbol :: Symbol +compSymbol = relalgSymbol "comp" +addSymbol = relalgSymbol "add" +conjSymbol = relalgSymbol "conj" +disjSymbol = relalgSymbol "disj" +notSymbol = relalgSymbol "not" +invSymbol = relalgSymbol "inv" +universeSymbol = relalgSymbol "universe" +identSymbol = relalgSymbol "ident" + +relalgSymbol :: String -> Symbol +relalgSymbol a = newSymbol ["relalg", a] 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 @@ -23,18 +23,18 @@ instance CoArbitrary RelAlg where coarbitrary term = case term of - Var x -> variant 0 . coarbitrary x - p :.: q -> variant 1 . coarbitrary p . coarbitrary q - p :+: q -> variant 2 . coarbitrary p . coarbitrary q - p :&&: q -> variant 3 . coarbitrary p . coarbitrary q - p :||: q -> variant 4 . coarbitrary p . coarbitrary q - Not p -> variant 5 . coarbitrary p - Inv p -> variant 6 . coarbitrary p - V -> variant 7 - I -> variant 8 + Var x -> variant (0 :: Int) . coarbitrary x + p :.: q -> variant (1 :: Int) . coarbitrary p . coarbitrary q + p :+: q -> variant (2 :: Int) . coarbitrary p . coarbitrary q + p :&&: q -> variant (3 :: Int) . coarbitrary p . coarbitrary q + p :||: q -> variant (4 :: Int) . coarbitrary p . coarbitrary q + Not p -> variant (5 :: Int) . coarbitrary p + Inv p -> variant (6 :: Int) . coarbitrary p + V -> variant (7 :: Int) + I -> variant (8 :: Int) arbRelAlg :: Int -> Gen RelAlg -arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return vars)), (1, return V), (1, return empty), (1, return I)] +arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)] arbRelAlg n = oneof [ arbRelAlg 0, binop (:.:), binop (:+:), binop (:&&:), binop (:||:) , unop Not, unop Inv ] @@ -43,12 +43,18 @@ unop op = liftM op rec rec = arbRelAlg (n `div` 2) -vars :: [String] -vars = ["q", "r", "s"] +relAlgVars :: [String] +relAlgVars = ["q", "r", "s"] ------------------------------------------------------------------- -- Templates +template1, template2, template3, template4, template7, template8 :: + RelAlg -> RelAlg -> RelAlg -> RelAlg + +template5 :: RelAlg -> RelAlg -> RelAlg -> RelAlg -> RelAlg +template6 :: Maybe RelAlg -> RelAlg -> RelAlg -> Maybe RelAlg -> RelAlg + template1 x y z = x :||: (y :&&: z) template2 x y z = Not(x :&&: (y :||: z)) template3 x y z = Inv(x :||: (y :&&: z)) @@ -77,7 +83,10 @@ gen8 = use3 template2 arbInvNotMol hulpgen1 arbInvNotMol gen9 = use3 template8 hulpgen2 arbInvNotMol arbInvNotMol +use3 :: (a -> b -> c -> d) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> t -> Gen d use3 temp f g h n = liftM3 temp (f n) (g n) (h n) + +use4 :: (a -> b -> c -> d -> e) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> (t -> Gen d) -> t -> Gen e use4 temp f g h k n = liftM4 temp (f n) (g n) (h n) (k n) hulpgen1 :: Int -> Gen RelAlg @@ -87,7 +96,7 @@ hulpgen2 n = liftM3 template7 (arbInvNotMol 1) (arbRelAlg n) (arbRelAlg n) arbInvNotMol :: Int -> Gen RelAlg -arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return vars)), (1, return V), (1, return empty), (1, return I)] +arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)] arbInvNotMol n = frequency [ (10, arbInvNotMol 0), (4, binop (:.:)), (4, binop (:+:)), (2, unop Not), (2, unop Inv) ] where binop op = liftM2 op rec rec @@ -98,4 +107,4 @@ arbMaybeInvNotMol n = frequency [(3, liftM Just (arbInvNotMol n)), (1, return Nothing)] arbVar :: Gen RelAlg -arbVar = liftM Var (oneof $ map return vars) +arbVar = liftM Var (oneof $ map return relAlgVars) 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 @@ -28,6 +28,7 @@ , (NoMix, [(compSym, (:.:)), (addSym, (:+:))]) ] +andSym, orSym, addSym, compSym, notSym, invSym :: String andSym = "/\\" orSym = "\\/" addSym = "!" @@ -77,8 +78,11 @@ ppRelAlg = ppRelAlgPrio (0, "") ppRelAlgPrio :: (Int, String) -> RelAlg -> String -ppRelAlgPrio n p = foldRelAlg (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/", nott, inv, var "V", var "I") p n "" +ppRelAlgPrio = (\f n -> f n "") . flip (foldRelAlg alg) where + alg = (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/" + , nott, inv, var "V", var "I" + ) binop prio op p q (n, parent) = parIf (n > prio || (prio==4 && n==4 && op/=parent)) (p (prio+1, op) . ((" "++op++" ")++) . q (prio, op)) var = const . (++) 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 @@ -13,8 +13,10 @@ import Domain.RelationAlgebra.Formula import Domain.RelationAlgebra.Generator() -import Common.Transformation +import Common.Id +import Common.Transformation (Rule, addRuleToGroup, buggyRule) import Common.Rewriting +import qualified Common.Transformation as Rule invRules :: [Rule RelAlg] invRules = [ ruleInvOverUnion, ruleInvOverIntersec, ruleInvOverComp @@ -38,10 +40,21 @@ , buggyRuleAssoc, buggyRuleInvOverComp, buggyRuleInvOverAdd , buggyRuleCompOverIntersec, buggyRuleAddOverUnion, buggyRuleRemCompl ] + +relalg :: IsId a => a -> Id +relalg = (#) "relationalgebra" + +rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +rule = Rule.rule . relalg + +ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +ruleList = Rule.ruleList . relalg -- | 1. Alle ~ operatoren naar binnen verplaatsen -conversionGroup s = addRuleToGroup "Conversion" . rule s +conversionGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +conversionGroup s = + addRuleToGroup (relalg "Conversion") . rule s ruleInvOverUnion :: Rule RelAlg ruleInvOverUnion = conversionGroup "InvOverUnion" $ @@ -71,8 +84,9 @@ -- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen - -distributionGroup s = addRuleToGroup "Distribution" . ruleList s +distributionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +distributionGroup s = + addRuleToGroup (relalg "Distribution") . ruleList s ruleCompOverUnion :: Rule RelAlg ruleCompOverUnion = distributionGroup "CompOverUnion" @@ -106,7 +120,9 @@ -- | 4. De Morgan rules -deMorganGroup s = addRuleToGroup "DeMorgan" . rule s +deMorganGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +deMorganGroup s = + addRuleToGroup (relalg "DeMorgan") . rule s ruleDeMorganOr :: Rule RelAlg ruleDeMorganOr = deMorganGroup "DeMorganOr" $ @@ -118,7 +134,9 @@ -- | 5. Idempotency -idempotencyGroup s = addRuleToGroup "Idempotency" . rule s +idempotencyGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +idempotencyGroup s = + addRuleToGroup (relalg "Idempotency") . rule s ruleIdempOr :: Rule RelAlg ruleIdempOr = idempotencyGroup "IdempotencyOr" $ @@ -130,7 +148,9 @@ -- | 6. Complement -complementGroup s = addRuleToGroup "Complement" . ruleList s +complementGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +complementGroup s = + addRuleToGroup (relalg "Complement") . ruleList s ruleDoubleNegation :: Rule RelAlg ruleDoubleNegation = complementGroup "DoubleNegation" @@ -159,7 +179,9 @@ -- | 7. Absorption complement -absorptionGroup s = addRuleToGroup "Absorption" . ruleList s +absorptionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +absorptionGroup s = + addRuleToGroup (relalg "Absorption") . ruleList s ruleAbsorpCompl :: Rule RelAlg ruleAbsorpCompl = absorptionGroup "AbsorpCompl" @@ -187,7 +209,9 @@ -- | 8. Remove redundant expressions -simplificationGroup s = addRuleToGroup "Simplification" . ruleList s +simplificationGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +simplificationGroup s = + addRuleToGroup (relalg "Simplification") . ruleList s ruleRemRedunExprs :: Rule RelAlg ruleRemRedunExprs = simplificationGroup "RemRedunExprs" @@ -220,7 +244,9 @@ -- Buggy rules: -buggyGroup s = addRuleToGroup "Buggy" . buggyRule . ruleList s +buggyGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +buggyGroup s = addRuleToGroup (relalg "Buggy") . buggyRule + . Rule.ruleList ("relationalgebra.buggy." ++ s) buggyRuleIdemComp :: Rule RelAlg buggyRuleIdemComp = buggyGroup "IdemComp" @@ -233,7 +259,7 @@ ] buggyRuleDeMorgan :: Rule RelAlg -buggyRuleDeMorgan = buggyGroup "BuggyDeMorgan" +buggyRuleDeMorgan = buggyGroup "DeMorgan" [ \q r -> Not (q :&&: r) :~> Not q :||: r , \q r -> Not (q :&&: r) :~> q :||: Not r , \q r -> Not (q :&&: r) :~> Not (Not q :||: Not r) @@ -243,7 +269,7 @@ ] buggyRuleNotOverAdd :: Rule RelAlg -buggyRuleNotOverAdd = buggyGroup "BuggyNotOverAdd" +buggyRuleNotOverAdd = buggyGroup "NotOverAdd" [ \q r -> Not (q :+: r) :~> Not q :+: Not r , \q r -> Not (q :+: r) :~> Not q :.: r , \q r -> Not (q :+: r) :~> Not q :+: r @@ -251,7 +277,7 @@ ] buggyRuleNotOverComp :: Rule RelAlg -buggyRuleNotOverComp = buggyGroup "BuggyNotOverComp" +buggyRuleNotOverComp = buggyGroup "NotOverComp" [ \q r -> Not (q :.: r) :~> Not q :.: Not r , \q r -> Not (q :.: r) :~> Not q :.: r , \q r -> Not (q :.: r) :~> Not q :+: r @@ -259,7 +285,7 @@ ] buggyRuleParenth :: Rule RelAlg -buggyRuleParenth = buggyGroup "BuggyParenth" +buggyRuleParenth = buggyGroup "Parenth" [ \q r -> Not (q :&&: r) :~> Not q :&&: r , \q r -> Not (q :||: r) :~> Not q :||: r , \q r -> Not (Not q :&&: r) :~> q :&&: r @@ -275,7 +301,7 @@ ] buggyRuleAssoc :: Rule RelAlg -buggyRuleAssoc = buggyGroup "BuggyAssoc" +buggyRuleAssoc = buggyGroup "Assoc" [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: s , \q r s -> (q :||: r) :&&: s :~> q :||: (r :&&: s) , \q r s -> (q :&&: r) :||: s :~> q :&&: (r :||: s) @@ -291,28 +317,28 @@ ] buggyRuleInvOverComp :: Rule RelAlg -buggyRuleInvOverComp = buggyGroup "BuggyInvOverComp" +buggyRuleInvOverComp = buggyGroup "InvOverComp" [ \r s -> Inv (r :.: s) :~> Inv r :.: Inv s ] buggyRuleInvOverAdd :: Rule RelAlg -buggyRuleInvOverAdd = buggyGroup "BuggyInvOverAdd" +buggyRuleInvOverAdd = buggyGroup "InvOverAdd" [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s ] buggyRuleCompOverIntersec :: Rule RelAlg -buggyRuleCompOverIntersec = buggyGroup "BuggyCompOverIntersec" +buggyRuleCompOverIntersec = buggyGroup "CompOverIntersec" [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s) --alleen toegestaan als q een functie is! , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s) --idem ] buggyRuleAddOverUnion :: Rule RelAlg -buggyRuleAddOverUnion = buggyGroup "BuggyAddOverUnion" +buggyRuleAddOverUnion = buggyGroup "AddOverUnion" [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is! , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem ] buggyRuleRemCompl :: Rule RelAlg -buggyRuleRemCompl = buggyGroup "BuggyRemCompl" +buggyRuleRemCompl = buggyGroup "RemCompl" [ \r -> r :&&: Not r :~> V , \r -> Not r :&&: r :~> V , \r -> r :||: Not r :~> empty diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -19,7 +19,7 @@ import Data.IORef import Data.Time import Documentation.Make -import Main.ExerciseList +import Main.IDEAS import Main.LoggingDatabase import Main.Options import Network.CGI @@ -48,7 +48,8 @@ -- documentation mode _ | documentationMode flags -> useIDEAS $ - mapM_ makeDocumentation (docItems flags) + let f = makeDocumentation (docDir flags) (testDir flags) + in mapM_ f (docItems flags) -- cgi binary Nothing -> runCGI $ do diff --git a/src/Main/ExerciseList.hs b/src/Main/ExerciseList.hs deleted file mode 100644 --- a/src/Main/ExerciseList.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Main.ExerciseList (packages, useIDEAS) where - -import Common.Utils (Some(..), fromShowString) -import Common.Rewriting -import Domain.Math.Expr -import Service.ExercisePackage -import Service.FeedbackText -import Service.DomainReasoner -import qualified Domain.LinearAlgebra as LA -import qualified Domain.Logic as Logic -import qualified Domain.Logic.FeedbackText as Logic -import qualified Domain.RelationAlgebra as RA -import qualified Domain.Math.DerivativeExercise as Math -import qualified Domain.Math.Numeric.Exercises as Math -import qualified Domain.Math.Equation.CoverUpExercise as Math -import qualified Domain.Math.Polynomial.Exercises as Math -import qualified Domain.Math.Polynomial.IneqExercises as Math -import qualified Domain.RegularExpr.Exercises as RE -import qualified Domain.Math.Power.Exercises as Math -import Main.Options -import Service.ServiceList - -packages :: [Some ExercisePackage] -packages = - [ -- logic and relation-algebra - Some (package Logic.dnfExercise) - { withOpenMath = True - , toOpenMath = termToOMOBJ . toTerm . fmap (Var . fromShowString) - , fromOpenMath = (>>= fromTerm) . omobjToTerm - , getExerciseText = Just logicText - } - , Some (package Logic.dnfUnicodeExercise) - { withOpenMath = True - , toOpenMath = termToOMOBJ . toTerm . fmap (Var . fromShowString) - , fromOpenMath = (>>= fromTerm) . omobjToTerm - , getExerciseText = Just logicText - } - , somePackage RA.cnfExercise - -- basic math - , someTermPackage Math.naturalExercise - , someTermPackage Math.integerExercise - , someTermPackage Math.rationalExercise - , someTermPackage Math.fractionExercise - , someTermPackage Math.coverUpExercise - , someTermPackage Math.linearExercise - , someTermPackage Math.linearMixedExercise - , someTermPackage Math.quadraticExercise - , someTermPackage Math.higherDegreeExercise - , someTermPackage Math.findFactorsExercise - , someTermPackage Math.ineqLinearExercise - , someTermPackage Math.ineqQuadraticExercise - , someTermPackage Math.ineqHigherDegreeExercise - , someTermPackage Math.quadraticNoABCExercise - , someTermPackage Math.quadraticWithApproximation - , someTermPackage Math.derivativeExercise - , someTermPackage Math.simplifyPowerExercise - , someTermPackage Math.powerOfExercise - , someTermPackage Math.nonNegExpExercise - , someTermPackage Math.calcPowerExercise - -- linear algebra - , someTermPackage LA.gramSchmidtExercise - , someTermPackage LA.linearSystemExercise - , someTermPackage LA.gaussianElimExercise - , someTermPackage LA.systemWithMatrixExercise - -- regular expressions - , somePackage RE.regexpExercise - ] - -logicText :: ExerciseText Logic.SLogic -logicText = ExerciseText - { ruleText = Logic.ruleText - , appliedRule = Logic.appliedRule - , feedbackSyntaxError = Logic.feedbackSyntaxError - , feedbackSame = Logic.feedbackSame - , feedbackBuggy = Logic.feedbackBuggy - , feedbackNotEquivalent = Logic.feedbackNotEquivalent - , feedbackOk = Logic.feedbackOk - , feedbackDetour = Logic.feedbackDetour - , feedbackUnknown = Logic.feedbackUnknown - } - -useIDEAS :: DomainReasoner a -> IO a -useIDEAS action = runDomainReasoner $ do - setVersion shortVersion - setFullVersion fullVersion - addPackages packages - addServices serviceList - addPkgService exerciselistS - action diff --git a/src/Main/IDEAS.hs b/src/Main/IDEAS.hs new file mode 100644 --- /dev/null +++ b/src/Main/IDEAS.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Main.IDEAS (useIDEAS) where + +import Common.Rewriting +import Common.Utils (Some(..), fromShowString) +import Main.Options +import Service.DomainReasoner +import Service.ExercisePackage +import Service.ServiceList +import qualified Domain.LinearAlgebra as LA +import qualified Domain.LinearAlgebra.Checks as LA +import qualified Domain.Logic as Logic +import qualified Domain.Logic.FeedbackText as Logic +import qualified Domain.Math.Expr as Math +import qualified Domain.Math.Data.Interval as MathInterval +import qualified Domain.Math.Derivative.Exercises as Math +import qualified Domain.Math.Equation.CoverUpExercise as Math +import qualified Domain.Math.Numeric.Exercises as Math +import qualified Domain.Math.Numeric.Tests as MathNum +import qualified Domain.Math.Polynomial.Exercises as Math +import qualified Domain.Math.Polynomial.IneqExercises as Math +import qualified Domain.Math.Polynomial.RationalExercises as Math +import qualified Domain.Math.Polynomial.Tests as MathPoly +import qualified Domain.Math.Power.Exercises as Math +import qualified Domain.Math.Power.Equation.Exercises as Math +import qualified Domain.Math.SquareRoot.Tests as MathSqrt +import qualified Domain.Math.Polynomial.LeastCommonMultiple as MathLCM +-- import qualified Domain.RegularExpr.Exercises as RE +import qualified Domain.RelationAlgebra as RA + +useIDEAS :: DomainReasoner a -> IO a +useIDEAS action = runDomainReasoner $ do + -- version information + setVersion shortVersion + setFullVersion fullVersion + -- exercise packages + addPackages packages + -- services + addServices serviceList + addPkgService exerciselistS + -- domain checks + addTestSuite $ do + MathNum.main + MathPoly.tests + MathSqrt.tests + MathInterval.testMe + MathLCM.testLCM + LA.checks + -- do the rest + action + +packages :: [Some ExercisePackage] +packages = + [ -- logic and relation-algebra + Some (package Logic.dnfExercise) + { withOpenMath = True + , toOpenMath = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString) + , fromOpenMath = (>>= fromTerm) . omobjToTerm + , getExerciseText = Just logicText + } + , Some (package Logic.dnfUnicodeExercise) + { withOpenMath = True + , toOpenMath = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString) + , fromOpenMath = (>>= fromTerm) . omobjToTerm + , getExerciseText = Just logicText + } + -- , somePackage Logic.proofExercise + , somePackage RA.cnfExercise + -- basic math + -- , someTermPackage Math.naturalExercise + -- , someTermPackage Math.integerExercise + -- , someTermPackage Math.rationalExercise + , someTermPackage Math.fractionExercise + , someTermPackage Math.coverUpExercise + , someTermPackage Math.linearExercise + , someTermPackage Math.linearMixedExercise + , someTermPackage Math.quadraticExercise + , someTermPackage Math.higherDegreeExercise + , someTermPackage Math.findFactorsExercise + , someTermPackage Math.ineqLinearExercise + , someTermPackage Math.ineqQuadraticExercise + , someTermPackage Math.ineqHigherDegreeExercise + , someTermPackage Math.rationalEquationExercise + , someTermPackage Math.simplifyRationalExercise + -- , someTermPackage Math.divisionBrokenExercise + , someTermPackage Math.quadraticNoABCExercise + , someTermPackage Math.quadraticWithApproximation + , someTermPackage Math.derivativeExercise + , someTermPackage Math.derivativePolyExercise + , someTermPackage Math.derivativeProductExercise + , someTermPackage Math.derivativeQuotientExercise + -- , someTermPackage Math.derivativePowerExercise + , someTermPackage Math.simplifyPowerExercise + , someTermPackage Math.powerOfExercise + , someTermPackage Math.nonNegBrokenExpExercise + , someTermPackage Math.calcPowerExercise + , someTermPackage Math.powerEqExercise + , someTermPackage Math.expEqExercise + , someTermPackage Math.logEqExercise + -- linear algebra + , someTermPackage LA.gramSchmidtExercise + , someTermPackage LA.linearSystemExercise + , someTermPackage LA.gaussianElimExercise + , someTermPackage LA.systemWithMatrixExercise + -- regular expressions + -- , somePackage RE.regexpExercise + ] + +logicText :: ExerciseText Logic.SLogic +logicText = ExerciseText + { ruleText = Logic.ruleText + , appliedRule = Logic.appliedRule + , feedbackSyntaxError = Logic.feedbackSyntaxError + , feedbackSame = Logic.feedbackSame + , feedbackBuggy = Logic.feedbackBuggy + , feedbackNotEquivalent = Logic.feedbackNotEquivalent + , feedbackOk = Logic.feedbackOk + , feedbackDetour = Logic.feedbackDetour + , feedbackUnknown = Logic.feedbackUnknown + } diff --git a/src/Main/LoggingDatabase.hs b/src/Main/LoggingDatabase.hs --- a/src/Main/LoggingDatabase.hs +++ b/src/Main/LoggingDatabase.hs @@ -41,7 +41,7 @@ -- insert data into database run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" [ toSql $ service req - , toSql $ maybe "unknown" show (exerciseID req) + , toSql $ maybe "unknown" show (exerciseId req) , toSql $ fromMaybe "unknown" (source req) , toSql $ show (dataformat req) , toSql $ maybe "unknown" show (encoding req) @@ -60,7 +60,7 @@ {- -- | Log table schema createStmt = "CREATE TABLE log ( service VARCHAR(250)" - ++ ", exerciseID VARCHAR(250)" + ++ ", exerciseId VARCHAR(250)" ++ ", source VARCHAR(250)" ++ ", dataformat VARCHAR(250)" ++ ", encoding VARCHAR(250)" diff --git a/src/Main/Options.hs b/src/Main/Options.hs --- a/src/Main/Options.hs +++ b/src/Main/Options.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- module Main.Options where -import Data.Maybe import Documentation.Make import Main.LoggingDatabase (logEnabled) import Main.Revision @@ -22,7 +21,7 @@ import System.Exit data Flag = Version | Help | Logging Bool | InputFile String - | FixRNG | DocItem DocItem + | FixRNG | DocItem DocItem | DocDir String | TestDir String deriving Eq header :: String @@ -47,19 +46,21 @@ options :: [OptDescr Flag] options = - [ Option [] ["version"] (NoArg Version) "show version number" - , Option "?" ["help"] (NoArg Help) "show options" - , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" - , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" - , Option "f" ["file"] (ReqArg InputFile "FILE") "use input FILE as request" - , Option "" ["fixed-rng"] (NoArg FixRNG) "use a fixed random-number generator" - , Option "" ["make-pages"] (docItemDescr (Pages . fromMaybe "docs")) "generate pages for exercises and services" - , Option "" ["make-rules"] (docItemDescr (LatexRules . fromMaybe "docs")) "generate latex code for rewrite rules" - , Option "" ["self-check"] (docItemDescr (SelfCheck . fromMaybe "test")) "perform a self-check" + [ Option [] ["version"] (NoArg Version) "show version number" + , Option "?" ["help"] (NoArg Help) "show options" + , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" + , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" + , Option "f" ["file"] (ReqArg InputFile "FILE") "use input FILE as request" + , Option "" ["fixed-rng"] (NoArg FixRNG) "use a fixed random-number generator" + , Option "" ["make-pages"] (NoArg $ DocItem Pages) "generate pages for exercises and services" + , Option "" ["self-check"] (NoArg $ DocItem SelfCheck) "perform a self-check" + , Option "" ["test"] (OptArg testArg "DIR") "run tests on directory (default: 'test')" + , Option "" ["docs-dir"] (ReqArg DocDir "DIR") "directory for documentation (default: 'docs')" + , Option "" ["test-dir"] (ReqArg TestDir "DIR") "directory with tests (default: 'test')" ] -docItemDescr :: (Maybe String -> DocItem) -> ArgDescr Flag -docItemDescr f = OptArg (DocItem . f) "DIR" +testArg :: Maybe String -> Flag +testArg = DocItem . BlackBox serviceOptions :: IO [Flag] serviceOptions = do @@ -77,6 +78,16 @@ docItems :: [Flag] -> [DocItem] docItems flags = [ x | DocItem x <- flags ] + +docDir :: [Flag] -> String +docDir flags = case [ d | DocDir d <- flags ] of + d:_ -> d + _ -> "docs" + +testDir :: [Flag] -> String +testDir flags = case [ d | TestDir d <- flags ] of + d:_ -> d + _ -> "test" documentationMode :: [Flag] -> Bool documentationMode = not . null . docItems diff --git a/src/Main/Revision.hs b/src/Main/Revision.hs --- a/src/Main/Revision.hs +++ b/src/Main/Revision.hs @@ -1,5 +1,8 @@ -- Automatically generated by Makefile. Do not change. module Main.Revision where -version = "0.6" -revision = 3065 -lastChanged = "ma, 19 apr 2010" +version :: String +version = "0.7" +revision :: Int +revision = 3724 +lastChanged :: String +lastChanged = "do, 23 dec 2010" diff --git a/src/Service/BasicServices.hs b/src/Service/BasicServices.hs new file mode 100644 --- /dev/null +++ b/src/Service/BasicServices.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.BasicServices + ( -- * Basic Services + stepsremaining, findbuggyrules, ready, allfirsts, derivation + , onefirst, applicable, allapplications, apply, generate, generateWith + ) where + +import Common.Library hiding (derivation, applicable, apply) +import Common.Utils (safeHead) +import Data.List +import Data.Maybe +import System.Random (StdGen, newStdGen) +import Control.Monad +import Service.ExercisePackage +import Service.State +import qualified Common.Classes as Apply + +-- result must be in the IO monad to access a standard random number generator +generate :: ExercisePackage a -> Int -> IO (State a) +generate pkg level = do + stdgen <- newStdGen + return (generateWith stdgen pkg level) + +generateWith :: StdGen -> ExercisePackage a -> Int -> State a +generateWith rng pkg level = + emptyState pkg (randomTermWith rng level (exercise pkg)) + +derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)] +derivation mcfg state = + case (statePrefix state, mcfg) of + (Nothing, _) -> fail "Prefix is required" + -- configuration is only allowed beforehand: hence, the prefix + -- should be empty (or else, the configuration is ignored). This + -- restriction should probably be relaxed later on. + (Just p, Just cfg) | null (prefixToSteps p) -> + let newStrategy = configure cfg (strategy ex) + newExercise = ex {strategy = newStrategy} + newPackage = pkg {exercise = newExercise} + in rec timeout [] (empyStateContext newPackage (stateContext state)) + _ -> rec timeout [] state + where + pkg = exercisePkg state + ex = exercise pkg + timeout = 50 :: Int + + rec i acc st = + case onefirst st of + Nothing -> return (reverse acc) + Just (r, _, next) + | i <= 0 -> fail msg + | otherwise -> rec (i-1) ((r, stateContext next) : acc) next + where + msg = "Time out after " ++ show timeout ++ " steps. " ++ + concatMap f (reverse acc) + f (r, c) = let s = maybe "???" (prettyPrinter ex) (fromContext c) + in "[" ++ show r ++ "] " ++ s ++ "; " + +-- Note that we have to inspect the last step of the prefix afterwards, because +-- the remaining part of the derivation could consist of minor rules only. +allfirsts :: Monad m => State a -> m [(Rule (Context a), Location, State a)] +allfirsts state = + case statePrefix state of + Nothing -> + fail "Prefix is required" + Just p0 -> + let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (stateContext state)) + f (r1, _, _) (r2, _, _) = + ruleOrdering (exercise (exercisePkg state)) r1 r2 + in return (sortBy f (mapMaybe make (derivations tree))) + where + stop (Just (RuleStep r)) = isMajorRule r + stop _ = False + + make d = do + prefixEnd <- safeHead (reverse (steps d)) + termEnd <- safeHead (reverse (terms d)) + case lastStepInPrefix prefixEnd of + Just (RuleStep r) | isMajorRule r -> return + ( r + , location termEnd + , makeState (exercisePkg state) (Just prefixEnd) termEnd + ) + _ -> Nothing + +onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a) +onefirst state = do + xs <- allfirsts state + case xs of + hd:_ -> return hd + [] -> fail "No step possible" + +applicable :: Location -> State a -> [Rule (Context a)] +applicable loc state = + let p r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (stateContext state)) + in filter p (ruleset (exercise (exercisePkg state))) + +allapplications :: State a -> [(Rule (Context a), Location, State a)] +allapplications state = xs ++ ys + where + pkg = exercisePkg state + ex = exercise pkg + xs = concat (allfirsts state) + ps = [ (r, loc) | (r, loc, _) <- xs ] + ys = maybe [] f (top (stateContext state)) + + f c = g c ++ concatMap f (allDowns c) + g c = [ (r, location new, makeState pkg Nothing new) + | r <- ruleset ex + , (r, location c) `notElem` ps + , new <- applyAll r c + ] + +-- local helper +setLocation :: Location -> Context a -> Context a +setLocation loc c0 = fromMaybe c0 (navigateTo loc c0) + +-- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the +-- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied +-- to the current term at the given location, in which case the request is invalid. +apply :: Monad m => Rule (Context a) -> Location -> State a -> m (State a) +apply r loc state = maybe applyOff applyOn (statePrefix state) + where + applyOn _ = -- scenario 1: on-strategy + maybe applyOff return $ safeHead + [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, showId r == showId r1, loc==loc1 ] + + applyOff = -- scenario 2: off-strategy + case Apply.apply r (setLocation loc (stateContext state)) of + Just new -> return (makeState (exercisePkg state) Nothing new) + Nothing -> fail ("Cannot apply " ++ show r) + +ready :: State a -> Bool +ready state = isReady (exercise (exercisePkg state)) (stateTerm state) + +stepsremaining :: Monad m => State a -> m Int +stepsremaining = liftM length . derivation Nothing + +findbuggyrules :: State a -> a -> [Rule (Context a)] +findbuggyrules state a = + let ex = exercise (exercisePkg state) + buggies = filter isBuggyRule (ruleset ex) + p r = ruleIsRecognized ex r (stateContext state) (inContext ex a) + in filter p buggies diff --git a/src/Service/Diagnose.hs b/src/Service/Diagnose.hs --- a/src/Service/Diagnose.hs +++ b/src/Service/Diagnose.hs @@ -12,38 +12,47 @@ -- ----------------------------------------------------------------------------- module Service.Diagnose - ( Diagnosis(..), RuleID, diagnose, restartIfNeeded + ( Diagnosis(..), diagnose, restartIfNeeded + , diagnosisType, diagnosisTypeSynonym ) where -import Common.Apply -import Common.Context -import Common.Exercise -import Common.Strategy (emptyPrefix) -import Common.Transformation +import Common.Library import Common.Utils (safeHead) +import Data.List (sortBy) import Data.Maybe -import Service.TypedAbstractService +import Service.ExercisePackage +import Service.State +import Service.BasicServices +import Service.Types ---------------------------------------------------------------- -- Result types for diagnose service -type RuleID a = Rule (Context a) - data Diagnosis a - = Buggy (RuleID a) + = Buggy (Rule (Context a)) | NotEquivalent | Similar Bool (State a) - | Expected Bool (State a) (RuleID a) - | Detour Bool (State a) (RuleID a) + | Expected Bool (State a) (Rule (Context a)) + | Detour Bool (State a) (Rule (Context a)) | Correct Bool (State a) +instance Show (Diagnosis a) where + show diagnosis = + case diagnosis of + Buggy r -> "Buggy rule " ++ show (show r) + NotEquivalent -> "Unknown mistake" + Similar _ _ -> "Very similar" + Expected _ _ r -> "Rule " ++ show (show r) ++ ", expected by strategy" + Detour _ _ r -> "Rule " ++ show (show r) ++ ", not following strategy" + Correct _ _ -> "Unknown step" + ---------------------------------------------------------------- -- The diagnose service diagnose :: State a -> a -> Diagnosis a diagnose state new -- Is the submitted term equivalent? - | not (equivalence ex (term state) new) = + | not (equivalenceContext ex (stateContext state) newc) = -- Is the rule used discoverable by trying all known buggy rules? case discovered True of Just r -> -- report the buggy rule @@ -52,7 +61,7 @@ NotEquivalent -- Is the submitted term (very) similar to the previous one? - | similarity ex (term state) new = + | similarity ex (stateTerm state) new = -- If yes, report this Similar (ready state) state @@ -64,35 +73,34 @@ -- Is the rule used discoverable by trying all known rules? | otherwise = - let ns = restartIfNeeded (state { prefix=Nothing, context=inContext ex new }) + let ns = restartIfNeeded (makeState pkg Nothing newc) in case discovered False of Just r -> -- If yes, report the found rule as a detour Detour (ready ns) ns r Nothing -> -- If not, we give up Correct (ready ns) ns where - ex = exercise state + pkg = exercisePkg state + ex = exercise pkg + newc = inContext ex new expected = do xs <- allfirsts (restartIfNeeded state) - let p (_, _, ns) = similarity ex new (term ns) + let p (_, _, ns) = similarity ex new (stateTerm ns) safeHead (filter p xs) discovered searchForBuggy = safeHead [ r - | r <- ruleset ex + | r <- sortBy (ruleOrdering ex) (ruleset ex) , isBuggyRule r == searchForBuggy - , ca <- applyAll r (inContext ex sub1) - -- , let s = prettyPrinter (exercise state) (fromContext a) - --, if s=="2*x+2 == 5" then True else error s - , a <- fromContext ca - , similarity ex sub2 a + , ruleIsRecognized ex r sub1 sub2 ] where - mode = not searchForBuggy - diff = difference ex mode (term state) new - (sub1, sub2) = fromMaybe (term state, new) diff - + (sub1, sub2) = + case difference ex (not searchForBuggy) (stateTerm state) new of + Just (a, b) -> (inContext ex a, inContext ex b) + Nothing -> (stateContext state, newc) + ---------------------------------------------------------------- -- Helpers @@ -100,14 +108,36 @@ -- Make sure that the new state has a prefix -- When resetting the prefix, also make sure that the context is refreshed restartIfNeeded :: State a -> State a -restartIfNeeded s - | isNothing (prefix s) && canBeRestarted ex = - case fromContext (context s) of - Just a -> s - { prefix = Just (emptyPrefix (strategy ex)) - , context = inContext ex a - } - Nothing -> s - | otherwise = s +restartIfNeeded state + | isNothing (statePrefix state) && canBeRestarted (exercise pkg) = + emptyState pkg (stateTerm state) + | otherwise = state where - ex = exercise s + pkg = exercisePkg state + +diagnosisType :: Type a (Diagnosis a) +diagnosisType = useSynonym diagnosisTypeSynonym + +diagnosisTypeSynonym :: TypeSynonym a (Diagnosis a) +diagnosisTypeSynonym = typeSynonym "Diagnosis" to from tp + where + to (Left r) = Buggy r + to (Right (Left ())) = NotEquivalent + to (Right (Right (Left (b, s)))) = Similar b s + to (Right (Right (Right (Left (b, s, r))))) = Expected b s r + to (Right (Right (Right (Right (Left (b, s, r)))))) = Detour b s r + to (Right (Right (Right (Right (Right (b, s)))))) = Correct b s + + from (Buggy r) = Left r + from (NotEquivalent) = Right (Left ()) + from (Similar b s) = Right (Right (Left (b, s))) + from (Expected b s r) = Right (Right (Right (Left (b, s, r)))) + from (Detour b s r) = Right (Right (Right (Right (Left (b, s, r))))) + from (Correct b s) = Right (Right (Right (Right (Right (b, s))))) + + tp = Rule + :|: Unit + :|: Pair Bool stateTp + :|: tuple3 Bool stateTp Rule + :|: tuple3 Bool stateTp Rule + :|: Pair Bool stateTp diff --git a/src/Service/DomainReasoner.hs b/src/Service/DomainReasoner.hs --- a/src/Service/DomainReasoner.hs +++ b/src/Service/DomainReasoner.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XMultiParamTypeClasses -XTypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -12,23 +12,25 @@ ----------------------------------------------------------------------------- module Service.DomainReasoner ( -- * Domain Reasoner data type - DomainReasoner, runDomainReasoner - , liftEither, liftIO, catchError + DomainReasoner, runDomainReasoner, runWithCurrent + , liftEither, MonadIO(..), catchError -- * Update functions , addPackages, addPackage, addPkgService - , addServices, addService + , addServices, addService, addTestSuite , setVersion, setFullVersion -- * Accessor functions , getPackages, getExercises, getServices - , getVersion, getFullVersion + , getVersion, getFullVersion, getTestSuite , findPackage, findService ) where -import Common.Exercise +import Common.Library +import Common.TestSuite import Common.Utils (Some(..)) import Control.Monad.Error import Control.Monad.State -import Service.ServiceList +import Data.Maybe +import Service.Types import Service.ExercisePackage ----------------------------------------------------------------------- @@ -39,12 +41,13 @@ data Content = Content { packages :: [Some ExercisePackage] , services :: [Some ExercisePackage] -> [Service] + , testSuite :: TestSuite , version :: String , fullVersion :: Maybe String } noContent :: Content -noContent = Content [] (const []) [] Nothing +noContent = Content [] (const []) (return ()) [] Nothing runDomainReasoner :: DomainReasoner a -> IO a runDomainReasoner m = do @@ -53,6 +56,11 @@ Left msg -> fail msg Right a -> return a +-- | Returns a run function, based on the current state, inside the monad +runWithCurrent :: DomainReasoner (DomainReasoner a -> IO a) +runWithCurrent = + get >>= \st -> return (runDomainReasoner . (put st >>)) + liftEither :: Either String a -> DomainReasoner a liftEither = either fail return @@ -68,6 +76,10 @@ throwError = fail catchError m f = DR (unDR m `catchError` (unDR . f)) +instance MonadPlus DomainReasoner where + mzero = DR mzero + a `mplus` b = DR (unDR a `mplus` unDR b) + instance MonadState Content DomainReasoner where get = DR get put s = DR (put s) @@ -89,11 +101,14 @@ c { services = \xs -> f xs : services c xs } addServices :: [Service] -> DomainReasoner () -addServices = mapM_ addPkgService . map const +addServices = mapM_ (addPkgService . const) addService :: Service -> DomainReasoner () addService s = addServices [s] +addTestSuite :: TestSuite -> DomainReasoner () +addTestSuite m = modify $ \c -> c { testSuite = testSuite c >> m } + setVersion :: String -> DomainReasoner () setVersion s = modify $ \c -> c { version = s } @@ -118,18 +133,60 @@ getFullVersion :: DomainReasoner String getFullVersion = gets fullVersion >>= maybe getVersion return -findPackage :: ExerciseCode -> DomainReasoner (Some ExercisePackage) -findPackage code = do +getTestSuite :: DomainReasoner TestSuite +getTestSuite = gets testSuite + +findPackage :: Id -> DomainReasoner (Some ExercisePackage) +findPackage i = do pkgs <- getPackages - let p (Some pkg) = exerciseCode (exercise pkg) == code - case filter p pkgs of + case [ a | a@(Some pkg) <- pkgs, getId pkg == resolveId i ] of [this] -> return this - _ -> fail $ "Package " ++ show code ++ " not found" + _ -> fail $ "Package " ++ show i ++ " not found" findService :: String -> DomainReasoner Service findService txt = do srvs <- getServices - case filter ((==txt) . serviceName) srvs of + case filter ((==txt) . showId) srvs of [hd] -> return hd [] -> fail $ "No service " ++ txt _ -> fail $ "Ambiguous service " ++ txt + +----------------------------------------------------------------------- +-- Identifier aliases (temporary) + +resolveId :: Id -> Id +resolveId i = fromMaybe i (lookup i table) + where + table = map (newId *** newId) + [ ("math.coverup", "algebra.equations.coverup") + , ("math.lineq", "algebra.equations.linear") + , ("math.lineq-mixed", "algebra.equations.linear.mixed") + , ("math.quadreq", "algebra.equations.quadratic") + , ("math.quadreq-no-abc", "algebra.equations.quadratic.no-abc") + , ("math.quadreq-with-approx", "algebra.equations.quadratic.approximate") + , ("math.higherdegree", "algebra.equations.polynomial") + , ("math.rationaleq", "algebra.equations.rational") + , ("math.linineq", "algebra.inequalities.linear") + , ("math.quadrineq", "algebra.inequalities.quadratic") + , ("math.ineqhigherdegree", "algebra.inequalities.polynomial") + , ("math.factor", "algebra.manipulation.polynomial.factor") + , ("math.simplifyrational", "algebra.manipulation.rational.simplify") + , ("math.simplifypower", "algebra.manipulation.exponents.simplify") + , ("math.nonnegexp", "algebra.manipulation.exponents.nonnegative") + , ("math.powerof", "algebra.manipulation.exponents.powerof") + , ("math.derivative", "calculus.differentiation") + , ("math.fraction", "arithmetic.fractions") + , ("math.calcpower", "arithmetic.exponents") + , ("linalg.gaussianelim", "linearalgebra.gaussianelim") + , ("linalg.gramschmidt", "linearalgebra.gramschmidt") + , ("linalg.linsystem", "linearalgebra.linsystem") + , ("linalg.systemwithmatrix", "linearalgebra.systemwithmatrix") + , ("logic.dnf", "logic.propositional.dnf") + , ("logic.dnf-unicode", "logic.propositional.dnf.unicode") + , ("relationalg.cnf", "relationalgebra.cnf") + -- MathDox compatibility + , ("gaussianelimination" , "linearalgebra.gaussianelim") + , ("gramschmidt" , "linearalgebra.gramschmidt") + , ("solvelinearsystem" , "linearalgebra.linsystem") + , ("solvelinearsystemwithmatrix", "linearalgebra.systemwithmatrix") + ] diff --git a/src/Service/Evaluator.hs b/src/Service/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Service/Evaluator.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GADTs, Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.Evaluator where + +import Common.Library +import Control.Monad +import Data.List +import Service.ExercisePackage +import Service.Types +import Service.DomainReasoner + +evalService :: Evaluator inp out a -> Service -> inp -> DomainReasoner out +evalService f = eval f . serviceFunction + +data Evaluator inp out a = Evaluator + { encoder :: Encoder out a + , decoder :: Decoder inp a + } + +data Encoder s a = Encoder + { encodeType :: forall t . Type a t -> t -> DomainReasoner s + , encodeTerm :: a -> DomainReasoner s + , encodeTuple :: [s] -> s + } + +data Decoder s a = Decoder + { decodeType :: forall t . Type a t -> s -> DomainReasoner (t, s) + , decodeTerm :: s -> DomainReasoner a + , decoderPackage :: ExercisePackage a + } + +decoderExercise :: Decoder s a -> Exercise a +decoderExercise = exercise . decoderPackage + +eval :: Evaluator inp out a -> TypedValue a -> inp -> DomainReasoner out +eval f (tv ::: tp) s = + case tp of + t1 :-> t2 -> do + (a, s1) <- decodeType (decoder f) t1 s + eval f (tv a ::: t2) s1 + _ -> + encodeType (encoder f) tp tv + +decodeDefault :: Decoder s a -> Type a t -> s -> DomainReasoner (t, s) +decodeDefault dec tp s = + case tp of + Iso f _ t -> liftM (first f) (decodeType dec t s) + Pair t1 t2 -> do + (a, s1) <- decodeType dec t1 s + (b, s2) <- decodeType dec t2 s1 + return ((a, b), s2) + t1 :|: t2 -> + liftM (first Left) (decodeType dec t1 s) `mplus` + liftM (first Right) (decodeType dec t2 s) + Unit -> + return ((), s) + Tag _ t1 -> + decodeType dec t1 s + ExercisePkg -> + return (decoderPackage dec, s) + _ -> + fail $ "No support for argument type: " ++ show tp + +encodeDefault :: Encoder s a -> Type a t -> t -> DomainReasoner s +encodeDefault enc tp tv = + case tp of + Iso _ f t -> encodeType enc t (f tv) + Pair t1 t2 -> do + let (a, b) = tv + x <- encodeType enc t1 a + y <- encodeType enc t2 b + return (encodeTuple enc [x, y]) + t1 :|: t2 -> case tv of + Left a -> encodeType enc t1 a + Right b -> encodeType enc t2 b + Unit -> return (encodeTuple enc []) + Tag _ t1 -> encodeType enc t1 tv + IO t1 -> do let pp s | "user error (" `isPrefixOf` s = init (drop 12 s) + | otherwise = s + result <- liftIO $ + liftM Right tv `catch` (return . Left . pp . show) + case result of + Left msg -> fail msg + Right a -> encodeType enc t1 a + Rule -> encodeType enc String (showId tv) + Term -> encodeTerm enc tv + Context -> fromContext tv >>= encodeType enc Term + Location -> encodeType enc String (show tv) + ExercisePkg -> return (encodeTuple enc []) + _ -> fail ("No support for result type: " ++ show tp) diff --git a/src/Service/ExercisePackage.hs b/src/Service/ExercisePackage.hs --- a/src/Service/ExercisePackage.hs +++ b/src/Service/ExercisePackage.hs @@ -18,17 +18,18 @@ , package, termPackage, somePackage, someTermPackage -- Conversion functions to/from OpenMath , termToOMOBJ, omobjToTerm + -- ExerciseText datatype + , ExerciseText(..) ) where +import Common.Library import Common.Utils (Some(..)) -import Common.Exercise -import Control.Monad import Common.Rewriting.Term +import Control.Monad import Data.Char import Data.List -import Service.FeedbackText (ExerciseText) import Text.OpenMath.Object -import Text.OpenMath.Symbol +import qualified Text.OpenMath.Symbol as OM import Text.OpenMath.Dictionary.Fns1 ----------------------------------------------------------------------------- @@ -42,6 +43,10 @@ , getExerciseText :: Maybe (ExerciseText a) } +instance HasId (ExercisePackage a) where + getId = getId . exercise + changeId f pkg = pkg { exercise = changeId f (exercise pkg) } + package :: Exercise a -> ExercisePackage a package ex = P { exercise = ex @@ -63,22 +68,20 @@ someTermPackage :: IsTerm a => Exercise a -> Some ExercisePackage someTermPackage = Some . termPackage - + ----------------------------------------------------------------------------- -- Utility functions for conversion to/from OpenMath termToOMOBJ :: Term -> OMOBJ termToOMOBJ term = case term of - Var s -> OMV s - Con s -> case s of - S (Just a) b -> OMS (makeSymbol a b) - S Nothing b -> OMS (extraSymbol b) - Meta i -> OMV ("$" ++ show i) - Num n -> OMI n - Float d -> OMF d - App _ _ -> let (f, xs) = getSpine term - in make (map termToOMOBJ (f:xs)) + Var s -> OMV s + Con s -> OMS (idToSymbol (getId s)) + Meta i -> OMV ('$' : show i) + Num n -> OMI n + Float d -> OMF d + Apply _ _ -> let (f, xs) = getSpine term + in make (map termToOMOBJ (f:xs)) where make [OMS s, OMV x, body] | s == lambdaSymbol = OMBIND (OMS s) [x] body @@ -90,7 +93,7 @@ OMV x -> case isMeta x of Just n -> return (Meta n) Nothing -> return (Var x) - OMS s -> return (Con (S (dictionary s) (symbolName s))) + OMS s -> return (symbol (newSymbol (OM.dictionary s # OM.symbolName s))) OMI n -> return (Num n) OMF a -> return (Float a) OMA (x:xs) -> liftM2 makeTerm (omobjToTerm x) (mapM omobjToTerm xs) @@ -100,3 +103,27 @@ where isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' isMeta _ = Nothing + +idToSymbol :: Id -> OM.Symbol +idToSymbol a + | null (qualifiers a) = + OM.extraSymbol (unqualified a) + | otherwise = + OM.makeSymbol (qualification a) (unqualified a) + +------------------------------------------------------------ +-- Exercise Text data type +-- Note: ideally, this should be defined elsewhere + +-- Exercise extension for textual feedback +data ExerciseText a = ExerciseText + { ruleText :: Rule (Context a) -> Maybe String + , appliedRule :: Rule (Context a) -> String + , feedbackSyntaxError :: String -> String + , feedbackSame :: String + , feedbackBuggy :: Bool -> [Rule (Context a)] -> String + , feedbackNotEquivalent :: Bool -> String + , feedbackOk :: [Rule (Context a)] -> (String, Bool) + , feedbackDetour :: Bool -> Maybe (Rule (Context a)) -> [Rule (Context a)] -> (String, Bool) + , feedbackUnknown :: Bool -> String + } diff --git a/src/Service/FeedbackText.hs b/src/Service/FeedbackText.hs --- a/src/Service/FeedbackText.hs +++ b/src/Service/FeedbackText.hs @@ -14,61 +14,49 @@ , onefirsttext, submittext, derivationtext, submitHelper ) where -import Control.Arrow -import Common.Context -import Common.Exercise -import Common.Transformation -import Common.Utils +import Common.Library hiding (derivation) import Data.Maybe +import Common.Utils import Service.Diagnose (restartIfNeeded) +import Service.ExercisePackage +import Service.State import Service.Submit -import Service.TypedAbstractService - ------------------------------------------------------------- --- Exercise Text data type - --- Exercise extension for textual feedback -data ExerciseText a = ExerciseText - { ruleText :: Rule (Context a) -> Maybe String - , appliedRule :: Rule (Context a) -> String - , feedbackSyntaxError :: String -> String - , feedbackSame :: String - , feedbackBuggy :: Bool -> [Rule (Context a)] -> String - , feedbackNotEquivalent :: Bool -> String - , feedbackOk :: [Rule (Context a)] -> (String, Bool) - , feedbackDetour :: Bool -> Maybe (Rule (Context a)) -> [Rule (Context a)] -> (String, Bool) - , feedbackUnknown :: Bool -> String - } - +import Service.BasicServices + ------------------------------------------------------------ -- Services -derivationtext :: Monad m => ExerciseText a -> State a -> Maybe String -> m [(String, Context a)] -derivationtext exText st _event = do - xs <- derivation Nothing st +derivationtext :: Monad m => State a -> Maybe String -> m [(String, Context a)] +derivationtext state _event = do + exText <- exerciseText state + xs <- derivation Nothing state return (map (first (showRule exText)) xs) -onefirsttext :: ExerciseText a -> State a -> Maybe String -> (Bool, String, State a) -onefirsttext exText state event = - case allfirsts state of - Just ((r, _, s):_) -> - let msg = case fromContext (context s) >>= useToRewrite exText r state of - Just txt | event /= Just "hint button" -> txt - _ -> "Use " ++ showRule exText r - in (True, msg, s) - _ -> (False, "Sorry, no hint available", state) +onefirsttext :: Monad m => State a -> Maybe String -> m (Bool, String, State a) +onefirsttext state event = + case onefirst state of + Just (r, _, s) -> do + exText <- exerciseText state + let mtxt = fromContext (stateContext s) >>= useToRewrite exText r state + msg = case mtxt of + Just txt | event /= Just "hint button" -> txt + _ -> "Use " ++ showRule exText r + return (True, msg, s) + _ -> return (False, "Sorry, no hint available", state) -submittext :: ExerciseText a -> State a -> String -> Maybe String -> (Bool, String, State a) -submittext exText state txt _event = - case parser (exercise state) txt of - Left err -> - (False, feedbackSyntaxError exText err, state) - Right a -> - let result = submit state a - (txt, b) = submitHelper exText state a result - in case getResultState result of - Just new | b -> (True, txt, restartIfNeeded new) - _ -> (False, txt, state) +submittext :: Monad m => State a -> String -> Maybe String -> m (Bool, String, State a) +submittext state input _event = do + exText <- exerciseText state + return $ + case parser (exercise (exercisePkg state)) input of + Left err -> + (False, feedbackSyntaxError exText err, state) + Right a -> + let result = submit state a + (txt, b) = submitHelper exText state a result + in case getResultState result of + Just new | b -> (True, txt, restartIfNeeded new) + _ -> (False, txt, state) -- Feedback messages for submit service (free student input). The boolean -- indicates whether the student is allowed to continue (True), or forced @@ -99,23 +87,25 @@ showRule :: ExerciseText a -> Rule (Context a) -> String showRule exText r = - case ruleText exText r of - Just s -> s - Nothing -> "rule " ++ name r + fromMaybe ("rule " ++ showId r) (ruleText exText r) useToRewrite :: ExerciseText a -> Rule (Context a) -> State a -> a -> Maybe String -useToRewrite exText rule old = rewriteIntoText True txt old +useToRewrite exText r old = rewriteIntoText True txt old where - txt = "Use " ++ showRule exText rule - ++ " to rewrite " + txt = "Use " ++ showRule exText r ++ " to rewrite " youRewroteInto :: State a -> a -> Maybe String youRewroteInto = rewriteIntoText False "You rewrote " rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String rewriteIntoText mode txt old a = do - let ex = exercise old - p <- fromContext (context old) + let ex = exercise (exercisePkg old) + p <- fromContext (stateContext old) (p1, a1) <- difference ex mode p a return $ txt ++ prettyPrinter ex p1 ++ " into " ++ prettyPrinter ex a1 ++ ". " + +exerciseText :: Monad m => State a -> m (ExerciseText a) +exerciseText = + let msg = "No support for textual feedback" + in maybe (fail msg) return . getExerciseText . exercisePkg diff --git a/src/Service/ModeJSON.hs b/src/Service/ModeJSON.hs --- a/src/Service/ModeJSON.hs +++ b/src/Service/ModeJSON.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XGADTs #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -14,18 +14,15 @@ ----------------------------------------------------------------------------- module Service.ModeJSON (processJSON, jsonTuple) where -import Common.Context +import Common.Library hiding (exerciseId) import Common.Utils (Some(..), distinct, readM) -import Common.Exercise -import Common.Strategy (makePrefix) -import Common.Transformation hiding (ruleList, defaultArgument) import Text.JSON import Service.Request -import Service.Types (TypedValue(..), Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..), decoderExercise) +import Service.State import qualified Service.Types as Tp -import qualified Service.TypedAbstractService as TAS +import Service.Types hiding (String) import Service.Submit -import Service.ServiceList hiding (Service) +import Service.Evaluator import Service.ExercisePackage import Service.DomainReasoner import Control.Monad @@ -33,14 +30,16 @@ import Data.Char -- TODO: Clean-up code -extractCode :: JSON -> ExerciseCode -extractCode = fromMaybe noCode . readCode . f +extractExerciseId :: Monad m => JSON -> m Id +extractExerciseId json = + case json of + String s -> return (newId s) + Array [String _, String _, a@(Array _)] -> extractExerciseId a + Array (String s:tl) | any p s -> extractExerciseId (Array tl) + Array (hd:_) -> extractExerciseId hd + _ -> fail "no code" where - f (String s) = s - f (Array [String _, String _, a@(Array _)]) = f a - f (Array (String s:tl)) | any (\c -> not (isAlphaNum c || isSpace c || c `elem` ".-")) s = f (Array tl) - f (Array (hd:_)) = f hd - f _ = "" + p c = not (isAlphaNum c || isSpace c || c `elem` ".-") processJSON :: String -> DomainReasoner (Request, String, String) processJSON input = do @@ -64,7 +63,7 @@ srv <- case lookupM "method" json of Just (String s) -> return s _ -> fail "Invalid method" - code <- liftM (return . extractCode) (lookupM "params" json) + let a = (lookupM "params" json >>= extractExerciseId) enc <- case lookupM "encoding" json of Nothing -> return Nothing Just (String s) -> liftM Just (readEncoding s) @@ -75,7 +74,7 @@ _ -> fail "Invalid source" return Request { service = srv - , exerciseID = code + , exerciseId = a , source = src , dataformat = JSON , encoding = enc @@ -83,38 +82,45 @@ myHandler :: JSON_RPC_Handler DomainReasoner myHandler fun arg = do - pkg <- if fun == "exerciselist" - then return (Some (package emptyExercise)) - else findPackage (extractCode arg) - srv <- findService fun + pkg <- if fun == "exerciselist" + then return (Some (package emptyExercise)) + else extractExerciseId arg >>= findPackage + srv <- findService fun case jsonConverter pkg of - Some conv -> do - either fail return (evalService conv srv arg) + Some conv -> + evalService conv srv arg -jsonConverter :: Some ExercisePackage -> Some (Evaluator (Either String) JSON JSON) +jsonConverter :: Some ExercisePackage -> Some (Evaluator JSON JSON) jsonConverter (Some pkg) = Some (Evaluator (jsonEncoder (exercise pkg)) (jsonDecoder pkg)) -jsonEncoder :: Monad m => Exercise a -> Encoder m JSON a +jsonEncoder :: Exercise a -> Encoder JSON a jsonEncoder ex = Encoder { encodeType = encode (jsonEncoder ex) , encodeTerm = return . String . prettyPrinter ex , encodeTuple = jsonTuple } where - encode :: Monad m => Encoder m JSON a -> Type a t -> t -> m JSON + encode :: Encoder JSON a -> Type a t -> t -> DomainReasoner JSON encode enc serviceType a | length xs > 1 = liftM jsonTuple (mapM (\(b ::: t) -> encode enc t b) xs) | otherwise = case serviceType of + Tp.Tag s t | s == "Result" -> do + result <- isSynonym submitTypeSynonym (a ::: serviceType) + encodeResult enc result + | s == "elem" -> + encode enc t a + | s == "State" -> do + st <- isSynonym stateTypeSynonym (a ::: serviceType) + encodeState (encodeTerm enc) st + Tp.List t -> liftM Array (mapM (encode enc t) a) Tp.Tag s t -> liftM (\b -> Object [(s, b)]) (encode enc t a) Tp.Int -> return (toJSON a) Tp.Bool -> return (toJSON a) Tp.String -> return (toJSON a) - Tp.State -> encodeState (encodeTerm enc) a - Tp.Result -> encodeResult enc a _ -> encodeDefault enc serviceType a where xs = tupleList (a ::: serviceType) @@ -124,8 +130,8 @@ tupleList (p ::: Tp.Pair t1 t2) = tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2) tupleList tv = [tv] - -jsonDecoder :: MonadPlus m => ExercisePackage a -> Decoder m JSON a + +jsonDecoder :: ExercisePackage a -> Decoder JSON a jsonDecoder pkg = Decoder { decodeType = decode (jsonDecoder pkg) , decodeTerm = reader (exercise pkg) @@ -136,23 +142,25 @@ reader ex (String s) = either (fail . show) return (parser ex s) reader _ _ = fail "Expecting a string when reading a term" - decode :: MonadPlus m => Decoder m JSON a -> Type a t -> JSON -> m (t, JSON) + decode :: Decoder JSON a -> Type a t -> JSON -> DomainReasoner (t, JSON) decode dec serviceType = case serviceType of - Tp.State -> useFirst $ decodeState (decoderExercise dec) (decodeTerm dec) Tp.Location -> useFirst decodeLocation Tp.Term -> useFirst $ decodeTerm dec - Tp.Rule -> useFirst $ \x -> fromJSON x >>= getRule (decoderExercise dec) - Tp.Exercise -> \json -> case json of - (Array (String _:rest)) -> return (decoderExercise dec, Array rest) - _ -> return (decoderExercise dec, json) + Tp.Rule -> useFirst $ \x -> jsonToId x >>= getRule (decoderExercise dec) + Tp.ExercisePkg -> \json -> case json of + Array (String _:rest) -> return (decoderPackage dec, Array rest) + _ -> return (decoderPackage dec, json) Tp.Int -> useFirst $ \json -> case json of Number (I n) -> return (fromIntegral n) _ -> fail "not an integer" Tp.String -> useFirst $ \json -> case json of String s -> return s _ -> fail "not a string" - _ -> decodeDefault dec serviceType + Tp.Tag s _ | s == "State" -> do + f <- equalM stateTp serviceType + useFirst (liftM f . decodeState (decoderPackage dec) (decodeTerm dec)) + _ -> decodeDefault dec serviceType useFirst :: Monad m => (JSON -> m a) -> JSON -> m (a, JSON) useFirst f (Array (x:xs)) = do @@ -160,20 +168,23 @@ return (a, Array xs) useFirst _ _ = fail "expecting an argument" +jsonToId :: Monad m => JSON -> m Id +jsonToId = liftM (newId :: String -> Id) . fromJSON + decodeLocation :: Monad m => JSON -> m [Int] decodeLocation (String s) = readM s decodeLocation _ = fail "expecting a string for a location" -------------------------- -encodeState :: Monad m => (a -> m JSON) -> TAS.State a -> m JSON +encodeState :: Monad m => (a -> m JSON) -> State a -> m JSON encodeState f st = do - theTerm <- f (TAS.term st) + theTerm <- f (stateTerm st) return $ Array - [ String (show (exerciseCode (TAS.exercise st))) - , String (maybe "NoPrefix" show (TAS.prefix st)) + [ String (showId (exercisePkg st)) + , String (maybe "NoPrefix" show (statePrefix st)) , theTerm - , encodeContext (getEnvironment (TAS.context st)) + , encodeContext (getEnvironment (stateContext st)) ] encodeContext :: Environment -> JSON @@ -181,16 +192,14 @@ where f k = (k, String $ fromMaybe "" $ lookupEnv k env) -decodeState :: Monad m => Exercise a -> (JSON -> m a) -> JSON -> m (TAS.State a) -decodeState ex f (Array [a]) = decodeState ex f a -decodeState ex f (Array [String _code, String p, ce, jsonContext]) = do +decodeState :: Monad m => ExercisePackage a -> (JSON -> m a) -> JSON -> m (State a) +decodeState pkg f (Array [a]) = decodeState pkg f a +decodeState pkg f (Array [String _code, String p, ce, jsonContext]) = do + let ex = exercise pkg + mpr = readM p >>= (`makePrefix` strategy ex) a <- f ce env <- decodeContext jsonContext - return TAS.State - { TAS.exercise = ex - , TAS.prefix = readM p >>= (`makePrefix` strategy ex) - , TAS.context = makeContext ex env a - } + return $ makeState pkg mpr (makeContext ex env a) decodeState _ _ s = fail $ "invalid state" ++ show s decodeContext :: Monad m => JSON -> m Environment @@ -201,26 +210,26 @@ add _ _ = fail "invalid item in context" decodeContext json = fail $ "invalid context: " ++ show json -encodeResult :: Monad m => Encoder m JSON a -> Result a -> m JSON +encodeResult :: Encoder JSON a -> Result a -> DomainReasoner JSON encodeResult enc result = case result of - -- TAS.SyntaxError _ -> [("result", String "SyntaxError")] - Buggy rs -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)] + -- SyntaxError _ -> [("result", String "SyntaxError")] + Buggy rs -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . showId) rs)] NotEquivalent -> return $ Object [("result", String "NotEquivalent")] Ok rs st -> do - json <- encodeType enc Tp.State st - return $ Object [("result", String "Ok"), ("rules", Array $ map (String . name) rs), ("state", json)] + json <- encodeType enc stateTp st + return $ Object [("result", String "Ok"), ("rules", Array $ map (String . showId) rs), ("state", json)] Detour rs st -> do - json <- encodeType enc Tp.State st - return $ Object [("result", String "Detour"), ("rules", Array $ map (String . name) rs), ("state", json)] + json <- encodeType enc stateTp st + return $ Object [("result", String "Detour"), ("rules", Array $ map (String . showId) rs), ("state", json)] Unknown st -> do - json <- encodeType enc Tp.State st + json <- encodeType enc stateTp st return $ Object [("result", String "Unknown"), ("state", json)] jsonTuple :: [JSON] -> JSON jsonTuple xs = case mapM f xs of - Just xs | distinct (map fst xs) -> Object xs + Just ys | distinct (map fst ys) -> Object ys _ -> Array xs where f (Object [p]) = Just p diff --git a/src/Service/ModeXML.hs b/src/Service/ModeXML.hs --- a/src/Service/ModeXML.hs +++ b/src/Service/ModeXML.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XGADTs #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -17,10 +17,7 @@ , resultOk, resultError, addVersion ) where -import Common.Navigator -import Common.Context -import Common.Exercise -import Common.Strategy hiding (not, fail) +import Common.Library hiding (exerciseId) import Common.Utils (Some(..), readM) import Control.Monad import Data.Char @@ -30,15 +27,14 @@ import Service.ProblemDecomposition import Service.Request import Service.RulesInfo (rulesInfoXML) -import Service.ServiceList import Service.StrategyInfo -import Service.TypedAbstractService hiding (exercise) +import Service.State import Service.Diagnose -import Service.Types hiding (State) +import Service.Types +import qualified Service.Types as Tp +import Service.Evaluator import Text.OpenMath.Object import Text.XML -import qualified Common.Transformation as Rule -import qualified Service.Types as Tp import Service.DomainReasoner processXML :: String -> DomainReasoner (Request, String, String) @@ -46,7 +42,7 @@ xml <- liftEither (parseXML input) req <- liftEither (xmlRequest xml) resp <- xmlReply req xml - `catchError` \msg -> return (resultError msg) + `catchError` (return . resultError) vers <- getVersion let out = showXML (if null vers then resp else addVersion vers resp) return (req, out, "application/xml") @@ -61,59 +57,38 @@ unless (name xml == "request") $ fail "expected xml tag request" srv <- findAttribute "service" xml - let code = extractExerciseCode xml + let a = extractExerciseId xml enc <- case findAttribute "encoding" xml of Just s -> liftM Just (readEncoding s) Nothing -> return Nothing return Request { service = srv - , exerciseID = code + , exerciseId = a , source = findAttribute "source" xml , dataformat = XML , encoding = enc } xmlReply :: Request -> XML -> DomainReasoner XML -xmlReply request xml - | service request == "mathdox" = do - code <- maybe (fail "unknown exercise code") return (exerciseID request) - Some pkg <- findPackage code - (st, sloc, answer) <- liftEither $ xmlToRequest xml (fromOpenMath pkg) (exercise pkg) - return (replyToXML (toOpenMath pkg) (problemDecomposition st sloc answer)) - xmlReply request xml = do srv <- findService (service request) pkg <- - case exerciseID request of + case exerciseId request of Just code -> findPackage code Nothing | service request == "exerciselist" -> return (Some (package emptyExercise)) | otherwise -> fail "unknown exercise code" - Some conv <- return $ + Some conv <- case encoding request of - Just StringEncoding -> stringFormatConverter pkg - _ -> openMathConverter pkg - res <- liftEither $ evalService conv srv xml + Just StringEncoding -> return (stringFormatConverter pkg) + _ -> return (openMathConverter pkg) + res <- evalService conv srv xml return (resultOk res) -extractExerciseCode :: Monad m => XML -> m ExerciseCode -extractExerciseCode xml = - case liftM (break (== '.')) (findAttribute "exerciseid" xml) of - Just (as, _:bs) -> return (makeCode as bs) - Just (as, _) -> maybe (fail "invalid code") return (readCode as) - -- being backwards compatible with early MathDox - Nothing -> do - let getName = map toLower . filter isAlphaNum . getData - linalg = return . makeCode "linalg" - case fmap getName (findChild "strategy" xml) of - Just name - | name == "gaussianelimination" -> linalg "gaussianelim" - | name == "gramschmidt" -> linalg "gramschmidt" - | name == "solvelinearsystem" -> linalg "linsystem" - | name == "solvelinearsystemwithmatrix" -> linalg "systemwithmatrix" - _ -> fail "no exerciseid attribute, nor a known strategy element" +extractExerciseId :: Monad m => XML -> m Id +extractExerciseId = liftM newId . findAttribute "exerciseid" resultOk :: XMLBuilder -> XML resultOk body = makeXML "reply" $ do @@ -128,91 +103,109 @@ ------------------------------------------------------------ -- Mixing abstract syntax (OpenMath format) and concrete syntax (string) -stringFormatConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder) +stringFormatConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder) stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg) -stringFormatConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a +stringFormatConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a stringFormatConverterTp pkg = - Evaluator (xmlEncoder False f ex) (xmlDecoder False g pkg) + Evaluator (xmlEncoder False f pkg) (xmlDecoder False g pkg) where ex = exercise pkg f = return . element "expr" . text . prettyPrinter ex - g xml = do - xml <- findChild "expr" xml -- quick fix + g xml0 = do + xml <- findChild "expr" xml0 -- quick fix -- guard (name xml == "expr") let input = getData xml either (fail . show) return (parser ex input) -openMathConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder) +openMathConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder) openMathConverter (Some pkg) = Some (openMathConverterTp pkg) -openMathConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a +openMathConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a openMathConverterTp pkg = - Evaluator (xmlEncoder True f ex) (xmlDecoder True g pkg) + Evaluator (xmlEncoder True f pkg) (xmlDecoder True g pkg) where - ex = exercise pkg f = return . builder . toXML . toOpenMath pkg g xml = do xob <- findChild "OMOBJ" xml - omobj <- xml2omobj xob + omobj <- liftEither (xml2omobj xob) case fromOpenMath pkg omobj of Just a -> return a Nothing -> fail "Unknown OpenMath object" -xmlEncoder :: Monad m => Bool -> (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a -xmlEncoder b f ex = Encoder - { encodeType = encode (xmlEncoder b f ex) ex +xmlEncoder :: Bool -> (a -> DomainReasoner XMLBuilder) -> ExercisePackage a -> Encoder XMLBuilder a +xmlEncoder b f pkg = Encoder + { encodeType = xmlEncodeType b (xmlEncoder b f pkg) pkg , encodeTerm = f , encodeTuple = sequence_ } - where - encode :: Monad m => Encoder m XMLBuilder a -> Exercise a -> Type a t -> t -> m XMLBuilder - encode enc ex serviceType = - case serviceType of - Tp.List t1 -> \xs -> - case allAreTagged t1 of - Just f -> do - let make = element "elem" . mapM_ (uncurry (.=.)) . f - let elems = mapM_ make xs - return (element "list" elems) - _ -> do - bs <- mapM (encode enc ex t1) xs - let elems = mapM_ (element "elem") bs - return (element "list" elems) - Tp.Elem t1 -> liftM (element "elem") . encode enc ex t1 - Tp.Tag s t1 -> liftM (element s) . encode enc ex t1 -- quick fix - Tp.Strategy -> return . builder . strategyToXML - Tp.Rule -> return . ("ruleid" .=.) . Rule.name - Tp.RulesInfo -> \_ -> rulesInfoXML ex (encodeTerm enc) - Tp.Term -> encodeTerm enc - Tp.Diagnosis -> encodeDiagnosis b (encodeTerm enc) - Tp.Context -> encodeContext b (encodeTerm enc) - Tp.Location -> return . {-element "location" .-} text . show - Tp.Bool -> return . text . map toLower . show - Tp.String -> return . text - Tp.Int -> return . text . show - Tp.State -> encodeState b (encodeTerm enc) - _ -> encodeDefault enc serviceType -xmlDecoder :: MonadPlus m => Bool -> (XML -> m a) -> ExercisePackage a -> Decoder m XML a +xmlEncodeType :: Bool -> Encoder XMLBuilder a -> ExercisePackage a -> Type a t -> t -> DomainReasoner XMLBuilder +xmlEncodeType b enc pkg serviceType = + case serviceType of + Tp.Tag s _ + | s == "Diagnosis" -> \a -> do + d <- isSynonym diagnosisTypeSynonym (a ::: serviceType) + encodeDiagnosis b (encodeTerm enc) d + | s == "DecompositionReply" -> \a -> do + reply <- isSynonym replyTypeSynonym (a ::: serviceType) + encodeReply (encodeState b (encodeTerm enc)) reply + | s == "RulesInfo" -> \_ -> + rulesInfoXML (exercise pkg) (encodeTerm enc) + | s == "State" -> \a -> do + st <- isSynonym stateTypeSynonym (a ::: serviceType) + encodeState b (encodeTerm enc) st + Tp.List t1 -> \xs -> + case allAreTagged t1 of + Just f -> do + let make = element "elem" . mapM_ (uncurry (.=.)) . f + let elems = mapM_ make xs + return (element "list" elems) + _ -> do + bs <- mapM (xmlEncodeType b enc pkg t1) xs + let elems = mapM_ (element "elem") bs + return (element "list" elems) + Tp.Tag s t1 -> liftM (element s) . xmlEncodeType b enc pkg t1 -- quick fix + Tp.Strategy -> return . builder . strategyToXML + Tp.Rule -> return . ("ruleid" .=.) . showId + Tp.Term -> encodeTerm enc + Tp.Context -> encodeContext b (encodeTerm enc) + Tp.Location -> return . {-element "location" .-} text . show + Tp.Id -> return . text . show + Tp.Bool -> return . text . map toLower . show + Tp.String -> return . text + Tp.Int -> return . text . show + _ -> encodeDefault enc serviceType + +xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> ExercisePackage a -> Decoder XML a xmlDecoder b f pkg = Decoder - { decodeType = decode (xmlDecoder b f pkg) + { decodeType = xmlDecodeType b (xmlDecoder b f pkg) , decodeTerm = f , decoderPackage = pkg } - where - decode :: MonadPlus m => Decoder m XML a -> Type a t -> XML -> m (t, XML) - decode dec serviceType = - case serviceType of - Tp.State -> decodeState b (decoderExercise dec) (decodeTerm dec) - Tp.Location -> leave $ liftM (read . getData) . findChild "location" - Tp.Rule -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid" - Tp.Term -> \xml -> decodeTerm dec xml >>= \a -> return (a, xml) - Tp.StrategyCfg -> decodeConfiguration - _ -> decodeDefault dec serviceType - - leave :: Monad m => (XML -> m a) -> XML -> m (a, XML) - leave f xml = liftM (\a -> (a, xml)) (f xml) + +xmlDecodeType :: Bool -> Decoder XML a -> Type a t -> XML -> DomainReasoner (t, XML) +xmlDecodeType b dec serviceType = + case serviceType of + Tp.Context -> keep $ decodeContext b (decoderPackage dec) (decodeTerm dec) + Tp.Location -> keep $ liftM (read . getData) . findChild "location" + Tp.Id -> keep $ \xml -> do + a <- findChild "location" xml + return (newId (getData a)) + Tp.Rule -> keep $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . newId . getData) . findChild "ruleid" + Tp.Term -> keep $ decodeTerm dec + Tp.StrategyCfg -> decodeConfiguration + Tp.Tag s t + | s == "State" -> \xml -> do + g <- equalM stateTp serviceType + st <- decodeState b (decoderPackage dec) (decodeTerm dec) xml + return (g st, xml) + | s == "answer" -> \xml -> + findChild "answer" xml >>= xmlDecodeType b dec t + _ -> decodeDefault dec serviceType + where + keep :: Monad m => (XML -> m a) -> XML -> m (a, XML) + keep f xml = liftM (\a -> (a, xml)) (f xml) allAreTagged :: Type a t -> Maybe (t -> [(String, String)]) allAreTagged (Iso _ f t) = fmap (. f) (allAreTagged t) @@ -220,32 +213,39 @@ f1 <- allAreTagged t1 f2 <- allAreTagged t2 return $ \(a,b) -> f1 a ++ f2 b -allAreTagged (Tag tag Bool) = Just $ \b -> [(tag, map toLower (show b))] -allAreTagged (Tag tag String) = Just $ \s -> [(tag, s)] +allAreTagged (Tag s Bool) = Just $ \b -> [(s, map toLower (show b))] +allAreTagged (Tag s String) = Just $ \a -> [(s, a)] allAreTagged _ = Nothing -decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a, XML) -decodeState b ex f top = do - xml <- findChild "state" top +decodeState :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (State a) +decodeState b pkg f xmlTop = do + xml <- findChild "state" xmlTop unless (name xml == "state") (fail "expected a state tag") - mpr <- case maybe "" getData (findChild "prefix" xml) of - prefixText - | all isSpace prefixText -> - return (Just (emptyPrefix (strategy ex))) - | prefixText ~= "no prefix" -> - return Nothing - | otherwise -> do - a <- readM prefixText - pr <- makePrefix a (strategy ex) - return (Just pr) - expr <- f xml - env <- decodeEnvironment b xml - let state = State ex mpr term - term = makeContext ex env expr - return (state, top) + mpr <- decodePrefix pkg xml + term <- decodeContext b pkg f xml + return (makeState pkg mpr term) + +decodePrefix :: Monad m => ExercisePackage a -> XML -> m (Maybe (Prefix (Context a))) +decodePrefix pkg xml + | all isSpace prefixText = + return (Just (emptyPrefix str)) + | prefixText ~= "no prefix" = + return Nothing + | otherwise = do + a <- readM prefixText + pr <- makePrefix a str + return (Just pr) where + prefixText = maybe "" getData (findChild "prefix" xml) + str = strategy (exercise pkg) a ~= b = g a == g b g = map toLower . filter (not . isSpace) + +decodeContext :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (Context a) +decodeContext b pkg f xml = do + expr <- f xml + env <- decodeEnvironment b xml + return (makeContext (exercise pkg) env expr) decodeEnvironment :: Monad m => Bool -> XML -> m Environment decodeEnvironment b xml = @@ -256,18 +256,18 @@ add env item = do unless (name item == "item") $ fail $ "expecting item tag, found " ++ name item - name <- findAttribute "name" item + n <- findAttribute "name" item case findChild "OMOBJ" item of -- OpenMath object found inside item tag - Just this | b -> do + Just this | b -> case xml2omobj this >>= omobjToTerm of Left err -> fail err Right term -> - return (storeEnv name term env) + return (storeEnv n term env) -- Simple value in attribute _ -> do value <- findAttribute "value" item - return (storeEnv name value env) + return (storeEnv n value env) decodeConfiguration :: MonadPlus m => XML -> m (StrategyConfiguration, XML) decodeConfiguration xml = @@ -282,22 +282,25 @@ Just a -> return a Nothing -> fail $ "unknown action " ++ show (name item) cfgloc <- findAttribute "name" item - return $ (ByName cfgloc, action) - + return (byName (newId cfgloc), action) encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder -encodeState b f state = f (term state) >>= \body -> return $ - element "state" $ do - element "prefix" (text $ maybe "no prefix" show (prefix state)) - let env = getEnvironment (context state) - encodeEnvironment b (location (context state)) env +encodeState b f state = do + body <- f (stateTerm state) + return $ element "state" $ do + encodePrefix (statePrefix state) + let env = getEnvironment (stateContext state) + encodeEnvironment b (location (stateContext state)) env body +encodePrefix :: Maybe (Prefix a) -> XMLBuilder +encodePrefix = element "prefix" . text . maybe "no prefix" show + encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder encodeEnvironment b loc env0 | nullEnv env = return () - | otherwise = element "context" $ do - forM_ (keysEnv env) $ \k -> do + | otherwise = element "context" $ + forM_ (keysEnv env) $ \k -> element "item" $ do "name" .=. k case lookupEnv k env of @@ -310,18 +313,18 @@ encodeDiagnosis :: Monad m => Bool -> (a -> m XMLBuilder) -> Diagnosis a -> m XMLBuilder encodeDiagnosis mode f diagnosis = case diagnosis of - Buggy r -> return $ element "buggy" $ "ruleid" .=. Rule.name r + Buggy r -> return $ element "buggy" $ "ruleid" .=. showId r NotEquivalent -> return $ tag "notequiv" Similar b s -> ok "similar" b s Nothing - Expected b s r -> ok "expected" b s (Just r) - Detour b s r -> ok "detour" b s (Just r) + Expected b s r -> ok "expected" b s (Just (showId r)) + Detour b s r -> ok "detour" b s (Just (showId r)) Correct b s -> ok "correct" b s Nothing where ok t b s mr = do body <- encodeState mode f s return $ element t $ do "ready" .=. map toLower (show b) - maybe (return ()) (("ruleid" .=.) . Rule.name) mr + maybe (return ()) ("ruleid" .=.) mr body encodeContext :: Monad m => Bool -> (a -> m XMLBuilder) -> Context a -> m XMLBuilder diff --git a/src/Service/ProblemDecomposition.hs b/src/Service/ProblemDecomposition.hs --- a/src/Service/ProblemDecomposition.hs +++ b/src/Service/ProblemDecomposition.hs @@ -11,101 +11,85 @@ ----------------------------------------------------------------------------- module Service.ProblemDecomposition ( problemDecomposition - , Reply, replyToXML, xmlToRequest + , replyType, replyTypeSynonym, encodeReply ) where -import Common.Apply -import Common.Context -import Common.Exercise -import Common.Derivation -import Common.Strategy hiding (not, repeat, fail) -import Common.Transformation +import Common.Library import Common.Utils -import Data.Char +import Control.Monad import Data.Maybe -import Service.TypedAbstractService (State(..), stepsremaining) +import Service.ExercisePackage +import Service.State +import Service.Types import Text.XML hiding (name) -import qualified Text.XML as XML -import Control.Monad -import Text.OpenMath.Object -replyError :: String -> String -> Reply a -replyError kind = Error . ReplyError kind - -problemDecomposition :: State a -> StrategyLocation -> Maybe a -> Reply a -problemDecomposition (State ex mpr requestedTerm) sloc answer +problemDecomposition :: Monad m => Maybe Id -> State a -> Maybe a -> m (Reply a) +problemDecomposition msloc state answer | isNothing $ subStrategy sloc (strategy ex) = - replyError "request error" "invalid location for strategy" + fail "request error: invalid location for strategy" | otherwise = - let pr = fromMaybe (emptyPrefix $ strategy ex) mpr in + let pr = fromMaybe (emptyPrefix $ strategy ex) (statePrefix state) in case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of - ([], _) -> replyError "strategy error" "not able to compute an expected answer" + ([], _) -> fail "strategy error: not able to compute an expected answer" (answers, Just answeredTerm) - | not (null witnesses) -> - Ok ReplyOk - { repOk_Code = ex - , repOk_Location = nextTaskLocation sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses) - , repOk_Context = show newPrefix ++ ";" ++ - show (getEnvironment $ fst $ head witnesses) - , repOk_Steps = fromMaybe 0 $ stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses) - } + | not (null witnesses) -> return $ + Ok newLocation newState where witnesses = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers - newPrefix = snd (head witnesses) - ((expected, prefix):_, maybeAnswer) -> - Incorrect ReplyIncorrect - { repInc_Code = ex - , repInc_Location = subTaskLocation sloc loc - , repInc_Expected = fromJust (fromContext expected) - , repInc_Derivation = derivation - , repInc_Arguments = args - , repInc_Steps = fromMaybe 0 $ stepsremaining $ State ex (Just pr) requestedTerm - , repInc_Equivalent = maybe False (equivalenceContext ex expected) maybeAnswer - } + (newCtx, newPrefix) = head witnesses + newLocation = nextTaskLocation (strategy ex) sloc $ + fromMaybe topId $ nextMajorForPrefix newPrefix newCtx + newState = makeState pkg (Just newPrefix) newCtx + ((expected, pref):_, maybeAnswer) -> return $ + Incorrect isEquiv newLocation expState arguments where - (loc, args) = firstMajorInPrefix pr prefix requestedTerm - derivation = - let len = length $ prefixToSteps pr - rules = stepsToRules $ drop len $ prefixToSteps prefix - f (s, a) = (s, fromJust (fromContext a)) - in map f (makeDerivation requestedTerm rules) - + newLocation = subTaskLocation (strategy ex) sloc loc + expState = makeState pkg (Just pref) expected + isEquiv = maybe False (equivalenceContext ex expected) maybeAnswer + (loc, arguments) = fromMaybe (topId, []) $ + firstMajorInPrefix pr pref requestedTerm + where + pkg = exercisePkg state + ex = exercise pkg + topId = getId (strategy ex) + sloc = fromMaybe topId msloc + requestedTerm = stateContext state + similarityCtx :: Exercise a -> Context a -> Context a -> Bool similarityCtx ex a b = fromMaybe False $ liftM2 (similarity ex) (fromContext a) (fromContext b) -- | Continue with a prefix until a certain strategy location is reached. At least one -- major rule should have been executed -runPrefixLocation :: StrategyLocation -> Prefix a -> a -> [(a, Prefix a)] -runPrefixLocation loc p0 = - concatMap (check . f) . derivations . +runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)] +runPrefixLocation loc p0 = + concatMap (checkPair . f) . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0 where f d = (last (terms d), if isEmpty d then p0 else last (steps d)) - stop (Just (End is _)) = is==loc + stop (Just (Exit info)) = getId info == loc stop _ = False - check result@(a, p) + checkPair result@(a, p) | null rules = [result] | all isMinorRule rules = runPrefixLocation loc p a | otherwise = [result] where rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p -firstMajorInPrefix :: Prefix a -> Prefix a -> a -> (StrategyLocation, Args) -firstMajorInPrefix p0 prefix a = fromMaybe (topLocation, []) $ do - let steps = prefixToSteps prefix - newSteps = drop (length $ prefixToSteps p0) steps +firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, Args) +firstMajorInPrefix p0 p a = do + let newSteps = drop (length $ prefixToSteps p0) (prefixToSteps p) is <- firstLocation newSteps return (is, argumentsForSteps a newSteps) where - firstLocation :: [Step a] -> Maybe StrategyLocation + firstLocation :: HasId l => [Step l a] -> Maybe Id firstLocation [] = Nothing - firstLocation (Begin is _:Step r:_) | isMajorRule r = Just is + firstLocation (Enter info:RuleStep r:_) | isMajorRule r = Just (getId info) firstLocation (_:rest) = firstLocation rest -argumentsForSteps :: a -> [Step a] -> Args -argumentsForSteps a = flip rec a . stepsToRules +argumentsForSteps :: a -> [Step l a] -> Args +argumentsForSteps a0 = flip rec a0 . stepsToRules where rec [] _ = [] rec (r:rs) a @@ -114,22 +98,15 @@ in maybe [] (zip ds) (expectedArguments r a) | otherwise = [] -nextMajorForPrefix :: Prefix a -> a -> StrategyLocation -nextMajorForPrefix p0 a = fromMaybe topLocation $ do +nextMajorForPrefix :: Prefix a -> a -> Maybe Id +nextMajorForPrefix p0 a = do (_, p1) <- safeHead $ runPrefixMajor p0 a - let steps = prefixToSteps p1 - rec (reverse steps) + rec (reverse (prefixToSteps p1)) where rec [] = Nothing - rec (Begin is _:_) = Just is - rec (End is _:_) = Just is - rec (_:rest) = rec rest - -makeDerivation :: a -> [Rule a] -> [(String, a)] -makeDerivation _ [] = [] -makeDerivation a (r:rs) = - let new = applyD r a - in [ (name r, new) | isMajorRule r ] ++ makeDerivation new rs + rec (Enter info:_) = Just (getId info) + rec (Exit info:_) = Just (getId info) + rec (_:rest) = rec rest -- Copied from TypedAbstractService: clean me up runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)] @@ -137,154 +114,55 @@ map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0 where f d = (last (terms d), if isEmpty d then p0 else last (steps d)) - stop (Just (Step r)) = isMajorRule r + stop (Just (RuleStep r)) = isMajorRule r stop _ = False - ------------------------------------------------------------------------- --- Requests - -extractString :: String -> XML -> Either String String -extractString s = liftM getData . findChild s - -xmlToRequest :: XML -> (OMOBJ -> Maybe a) -> Exercise a -> Either String (State a, StrategyLocation, Maybe a) -xmlToRequest xml fromOpenMath ex = do - unless (XML.name xml == "request") $ - fail "XML document is not a request" - loc <- optional (extractLocation "location" xml) - term <- extractExpr "term" xml - context <- optional (extractString "context" xml) - answer <- optional (extractExpr "answer" xml) - t <- maybe (fail "invalid omobj") return (fromOpenMath term) - mt <- case answer of - Nothing -> return Nothing - Just o -> return $ fromOpenMath o - return - ( State - { exercise = ex - , prefix = case context of - Just s -> Just $ getPrefix2 s (strategy ex) - Nothing -> Just $ emptyPrefix (strategy ex) - , context = case context of - Just s -> putInContext2 ex s t - Nothing -> inContext ex t - } - , fromMaybe topLocation loc - , mt - ) - ------------------------------------------------------------ -putInContext2 :: Exercise a -> String -> a -> Context a -putInContext2 ex s = fromMaybe (inContext ex) $ do - (_, s2) <- splitAtElem ';' s - env <- parseContext s2 - return (makeContext ex env) - -getPrefix2 :: String -> LabeledStrategy (Context a) -> Prefix (Context a) -getPrefix2 s ls = fromMaybe (emptyPrefix ls) $ do - (s1, _) <- splitAtElem ';' s - is <- readM s1 - makePrefix is ls - -optional :: Either String a -> Either String (Maybe a) -optional = Right . either (const Nothing) Just - -extractLocation :: String -> XML -> Either String StrategyLocation -extractLocation s xml = do - c <- findChild s xml - case parseStrategyLocation (getData c) of - Just loc -> return loc - _ -> fail "invalid location" - -extractExpr :: String -> XML -> Either String OMOBJ -extractExpr n xml = - case findChild n xml of - Just expr -> - case children expr of - [this] -> xml2omobj this - _ -> fail $ "error in " ++ show (n, xml) - _ -> fail $ "error in " ++ show (n, xml) - --- Legacy code: remove! -parseContext :: String -> Maybe Environment -parseContext s - | all isSpace s = - return emptyEnv - | otherwise = do - pairs <- mapM (splitAtElem '=') (splitsWithElem ',' s) - let env = foldr (uncurry storeEnv) emptyEnv pairs - return env ------------------------------------------------------------------------ -- Data types for replies --- There are three possible replies: ok, incorrect, or an error in the protocol (e.g., a parse error) -data Reply a = Ok (ReplyOk a) | Incorrect (ReplyIncorrect a) | Error ReplyError - -data ReplyOk a = ReplyOk - { repOk_Code :: Exercise a - , repOk_Location :: StrategyLocation - , repOk_Context :: String - , repOk_Steps :: Int - } - -data ReplyIncorrect a = ReplyIncorrect - { repInc_Code :: Exercise a - , repInc_Location :: StrategyLocation - , repInc_Expected :: a - , repInc_Derivation :: [(String, a)] - , repInc_Arguments :: Args - , repInc_Steps :: Int - , repInc_Equivalent :: Bool - } - -data ReplyError = ReplyError - { repErr_Kind :: String - , repErr_Message :: String - } +data Reply a = Ok Id (State a) + | Incorrect Bool Id (State a) Args type Args = [(String, String)] ------------------------------------------------------------------------ -- Conversion functions to XML -replyToXML :: (a -> OMOBJ) -> Reply a -> XML -replyToXML toOpenMath reply = +encodeReply :: Monad m => (State a -> m XMLBuilder) -> Reply a -> m XMLBuilder +encodeReply showState reply = case reply of - Ok r -> replyOkToXML r - Incorrect r -> replyIncorrectToXML toOpenMath r - Error r -> replyErrorToXML r + Ok loc state -> do + stateXML <- showState state + return $ + element "correct" $ do + element "location" (text $ show loc) + stateXML + Incorrect b loc state args -> do + stateXML <- showState state + return $ + element "incorrect" $ do + "equivalent" .=. show b + element "location" (text $ show loc) + stateXML + let f (x, y) = element "elem" $ do + "descr" .=. x + text y + unless (null args) $ + element "arguments" $ mapM_ f args -replyOkToXML :: ReplyOk a -> XML -replyOkToXML r = makeReply "ok" $ do - element "strategy" (text $ show $ exerciseCode $ repOk_Code r) - element "location" (text $ show $ repOk_Location r) - element "context" (text $ repOk_Context r) - element "steps" (text $ show $ repOk_Steps r) +replyType :: Type a (Reply a) +replyType = useSynonym replyTypeSynonym -replyIncorrectToXML :: (a -> OMOBJ) -> ReplyIncorrect a -> XML -replyIncorrectToXML toOpenMath r = makeReply "incorrect" $ do - element "strategy" (text $ show $ exerciseCode $ repInc_Code r) - element "location" (text $ show $ repInc_Location r) - element "expected" (builder $ omobj2xml $ toOpenMath $ repInc_Expected r) - element "steps" (text $ show $ repInc_Steps r) - element "equivalent" (text $ show $ repInc_Equivalent r) +replyTypeSynonym :: TypeSynonym a (Reply a) +replyTypeSynonym = typeSynonym "DecompositionReply" to from tp + where + to (Left (a, b)) = Ok a b + to (Right (a, b, c, d)) = Incorrect a b c d - unless (null $ repInc_Arguments r) $ - let f (x, y) = element "elem" $ do - "descr" .=. x - text y - in element "arguments" $ mapM_ f (repInc_Arguments r) - - unless (null $ repInc_Derivation r) $ - let f (x,y) = element "elem" $ do - "ruleid" .=. x - builder (omobj2xml (toOpenMath y)) - in element "derivation" $ mapM_ f (repInc_Derivation r) - -replyErrorToXML :: ReplyError -> XML -replyErrorToXML r = makeReply (repErr_Kind r) (text $ repErr_Message r) + from (Ok a b) = Left (a, b) + from (Incorrect a b c d) = Right (a, b, c, d) -makeReply :: String -> XMLBuilder -> XML -makeReply kind body = makeXML "reply" $ do - "result" .=. kind - body + tp = tuple2 Id stateTp + :|: tuple4 Bool Id stateTp argsTp + + argsTp = List (Pair String String) diff --git a/src/Service/Request.hs b/src/Service/Request.hs --- a/src/Service/Request.hs +++ b/src/Service/Request.hs @@ -11,12 +11,12 @@ ----------------------------------------------------------------------------- module Service.Request where -import Common.Exercise +import Common.Library hiding (exerciseId) import Data.Char data Request = Request { service :: String - , exerciseID :: Maybe ExerciseCode + , exerciseId :: Maybe Id , source :: Maybe String , dataformat :: DataFormat , encoding :: Maybe Encoding diff --git a/src/Service/RulesInfo.hs b/src/Service/RulesInfo.hs --- a/src/Service/RulesInfo.hs +++ b/src/Service/RulesInfo.hs @@ -10,51 +10,41 @@ -- ----------------------------------------------------------------------------- module Service.RulesInfo - ( RulesInfo, mkRulesInfo, rulesInfoXML - , rewriteRuleToFMP, collectExamples + ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap, rulesInfoType ) where +import Common.Library import Common.Utils (Some(..)) -import Common.Context -import Common.Derivation -import Common.Exercise hiding (getRule) -import Common.Rewriting -import Common.Strategy (derivationTree) -import Common.Transformation import Data.Char import Control.Monad import Text.OpenMath.Object import Text.OpenMath.FMP import Text.XML hiding (name) import Service.ExercisePackage (termToOMOBJ) +import Service.Types import qualified Data.Map as M -data RulesInfo a = I - -mkRulesInfo :: RulesInfo a -mkRulesInfo = I - rulesInfoXML :: Monad m => Exercise a -> (a -> m XMLBuilder) -> m XMLBuilder rulesInfoXML ex enc = combine $ forM (ruleset ex) $ \r -> do - let pairs = M.findWithDefault [] (name r) exampleMap - examples <- forM (take 3 pairs) $ \(a, b) -> - liftM2 (,) (enc a) (enc b) + let pairs = M.findWithDefault [] (getId r) exampleMap + xs <- forM (take 3 pairs) $ \(a, b) -> + liftM2 (,) (enc a) (enc b) return $ element "rule" $ do - "name" .=. name r + "name" .=. showId r "buggy" .=. f (isBuggyRule r) "rewriterule" .=. f (isRewriteRule r) -- More information - let descr = ruleDescription r + let descr = description r -- to do: rules should carry descriptions - txt = if null descr then (name r) else descr + txt = if null descr then showId r else descr unless (null txt) $ element "description" $ text txt forM_ (ruleGroups r) $ \s -> - element "group" $ text s + element "group" $ text (showId s) forM_ (ruleSiblings r) $ \s -> - element "sibling" $ text s + element "sibling" $ text $ showId s -- FMPs and CMPs forM_ (getRewriteRules r) $ \(Some rr, b) -> do let fmp = rewriteRuleToFMP b rr @@ -64,7 +54,7 @@ element "FMP" $ builder (omobj2xml (toObject fmp)) -- Examples - forM_ examples $ \(a, b) -> + forM_ xs $ \(a, b) -> element "example" (a >> b) where f = map toLower . show @@ -76,13 +66,18 @@ | sound = eqFMP a b | otherwise = buggyFMP a b where - a :~> b = fmap termToOMOBJ (rulePair r 0) - -collectExamples :: Exercise a -> M.Map String [(a, a)] + a :~> b = fmap termToOMOBJ (ruleSpecTerm r) + +type ExampleMap a = M.Map Id [(a, a)] + +collectExamples :: Exercise a -> ExampleMap a collectExamples ex = foldr add M.empty (examples ex) where add a m = let tree = derivationTree (strategy ex) (inContext ex a) f Nothing = m f (Just d) = foldr g m (zip3 (terms d) (steps d) (drop 1 (terms d))) - g (a, r, b) = M.insertWith (++) (name r) (liftM2 (,) (fromContext a) (fromContext b)) + g (x, r, y) = M.insertWith (++) (getId r) (liftM2 (,) (fromContext x) (fromContext y)) in f (derivation tree) + +rulesInfoType :: Type a () +rulesInfoType = useSynonym (typeSynonym "RulesInfo" id id Unit) diff --git a/src/Service/ServiceList.hs b/src/Service/ServiceList.hs --- a/src/Service/ServiceList.hs +++ b/src/Service/ServiceList.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XRankNTypes #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -10,32 +10,21 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Service.ServiceList - ( serviceList, exerciselistS - , Service(..), evalService - ) where +module Service.ServiceList (serviceList, exerciselistS) where -import Common.Exercise hiding (Exercise) -import Common.Strategy (toStrategy) -import Common.Transformation +import Common.Library hiding (apply, applicable, derivation) import Common.Utils (Some(..)) import Data.List (sortBy) -import Service.FeedbackText hiding (ExerciseText) -import Service.ProblemDecomposition +import Data.Ord +import Service.FeedbackText +import Service.ProblemDecomposition (problemDecomposition, replyType) import Service.ExercisePackage +import Service.Types import Service.RulesInfo -import Service.Types -import qualified Common.Exercise as E -import qualified Service.Diagnose as S -import qualified Service.Submit as S -import qualified Service.TypedAbstractService as S - -data Service = Service - { serviceName :: String - , serviceDescription :: String - , serviceDeprecated :: Bool - , serviceFunction :: forall a . TypedValue a - } +import Service.State +import Service.BasicServices +import qualified Service.Diagnose as Diagnose +import qualified Service.Submit as Submit ------------------------------------------------------ -- Querying a service @@ -43,22 +32,14 @@ serviceList :: [Service] serviceList = [ derivationS, allfirstsS, onefirstS, readyS - , stepsremainingS, applicableS, applyS, generateS - , submitS, diagnoseS + , stepsremainingS, applicableS, allapplicationsS + , applyS, generateS + , examplesS, submitS, diagnoseS , onefirsttextS, findbuggyrulesS , submittextS, derivationtextS , problemdecompositionS , rulelistS, rulesinfoS, strategyinfoS ] - -makeService :: String -> String -> (forall a . TypedValue a) -> Service -makeService name descr f = Service name descr False f - -deprecate :: Service -> Service -deprecate s = s { serviceDeprecated = True } - -evalService :: Monad m => Evaluator m inp out a -> Service -> inp -> m out -evalService f = eval f . serviceFunction ------------------------------------------------------ -- Basic services @@ -69,7 +50,7 @@ \current expression. The first optional argument lets you configure the \ \strategy, i.e., make some minor modifications to it. Rules used and \ \intermediate expressions are returned in a list." $ - S.derivation ::: Maybe StrategyCfg :-> State :-> Error (List (tuple2 Rule Context)) + derivation ::: maybeTp StrategyCfg :-> stateTp :-> errorTp (List (tuple2 Rule Context)) allfirstsS :: Service allfirstsS = makeService "allfirsts" @@ -77,7 +58,7 @@ \onefirst service to get only one suggestion. For each suggestion, a new \ \state, the rule used, and the location where the rule was applied are \ \returned." $ - S.allfirsts ::: State :-> Error (List (tuple3 Rule Location State)) + allfirsts ::: stateTp :-> errorTp (List (tuple3 Rule Location stateTp)) onefirstS :: Service onefirstS = makeService "onefirst" @@ -85,55 +66,70 @@ \service to get all possible steps that are allowed by the strategy. In \ \addition to a new state, the rule used and the location where to apply \ \this rule are returned." $ - S.onefirst ::: State :-> Elem (Error (tuple3 Rule Location State)) + onefirst ::: stateTp :-> elemTp (errorTp (tuple3 Rule Location stateTp)) readyS :: Service readyS = makeService "ready" "Test if the current expression is in a form accepted as a final answer. \ \For this, the strategy is not used." $ - S.ready ::: State :-> Bool + ready ::: stateTp :-> Bool stepsremainingS :: Service stepsremainingS = makeService "stepsremaining" "Computes how many steps are remaining to be done, according to the \ \strategy. For this, only the first derivation is considered, which \ \corresponds to the one returned by the derivation service." $ - S.stepsremaining ::: State :-> Error Int + stepsremaining ::: stateTp :-> errorTp Int applicableS :: Service applicableS = makeService "applicable" "Given a current expression and a location in this expression, this service \ \yields all rules that can be applied at this location, regardless of the \ \strategy." $ - S.applicable ::: Location :-> State :-> List Rule + applicable ::: Location :-> stateTp :-> List Rule +allapplicationsS :: Service +allapplicationsS = makeService "allapplications" + "Given a current expression, this service yields all rules that can be \ + \applied at a certain location, regardless wether the rule used is buggy \ + \or not. Some results are within the strategys, others are not." $ + allapplications ::: stateTp :-> List (tuple3 Rule Location stateTp) + applyS :: Service applyS = makeService "apply" "Apply a rule at a certain location to the current expression. If this rule \ \was not expected by the strategy, we deviate from it. If the rule cannot \ \be applied, this service call results in an error." $ - S.apply ::: Rule :-> Location :-> State :-> Error State + apply ::: Rule :-> Location :-> stateTp :-> errorTp stateTp generateS :: Service generateS = makeService "generate" "Given an exercise code and a difficulty level (optional), this service \ \returns an initial state with a freshly generated expression. The meaning \ \of the difficulty level (an integer) depends on the exercise at hand." $ - S.generate ::: Exercise :-> Optional 5 Int :-> IO State + generate ::: ExercisePkg :-> optionTp 5 Int :-> IO stateTp +examplesS :: Service +examplesS = makeService "examples" + "This services returns a list of example expresssions that can be solved \ + \with an exercise. These are the examples that appear at the page generated \ + \for each exercise. Also see the generate service, which returns a random \ + \start term." $ + (examples . exercise) ::: ExercisePkg :-> List Term + findbuggyrulesS :: Service findbuggyrulesS = makeService "findbuggyrules" "Search for common misconceptions (buggy rules) in an expression (compared \ \to the current state). It is assumed that the expression is indeed not \ \correct. This service has been superseded by the diagnose service." $ - S.findbuggyrules ::: State :-> Term :-> List Rule + findbuggyrules ::: stateTp :-> Term :-> List Rule submitS :: Service submitS = deprecate $ makeService "submit" "Analyze an expression submitted by a student. Possible answers are Buggy, \ \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \ \by the diagnose service." $ - S.submit ::: State :-> Term :-> Result + Submit.submit ::: stateTp :-> Term :-> Submit.submitType diagnoseS :: Service diagnoseS = makeService "diagnose" @@ -145,7 +141,7 @@ \expression was not expected by the strategy, but the applied rule was \ \detected), and Correct (it is correct, but we don't know which rule was \ \applied)." $ - S.diagnose ::: State :-> Term :-> Diagnosis + Diagnose.diagnose ::: stateTp :-> Term :-> Diagnose.diagnosisType ------------------------------------------------------ -- Services with a feedback component @@ -157,7 +153,7 @@ \leading to this service call (which can influence the returned result). \ \The boolean in the result specifies whether a suggestion was available or \ \not." $ - onefirsttext ::: ExerciseText :-> State :-> Maybe String :-> Elem (tuple3 Bool String State) + onefirsttext ::: stateTp :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp)) submittextS :: Service submittextS = makeService "submittext" @@ -167,24 +163,25 @@ \for announcing the event leading to this service call. The boolean in the \ \result specifies whether the submitted term is accepted and incorporated \ \in the new state." $ - submittext ::: ExerciseText :-> State :-> String :-> Maybe String :-> Elem (tuple3 Bool String State) + submittext ::: stateTp :-> String :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp)) derivationtextS :: Service derivationtextS = makeService "derivationtext" "Similar to the derivation service, but the rules appearing in the derivation \ \have been replaced by a short description of the rule. The optional string is \ \for announcing the event leading to this service call." $ - derivationtext ::: ExerciseText :-> State :-> Maybe String :-> Error (List (tuple2 String Context)) + derivationtext ::: stateTp :-> maybeTp String :-> errorTp (List (tuple2 String Context)) ------------------------------------------------------ -- Problem decomposition service + problemdecompositionS :: Service problemdecompositionS = makeService "problemdecomposition" "Strategy service developed for the SURF project Intelligent Feedback for a \ \binding with the MathDox system on linear algebra exercises. This is a \ \composite service, and available for backwards compatibility." $ - problemDecomposition ::: State :-> StrategyLoc :-> Maybe Term :-> DecompositionReply + problemDecomposition ::: maybeTp Id :-> stateTp :-> maybeTp (Tag "answer" Term) :-> errorTp replyType ------------------------------------------------------ -- Reflective services @@ -193,7 +190,7 @@ exerciselistS list = makeService "exerciselist" "Returns all exercises known to the system. For each exercise, its domain, \ \identifier, a short description, and its current status are returned." $ - allExercises list ::: List (tuple4 (Tag "domain" String) (Tag "identifier" String) (Tag "description" String) (Tag "status" String)) + allExercises list ::: List (tuple3 (Tag "exerciseid" String) (Tag "description" String) (Tag "status" String)) rulelistS :: Service rulelistS = makeService "rulelist" @@ -201,30 +198,30 @@ \name (or identifier), whether the rule is buggy, and whether the rule was \ \expressed as an observable rewrite rule. See rulesinfo for more details \ \about the rules." $ - allRules ::: Exercise :-> List (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) + allRules ::: ExercisePkg :-> List (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) rulesinfoS :: Service rulesinfoS = makeService "rulesinfo" "Returns a list of all rules of a particular exercise, with many details \ \including Formal Mathematical Properties (FMPs) and example applications." $ - mkRulesInfo ::: RulesInfo + () ::: rulesInfoType strategyinfoS :: Service strategyinfoS = makeService "strategyinfo" "Returns the representation of the strategy of a particular exercise." $ - (toStrategy . strategy) ::: Exercise :-> Strategy + (toStrategy . strategy . exercise) ::: ExercisePkg :-> Strategy -allExercises :: [Some ExercisePackage] -> [(String, String, String, String)] -allExercises = map make . sortBy cmp +allExercises :: [Some ExercisePackage] -> [(String, String, String)] +allExercises = map make . sortBy (comparing f) where - cmp e1 e2 = f e1 `compare` f e2 - f (Some pkg) = exerciseCode (exercise pkg) + f (Some pkg) = showId (exercise pkg) make (Some pkg) = - let ex = exercise pkg - code = exerciseCode ex - in (domain code, identifier code, description ex, show (status ex)) + (showId pkg, description pkg, show (status (exercise pkg))) -allRules :: E.Exercise a -> [(String, Bool, Bool)] -allRules = map make . ruleset +allRules :: ExercisePackage a -> [(String, Bool, Bool)] +allRules = map make . ruleset . exercise where - make r = (name r, isBuggyRule r, isRewriteRule r) + make r = (showId r, isBuggyRule r, isRewriteRule r) + +elemTp :: Type a t -> Type a t +elemTp = Tag "elem" diff --git a/src/Service/State.hs b/src/Service/State.hs new file mode 100644 --- /dev/null +++ b/src/Service/State.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- The information maintained for a learner trying to complete a +-- derivation. +-- +----------------------------------------------------------------------------- +module Service.State + ( -- * Exercise state + State, makeState, empyStateContext, emptyState + , exercisePkg, statePrefix, stateContext, stateTerm + -- * Types + , stateTp, stateTypeSynonym + ) where + +import Common.Library +import Common.Utils (readM) +import Service.Types +import Data.Maybe +import Service.ExercisePackage + +data State a = State + { exercisePkg :: ExercisePackage a + , statePrefix :: Maybe (Prefix (Context a)) + , stateContext :: Context a + } + +stateTerm :: State a -> a +stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext + +----------------------------------------------------------- + +makeState :: ExercisePackage a -> Maybe (Prefix (Context a)) -> Context a -> State a +makeState = State + +empyStateContext :: ExercisePackage a -> Context a -> State a +empyStateContext pkg = makeState pkg (Just pr) + where + ex = exercise pkg + pr = emptyPrefix (strategy ex) + +emptyState :: ExercisePackage a -> a -> State a +emptyState pkg = empyStateContext pkg . inContext (exercise pkg) + +-------------------------------------------------------------- + +stateTp :: Type a (State a) +stateTp = useSynonym stateTypeSynonym + +stateTypeSynonym :: TypeSynonym a (State a) +stateTypeSynonym = typeSynonym "State" to from tp + where + to (pkg, mp, ctx) = + let str = strategy (exercise pkg) + f = fromMaybe [] . readM + in makeState pkg (mp >>= flip makePrefix str . f) ctx + from st = + ( exercisePkg st + , fmap show (statePrefix st) + , stateContext st + ) + tp = tuple3 ExercisePkg prefixTp Context + +prefixTp :: Type a (Maybe String) +prefixTp = Tag "Prefix" (maybeTp String) diff --git a/src/Service/StrategyInfo.hs b/src/Service/StrategyInfo.hs --- a/src/Service/StrategyInfo.hs +++ b/src/Service/StrategyInfo.hs @@ -16,20 +16,12 @@ import Data.Char import Data.Maybe import Control.Monad +import Common.Library import Common.Strategy.Core (Core(..), noLabels) import Common.Strategy.Abstract import Text.XML -import Common.Transformation hiding (name) import Common.Utils (readInt) -instance InXML (LabeledStrategy a) where - toXML = toXML . toStrategy - fromXML xml = fromXML xml >>= toLabeledStrategy - -instance InXML (Strategy a) where - toXML = strategyToXML - fromXML = xmlToStrategy unknownRule - ----------------------------------------------------------------------- -- Strategy to XML @@ -38,7 +30,7 @@ infoToXML :: LabelInfo -> XMLBuilder infoToXML info = do - "name" .=. labelName info + "name" .=. showId info when (removed info) ("removed" .=. "true") when (collapsed info) ("collapsed" .=. "true") when (hidden info) ("hidden" .=. "true") @@ -49,7 +41,7 @@ Label l a -> infoToXML l >> coreBuilder infoToXML a _ -> coreBuilder infoToXML core -coreBuilder :: (l -> XMLBuilder) -> Core l a -> XMLBuilder +coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder coreBuilder f = rec where rec core = @@ -59,10 +51,11 @@ _ :|>: _ -> asList "orelse" isOrElse Many a -> element "many" (rec a) Repeat a -> element "repeat" (rec a) + Label l (Rule r) | getId l == getId r -> element "rule" (f l) Label l a -> element "label" (f l >> rec a) Rec n a -> element "rec" (("var" .=. show n) >> rec a) Not a -> element "not" (recNot a) - Rule l r -> element "rule" (maybe ("name" .=. show r) f l) + Rule r -> element "rule" ("name" .=. show r) Var n -> element "var" ("var" .=. show n) Succeed -> tag "succeed" Fail -> tag "fail" @@ -92,9 +85,9 @@ xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) -> XML -> m (Strategy a) xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g where - g info = case f (labelName info) of + g info = case f (showId info) of Just r -> return r - Nothing -> fail $ "Unknown rule: " ++ show (labelName info) + Nothing -> fail $ "Unknown rule: " ++ showId info xmlToInfo :: Monad m => XML -> m LabelInfo xmlToInfo xml = do @@ -114,14 +107,9 @@ "false" -> return False _ -> fail "not a boolean" -unknownRule :: Monad m => String -> m (Rule a) -unknownRule s = - let n = "#Unknown rule:" ++ s - in return (makeSimpleRule n (const Nothing)) - readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a) -readStrategy f g xml = do - xs <- mapM (readStrategy f g) (children xml) +readStrategy toLabel findRule xml = do + xs <- mapM (readStrategy toLabel findRule) (children xml) let s = name xml case lookup s table of Just f -> f s xs @@ -138,12 +126,12 @@ | null xs = return Fail | otherwise = return (foldr1 (:|>:) xs) buildLabel x = do - info <- f xml + info <- toLabel xml return (Label info x) buildRule = do - info <- f xml - rule <- g info - return (Rule (Just info) rule) + info <- toLabel xml + r <- findRule info + return (Label info (Rule r)) buildRec x = do s <- findAttribute "var" xml i <- maybe (fail "var: not an int") return (readInt s) @@ -153,11 +141,11 @@ i <- maybe (fail "var: not an int") return (readInt s) return (Var i) - nullary a _ [] = return a - nullary _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 0 args" + comb0 a _ [] = return a + comb0 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 0 args" - unary f _ [x] = return (f x) - unary _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 1 arg" + comb1 f _ [x] = return (f x) + comb1 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 1 arg" join2 f g a b = join (f g a b) @@ -165,13 +153,13 @@ [ ("sequence", buildSequence) , ("choice", buildChoice) , ("orelse", buildOrElse) - , ("many", unary Many) - , ("repeat", unary Repeat) - , ("label", join2 unary buildLabel) - , ("rec", join2 unary buildRec) - , ("not", unary (Not . noLabels)) - , ("rule", join2 nullary buildRule) - , ("var", join2 nullary buildVar) - , ("succeed", nullary Succeed) - , ("fail", nullary Fail) + , ("many", comb1 Many) + , ("repeat", comb1 Repeat) + , ("label", join2 comb1 buildLabel) + , ("rec", join2 comb1 buildRec) + , ("not", comb1 (Not . noLabels)) + , ("rule", join2 comb0 buildRule) + , ("var", join2 comb0 buildVar) + , ("succeed", comb0 Succeed) + , ("fail", comb0 Fail) ] diff --git a/src/Service/Submit.hs b/src/Service/Submit.hs --- a/src/Service/Submit.hs +++ b/src/Service/Submit.hs @@ -11,13 +11,16 @@ -- Diagnose a term submitted by a student. Deprecated (see diagnose service). -- ----------------------------------------------------------------------------- -module Service.Submit (submit, Result(..), getResultState) where +module Service.Submit + ( submit, Result(..), getResultState + , submitType, submitTypeSynonym + ) where -import Common.Transformation -import Common.Context +import Common.Library import qualified Service.Diagnose as Diagnose import Service.Diagnose (Diagnosis, diagnose) -import Service.TypedAbstractService +import Service.State +import Service.Types -- Note that in the typed setting there is no syntax error data Result a = Buggy [Rule (Context a)] @@ -27,8 +30,8 @@ | Unknown (State a) -- equivalent fromDiagnose :: Diagnosis a -> Result a -fromDiagnose diagnose = - case diagnose of +fromDiagnose diagnosis = + case diagnosis of Diagnose.Buggy r -> Buggy [r] Diagnose.NotEquivalent -> NotEquivalent Diagnose.Similar _ s -> Ok [] s @@ -37,7 +40,7 @@ Diagnose.Correct _ s -> Unknown s submit :: State a -> a -> Result a -submit state new = fromDiagnose (diagnose state new) +submit state = fromDiagnose . diagnose state getResultState :: Result a -> Maybe (State a) getResultState result = @@ -46,3 +49,27 @@ Detour _ st -> return st Unknown st -> return st _ -> Nothing + +submitType :: Type a (Result a) +submitType = useSynonym submitTypeSynonym + +submitTypeSynonym :: TypeSynonym a (Result a) +submitTypeSynonym = typeSynonym "Result" to from tp + where + to (Left rs) = Buggy rs + to (Right (Left ())) = NotEquivalent + to (Right (Right (Left (rs, s)))) = Ok rs s + to (Right (Right (Right (Left (rs, s))))) = Detour rs s + to (Right (Right (Right (Right s)))) = Unknown s + + from (Buggy rs) = Left rs + from (NotEquivalent) = Right (Left ()) + from (Ok rs s) = Right (Right (Left (rs, s))) + from (Detour rs s) = Right (Right (Right (Left (rs, s)))) + from (Unknown s) = Right (Right (Right (Right s))) + + tp = List Rule + :|: Unit + :|: Pair (List Rule) stateTp + :|: Pair (List Rule) stateTp + :|: stateTp diff --git a/src/Service/TypedAbstractService.hs b/src/Service/TypedAbstractService.hs deleted file mode 100644 --- a/src/Service/TypedAbstractService.hs +++ /dev/null @@ -1,152 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.TypedAbstractService - ( -- * Exercise state - State(..), emptyState, term - -- * Services - , stepsremaining, findbuggyrules, ready, allfirsts, derivation - , onefirst, applicable, apply, generate, generateWith - ) where - -import qualified Common.Apply as Apply -import Common.Context -import Common.Derivation hiding (derivation) -import Common.Exercise (Exercise(..), ruleset, randomTermWith, inContext) -import Common.Strategy hiding (not, fail) -import Common.Transformation (Rule, name, isMajorRule, isBuggyRule) -import Common.Utils (safeHead) -import Common.Navigator -import Data.Maybe -import System.Random -import Control.Monad - -data State a = State - { exercise :: Exercise a - , prefix :: Maybe (Prefix (Context a)) - , context :: Context a - } - -term :: State a -> a -term = fromMaybe (error "invalid term") . fromContext . context - ------------------------------------------------------------ - -emptyState :: Exercise a -> a -> State a -emptyState ex a = State - { exercise = ex - , prefix = Just (emptyPrefix (strategy ex)) - , context = inContext ex a - } - --- result must be in the IO monad to access a standard random number generator -generate :: Exercise a -> Int -> IO (State a) -generate ex level = do - stdgen <- newStdGen - return (generateWith stdgen ex level) - -generateWith :: StdGen -> Exercise a -> Int -> State a -generateWith rng ex level = emptyState ex (randomTermWith rng level ex) - -derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)] -derivation mcfg state = - case (prefix state, mcfg) of - (Nothing, _) -> fail "Prefix is required" - -- configuration is only allowed beforehand: hence, the prefix - -- should be empty (or else, the configuration is ignored). This - -- restriction should probably be relaxed later on. - (Just p, Just cfg) | null (prefixToSteps p) -> - let new = configure cfg $ strategy $ exercise state - in rec state - { prefix = Just (emptyPrefix new) - , exercise = (exercise state) {strategy=new} - } - _ -> rec state - where - rec :: Monad m => State a -> m [(Rule (Context a), Context a)] - rec state = do - xs <- allfirsts state - case xs of - [] -> return [] - (r, _, next):_ -> liftM ((r, context next):) (rec next) - --- Note that we have to inspect the last step of the prefix afterwards, because --- the remaining part of the derivation could consist of minor rules only. -allfirsts :: Monad m => State a -> m [(Rule (Context a), Location, State a)] -allfirsts state = - case prefix state of - Nothing -> - fail "Prefix is required" - Just p0 -> - let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (context state)) - in return (mapMaybe make (derivations tree)) - where - stop (Just (Step r)) = isMajorRule r - stop _ = False - - make d = do - prefixEnd <- safeHead (reverse (steps d)) - termEnd <- safeHead (reverse (terms d)) - case lastStepInPrefix prefixEnd of - Just (Step r) | isMajorRule r -> return - ( r - , location termEnd - , state { context = termEnd - , prefix = Just prefixEnd - } - ) - _ -> Nothing - -onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a) -onefirst state = - case allfirsts state of - Right (hd:_) -> return hd - Right [] -> fail "No step possible" - Left msg -> fail msg - -applicable :: Location -> State a -> [Rule (Context a)] -applicable loc state = - let check r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (context state)) - in filter check (ruleset (exercise state)) - --- local helper -setLocation :: Location -> Context a -> Context a -setLocation loc c0 = fromMaybe c0 $ do - navigateTo loc c0 - --- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the --- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied --- to the current term at the given location, in which case the request is invalid. -apply :: Monad m => Rule (Context a) -> Location -> State a -> m (State a) -apply r loc state = maybe applyOff applyOn (prefix state) - where - applyOn _ = -- scenario 1: on-strategy - maybe applyOff return $ safeHead - [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, name r == name r1, loc==loc1 ] - - applyOff = -- scenario 2: off-strategy - case Apply.apply r (setLocation loc (context state)) of - Just new -> return state { context=new, prefix=Nothing } - Nothing -> fail ("Cannot apply " ++ show r) - -ready :: State a -> Bool -ready state = isReady (exercise state) (term state) - -stepsremaining :: Monad m => State a -> m Int -stepsremaining = liftM length . derivation Nothing - -findbuggyrules :: State a -> a -> [Rule (Context a)] -findbuggyrules state a = - let ex = exercise state - isA = maybe False (similarity ex a) . fromContext - buggies = filter isBuggyRule (ruleset ex) - check r = any isA (Apply.applyAll r (context state)) - in filter check buggies diff --git a/src/Service/TypedExample.hs b/src/Service/TypedExample.hs --- a/src/Service/TypedExample.hs +++ b/src/Service/TypedExample.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XGADTs #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -16,40 +16,40 @@ import Service.DomainReasoner import Service.ModeXML import Service.ExercisePackage -import Service.ServiceList +import Service.Evaluator import Service.Types -import Common.Exercise +import Common.Library import Text.XML typedExample :: ExercisePackage a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool) typedExample pkg service args = do -- Construct a request in xml - xmlRequest <- + request <- case makeArgType args of Nothing -> return $ - stdReply (serviceName service) enc (exercise pkg) (return ()) - Just (reqTuple ::: reqTp) -> - case encodeType (encoder evaluator) reqTp reqTuple of - Left err -> fail err - Right xml -> return $ - stdReply (serviceName service) enc (exercise pkg) xml + stdReply (showId service) enc (exercise pkg) (return ()) + Just (reqTuple ::: reqTp) -> do + xml <- encodeType (encoder evaluator) reqTp reqTuple + return $ + stdReply (showId service) enc (exercise pkg) xml -- Construct a reply in xml - xmlReply <- return $ + reply <- case foldl dynamicApply (serviceFunction service) args of - reply ::: replyTp -> - case encodeType (encoder evaluator) replyTp reply of - Left err -> resultError err - Right xml -> resultOk xml + reply ::: replyTp -> do + xml <- encodeType (encoder evaluator) replyTp reply + return (resultOk xml) + `catchError` + (return . resultError) -- Check request/reply pair vers <- getVersion xmlTest <- do - (_, txt, _) <- processXML (show xmlRequest) + (_, txt, _) <- processXML (show request) let p = filter (not . isSpace) - out = showXML (if null vers then xmlReply else addVersion vers xmlReply) + out = showXML (if null vers then reply else addVersion vers reply) return (p txt == p out) `catchError` const (return False) - return (xmlRequest, xmlReply, xmlTest) + return (request, reply, xmlTest) where (evaluator, enc) | withOpenMath pkg = (openMathConverterTp pkg, "openmath") @@ -58,14 +58,14 @@ stdReply :: String -> String -> Exercise a -> XMLBuilder -> XML stdReply s enc ex body = makeXML "request" $ do "service" .=. s - "exerciseid" .=. show (exerciseCode ex) + "exerciseid" .=. showId ex "source" .=. "test" "encoding" .=. enc body makeArgType :: [TypedValue a] -> Maybe (TypedValue a) makeArgType [] = fail "makeArgType: empty list" -makeArgType [_ ::: Exercise] = fail "makeArgType: empty list" +makeArgType [_ ::: ExercisePkg] = fail "makeArgType: empty list" makeArgType [tv] = return tv makeArgType ((a1 ::: t1) : rest) = do a2 ::: t2 <- makeArgType rest @@ -79,13 +79,3 @@ Just eq -> f (eq a) ::: t2 Nothing -> error $ "mismatch (argument type): " ++ show t3 ++ " does not match " ++ show t1 _ -> error "mismatch (not a function)" - -equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2) -equal t1 t2 = - case (t1, t2) of - (Maybe a, Maybe b) -> fmap fmap (equal a b) - (StrategyCfg, StrategyCfg) -> Just id - (State, State) -> Just id - (Location, Location) -> Just id - (Exercise, Exercise) -> Just id - _ -> Nothing diff --git a/src/Service/Types.hs b/src/Service/Types.hs --- a/src/Service/Types.hs +++ b/src/Service/Types.hs @@ -10,26 +10,78 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Service.Types where +module Service.Types + ( -- * Services + Service, makeService, deprecate + , serviceDeprecated, serviceFunction + -- * Types + , Type(..), TypedValue(..), tuple2, tuple3, tuple4, maybeTp, optionTp + , errorTp, equal, isSynonym, useSynonym, TypeSynonym, typeSynonym + , equalM + ) where -import Common.Context (Context, fromContext) -import Common.Exercise (Exercise) -import Common.Navigator (Location) -import Common.Transformation (Rule, name) -import Common.Strategy (Strategy, StrategyLocation, StrategyConfiguration) +import Common.Library import Common.Utils (commaList) -import Control.Arrow import Control.Monad import Data.Maybe -import Service.ExercisePackage (ExercisePackage, exercise, getExerciseText) -import Service.TypedAbstractService (State) -import Service.Submit (Result) -import Service.Diagnose (Diagnosis) -import Service.FeedbackText (ExerciseText) -import Service.RulesInfo -import System.IO.Unsafe -import qualified Service.ProblemDecomposition as Decomposition +import Service.ExercisePackage +----------------------------------------------------------------------------- +-- Services + +data Service = Service + { serviceId :: Id + , serviceDeprecated :: Bool + , serviceFunction :: forall a . TypedValue a + } + +instance HasId Service where + getId = serviceId + changeId f a = a { serviceId = f (serviceId a) } + +makeService :: String -> String -> (forall a . TypedValue a) -> Service +makeService s descr f = describe descr (Service (newId s) False f) + +deprecate :: Service -> Service +deprecate s = s { serviceDeprecated = True } + +equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2) +equalM t1 t2 = maybe (fail msg) return (equal t1 t2) + where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2 + +equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2) +equal type1 type2 = + case (type1, type2) of + (Pair a b, Pair c d ) -> equalPairs a b c d + (a :|: b, c :|: d ) -> equalChoice a b c d + (List a, List b ) -> liftM map (equal a b) + (Rule, Rule ) -> Just id + (Unit, Unit ) -> Just id + (StrategyCfg, StrategyCfg) -> Just id + (Location, Location ) -> Just id + (Id, Id ) -> Just id + (Term, Term ) -> Just id + (ExercisePkg, ExercisePkg) -> Just id + (Context, Context ) -> Just id + (Bool, Bool ) -> Just id + (String, String ) -> Just id + (Int, Int ) -> Just id + (Iso _ f a, _ ) -> fmap (. f) (equal a type2) + (_, Iso f _ b ) -> fmap (f .) (equal type1 b) + (Tag s1 a, Tag s2 b ) -> guard (s1==s2) >> equal a b + _ -> Nothing + where + equalPairs a b c d = + liftM2 (\f g (x, y) -> (f x, g y)) (equal a c) (equal b d) + + equalChoice a b c d = + liftM2 (\f g -> either (Left . f) (Right . g)) (equal a c) (equal b d) + +infixr 5 :|: + +----------------------------------------------------------------------------- +-- Types + infix 2 ::: infixr 3 :-> @@ -50,6 +102,21 @@ f (a, (b, (c, d))) = (a, b, c, d) g (a, b, c, d) = (a, (b, (c, d))) +maybeTp :: Type a t1 -> Type a (Maybe t1) +maybeTp t = Iso f g (t :|: Unit) + where + f = either Just (const Nothing) + g = maybe (Right ()) Left + +optionTp :: t1 -> Type a t1 -> Type a t1 +optionTp a t = Iso (fromMaybe a) Just (maybeTp t) + +errorTp :: Type a t -> Type a (Either String t) +errorTp t = Iso f g (t :|: IO Unit) + where + f = either Right (const (Left "errorTp")) + g = either (Right . fail) Left + data Type a t where -- Type isomorphisms (for defining type synonyms) Iso :: (t1 -> t2) -> (t2 -> t1) -> Type a t1 -> Type a t2 @@ -57,29 +124,21 @@ (:->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) -- Special annotations Tag :: String -> Type a t1 -> Type a t1 - Optional :: t1 -> Type a t1 -> Type a t1 - Maybe :: Type a t1 -> Type a (Maybe t1) - Error :: Type a t -> Type a (Either String t) -- Type constructors List :: Type a t -> Type a [t] Pair :: Type a t1 -> Type a t2 -> Type a (t1, t2) - Elem :: Type a t -> Type a t -- quick fix + (:|:) :: Type a t1 -> Type a t2 -> Type a (Either t1 t2) + Unit :: Type a () IO :: Type a t -> Type a (IO t) -- Exercise-specific types - State :: Type a (State a) - Exercise :: Type a (Exercise a) + ExercisePkg :: Type a (ExercisePackage a) Strategy :: Type a (Strategy (Context a)) - ExerciseText :: Type a (ExerciseText a) Rule :: Type a (Rule (Context a)) - RulesInfo :: Type a (RulesInfo a) Term :: Type a a Context :: Type a (Context a) - Result :: Type a (Result a) - Diagnosis :: Type a (Diagnosis a) Location :: Type a Location - StrategyLoc :: Type a StrategyLocation + Id :: Type a Id StrategyCfg :: Type a StrategyConfiguration - DecompositionReply :: Type a (Decomposition.Reply a) -- Basic types Bool :: Type a Bool Int :: Type a Int @@ -89,17 +148,14 @@ show (Iso _ _ t) = show t show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 show t@(Pair _ _) = showTuple t - show (Tag _ t) = show t - show (Optional _ t) = "(" ++ show t ++ ")?" - show (Maybe t) = "(" ++ show t ++ ")?" - show (Error t) = show t + show (t1 :|: t2) = show t1 ++ " | " ++ show t2 + show (Tag s _) = s -- ++ "@(" ++ show t ++ ")" show (List t) = "[" ++ show t ++ "]" - show (Elem t) = show t show (IO t) = show t show t = fromMaybe "unknown" (groundType t) showTuple :: Type a t -> String -showTuple t = "(" ++ commaList (collect t) ++ ")" +showTuple tp = "(" ++ commaList (collect tp) ++ ")" where collect :: Type a t -> [String] collect (Pair t1 t2) = collect t1 ++ collect t2 @@ -109,98 +165,42 @@ groundType :: Type a t -> Maybe String groundType tp = case tp of - State -> Just "State" - Exercise -> Just "Exercise" + ExercisePkg -> Just "ExercisePkg" Strategy -> Just "Strategy" - ExerciseText -> Just "ExerciseText" Rule -> Just "Rule" - RulesInfo -> Just "RulesInfo" Term -> Just "Term" Context -> Just "Context" - Result -> Just "Result" - Diagnosis -> Just "Diagnosis" + Unit -> Just "()" Bool -> Just "Bool" Int -> Just "Int" String -> Just "String" Location -> Just "Location" - StrategyLoc -> Just "StrategyLocation" + Id -> Just "Id" StrategyCfg -> Just "StrategyConfiguration" _ -> Nothing - -data Evaluator m inp out a = Evaluator - { encoder :: Encoder m out a - , decoder :: Decoder m inp a - } + +----------------------------------------------------------------------------- +-- Type Synonyms -data Encoder m s a = Encoder - { encodeType :: forall t . Type a t -> t -> m s - , encodeTerm :: a -> m s - , encodeTuple :: [s] -> s +data TypeSynonym a t = TS + { synonymName :: String + , useSynonym :: Type a t + , isSynonym :: Monad m => TypedValue a -> m t } - -data Decoder m s a = Decoder - { decodeType :: forall t . Type a t -> s -> m (t, s) - , decodeTerm :: s -> m a - , decoderPackage :: ExercisePackage a + +typeSynonym :: String -> (t2 -> t) -> (t -> t2) -> Type a t2 -> TypeSynonym a t +typeSynonym name to from tp = TS + { synonymName = name + , useSynonym = Tag name (Iso to from tp) + , isSynonym = maybe (fail name) return . matchSynonym } - -decoderExercise :: Decoder m s a -> Exercise a -decoderExercise = exercise . decoderPackage - -eval :: Monad m => Evaluator m inp out a -> TypedValue a -> inp -> m out -eval f (tv ::: tp) s = - case tp of - t1 :-> t2 -> do - (a, s1) <- decodeType (decoder f) t1 s - eval f (tv a ::: t2) s1 - _ -> - encodeType (encoder f) tp tv - -decodeDefault :: MonadPlus m => Decoder m s a -> Type a t -> s -> m (t, s) -decodeDefault dec tp s = - case tp of - Iso f _ t -> liftM (first f) (decodeType dec t s) - Pair t1 t2 -> do - (a, s1) <- decodeType dec t1 s - (b, s2) <- decodeType dec t2 s1 - return ((a, b), s2) - Tag _ t1 -> - decodeType dec t1 s - Optional a t1 -> - decodeType dec t1 s `mplus` return (a, s) - Maybe t1 -> - liftM (first Just) (decodeType dec t1 s) `mplus` return (Nothing, s) - Error t -> - liftM (first Right) (decodeType dec t s) - Exercise -> do - return (exercise (decoderPackage dec), s) - ExerciseText -> do - exText <- case getExerciseText (decoderPackage dec) of - Just a -> return a - Nothing -> fail "No support for exercise texts" - return (exText, s) - _ -> - fail $ "No support for argument type: " ++ show tp + where + matchSynonym (a ::: t0) = do + (s, t) <- isTag t0 + guard (s == name) + f <- equal t tp + return (to (f a)) -encodeDefault :: Monad m => Encoder m s a -> Type a t -> t -> m s -encodeDefault enc tp tv = - case tp of - Iso _ f t -> encodeType enc t (f tv) - Pair t1 t2 -> do - let (a, b) = tv - x <- encodeType enc t1 a - y <- encodeType enc t2 b - return (encodeTuple enc [x, y]) - Tag _ t1 -> encodeType enc t1 tv - Elem t1 -> encodeType enc t1 tv - Optional _ t1 -> encodeType enc t1 tv - Maybe t1 -> case tv of - Just a -> encodeType enc t1 a - Nothing -> return (encodeTuple enc []) - Error t -> either fail (encodeType enc t) tv - IO t1 -> encodeType enc t1 (unsafePerformIO tv) - Rule -> encodeType enc String (name tv) - Term -> encodeTerm enc tv - Context -> fromContext tv >>= encodeType enc Term - Location -> encodeType enc String (show tv) - _ -> fail ("No support for result type: " ++ show tp) +isTag :: Type a t -> Maybe (String, Type a t) +isTag (Tag s t) = Just (s, t) +isTag _ = Nothing diff --git a/src/Text/HTML.hs b/src/Text/HTML.hs --- a/src/Text/HTML.hs +++ b/src/Text/HTML.hs @@ -13,14 +13,17 @@ ----------------------------------------------------------------------------- module Text.HTML ( HTML, HTMLBuilder, showHTML - , htmlPage, errorPage, link, h1, h2, h3, h4, preText, ul, table, noBorderTable - , text, image, space, tt, spaces - , bold, italic, para, ttText, hr, br, pre, center, bullet + , htmlPage, errorPage, link, linkTitle + , h1, h2, h3, h4, preText, ul, table + , text, image, space, tt, spaces, highlightXML + , font, bold, italic, para, ttText, hr, br, pre, center, bullet, divClass ) where import Text.XML hiding (text) import qualified Text.XML as XML import Control.Monad +import Data.Char +import Data.List type HTML = XML @@ -33,7 +36,8 @@ htmlPage :: String -> Maybe String -> HTMLBuilder -> HTML htmlPage title css body = makeXML "html" $ do element "head" $ do - element "title" (text title) + unless (null title) $ + element "title" (text title) case css of Nothing -> return () Just n -> element "link" $ do @@ -51,6 +55,10 @@ link url body = element "a" $ ("href" .=. url) >> body +linkTitle :: String -> String -> HTMLBuilder -> HTMLBuilder +linkTitle url title body = element "a" $ + ("href" .=. url) >> ("title" .=. title) >> body + center :: HTMLBuilder -> HTMLBuilder center = element "center" @@ -66,6 +74,8 @@ h4 :: String -> HTMLBuilder h4 = element "h4" . text +font :: String -> HTMLBuilder -> HTMLBuilder +font n = element "font" . ("class" .=. n >>) bold, italic :: HTMLBuilder -> HTMLBuilder bold = element "b" @@ -98,12 +108,15 @@ table :: [[HTMLBuilder]] -> HTMLBuilder table rows = element "table" $ do "border" .=. "1" - mapM_ (element "tr" . mapM_ (element "td")) rows - -noBorderTable :: [[HTMLBuilder]] -> HTMLBuilder -noBorderTable rows = element "table" $ do - "border" .=. "0" - mapM_ (element "tr" . mapM_ (element "td")) rows + forM_ (zip [0::Int ..] rows) $ \(i, r) -> + element "tr" $ do + "class" .=. getClass i + mapM_ (element "td") r + where + getClass i + | i == 0 = "topRow" + | even i = "evenRow" + | otherwise = "oddRow" spaces :: Int -> HTMLBuilder spaces n = replicateM_ n space @@ -117,3 +130,36 @@ text :: String -> HTMLBuilder text = XML.text + +divClass :: String -> HTMLBuilder -> HTMLBuilder +divClass n body = element "div" ("class" .=. n >> body) + +-- A simple XML highlighter +highlightXML :: Bool -> XML -> HTMLBuilder +highlightXML nice + | nice = builder . highlight . makeXML "pre" . text . showXML + | otherwise = builder . highlight . makeXML "tt" . text . compactXML + where + highlight :: HTML -> HTML + highlight html = html {content = map (either (Left . f) Right) (content html)} + + -- find < + f :: String -> String + f [] = [] + f list@(x:xs) + | "</" `isPrefixOf` list = -- close tag + let (as, bs) = span isAlphaNum (drop 5 list) + in "</" ++ as ++ "" ++ g bs + | "<" `isPrefixOf` list = -- open tag + let (as, bs) = span isAlphaNum (drop 4 list) + in "<" ++ as ++ "" ++ g bs + | otherwise = x : f xs + -- find > + g [] = [] + g list@(x:xs) + | "/>" `isPrefixOf` list = + "/>" ++ f (drop 5 list) + | ">" `isPrefixOf` list = + ">" ++ f (drop 4 list) + | x=='=' = "=" ++ g xs + | otherwise = x : g xs diff --git a/src/Text/JSON.hs b/src/Text/JSON.hs --- a/src/Text/JSON.hs +++ b/src/Text/JSON.hs @@ -17,7 +17,7 @@ , InJSON(..) -- type class" , lookupM , parseJSON, showCompact, showPretty -- parser and pretty-printers - , jsonRPC, JSON_RPC_Handler, testMe + , jsonRPC, JSON_RPC_Handler, propEncoding ) where import Text.Parsing @@ -228,7 +228,7 @@ lookupM _ _ = fail "expecting a JSON object" indent :: Int -> String -> String -indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines +indent n = unlines . map (replicate n ' ' ++) . lines -------------------------------------------------------- -- JSON-RPC over HTTP @@ -255,18 +255,18 @@ instance CoArbitrary JSON where coarbitrary json = case json of - Number a -> variant 0 . coarbitrary a - String s -> variant 1 . coarbitrary s - Boolean b -> variant 2 . coarbitrary b - Array xs -> variant 3 . coarbitrary xs - Object xs -> variant 4 . coarbitrary xs - Null -> variant 5 + Number a -> variant (0 :: Int) . coarbitrary a + String s -> variant (1 :: Int) . coarbitrary s + Boolean b -> variant (2 :: Int) . coarbitrary b + Array xs -> variant (3 :: Int) . coarbitrary xs + Object xs -> variant (4 :: Int) . coarbitrary xs + Null -> variant (5 :: Int) instance Arbitrary Number where arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary] instance CoArbitrary Number where - coarbitrary (I n) = variant 0 . coarbitrary n - coarbitrary (D d) = variant 1 . coarbitrary d + coarbitrary (I n) = variant (0 :: Int) . coarbitrary n + coarbitrary (D d) = variant (1 :: Int) . coarbitrary d arbJSON :: Int -> Gen JSON arbJSON n @@ -293,10 +293,6 @@ replicateM n $ oneof $ map return $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] -testMe :: IO () -testMe = do - putStrLn "** JSON encoding" - quickCheck prop - where - prop :: JSON -> Bool - prop a = parseJSON (show a) == Just a +propEncoding :: Property +propEncoding = property $ \a -> + parseJSON (show a) == Just a 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,4 +1,4 @@ -{-# OPTIONS -XDeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2010, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, @@ -15,6 +15,7 @@ ) where import Data.Char (isSpace) +import Data.Generics.Uniplate hiding (children) import Data.List (nub) import Data.Maybe import Data.Typeable @@ -35,22 +36,24 @@ toXML = omobj2xml fromXML = either fail return . xml2omobj +instance Uniplate OMOBJ where + uniplate omobj = + case omobj of + OMA xs -> (xs, OMA) + OMBIND a ss b -> ([a, b], \[x, y] -> OMBIND x ss y) + _ -> ([], \_ -> omobj) + getOMVs :: OMOBJ -> [String] -getOMVs = nub . rec - where - rec (OMA xs) = concatMap rec xs - rec (OMBIND q _ b) = rec q ++ rec b - rec (OMV s) = [s] - rec _ = [] +getOMVs omobj = nub [ x | OMV x <- universe omobj ] ---------------------------------------------------------- -- conversion functions: XML <-> OMOBJ xml2omobj :: XML -> Either String OMOBJ -xml2omobj xml = - case xml of +xml2omobj xmlTop = + case xmlTop of Element "OMOBJ" _ [Right e] -> rec e - _ -> fail $ "expected an OMOBJ tag" ++ show xml + _ -> fail $ "expected an OMOBJ tag" ++ show xmlTop where rec xml = case content xml of @@ -61,8 +64,8 @@ [] | name xml == "OMS" -> do let mcd = findAttribute "cd" xml - name <- findAttribute "name" xml - return (OMS (Symbol mcd name)) + n <- findAttribute "name" xml + return (OMS (Symbol mcd n)) [Left s] | name xml == "OMI" -> case scanInt (Pos 0 0) s of diff --git a/src/Text/OpenMath/Tests.hs b/src/Text/OpenMath/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Tests.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- Copyright 2010, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Tests (propEncoding) where + +import Control.Monad +import Text.OpenMath.Object +import Test.QuickCheck +import Text.OpenMath.Dictionary.Arith1 +import Text.OpenMath.Dictionary.Calculus1 +import Text.OpenMath.Dictionary.Fns1 +import Text.OpenMath.Dictionary.Linalg2 +import Text.OpenMath.Dictionary.List1 +import Text.OpenMath.Dictionary.Logic1 +import Text.OpenMath.Dictionary.Nums1 +import Text.OpenMath.Dictionary.Quant1 +import Text.OpenMath.Dictionary.Relation1 +import Text.OpenMath.Dictionary.Transc1 + +arbOMOBJ :: Gen OMOBJ +arbOMOBJ = sized rec + where + symbols = arith1List ++ calculus1List ++ fns1List ++ linalg2List ++ + list1List ++ logic1List ++ nums1List ++ quant1List ++ + relation1List ++ transc1List + + rec 0 = frequency + [ (1, liftM OMI arbitrary) + , (1, liftM OMF arbitrary) + , (1, liftM OMV arbitrary) + , (5, oneof $ map (return . OMS) symbols) + ] + rec n = frequency + [ (1, rec 0) + , (3, choose (1,4) >>= liftM OMA . (`replicateM` f)) + , (1, liftM3 OMBIND f arbitrary f) + ] + where + f = rec (n `div` 2) + +propEncoding :: Property +propEncoding = forAll arbOMOBJ $ \x -> xml2omobj (omobj2xml x) == Right x diff --git a/src/Text/Parsing.hs b/src/Text/Parsing.hs --- a/src/Text/Parsing.hs +++ b/src/Text/Parsing.hs @@ -24,7 +24,7 @@ -- * Derived token parsers , pParens, pBracks, pCurly, pCommas, pLines, pInteger -- * UU parser combinators - , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1 + , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1, pSepList , pChainl, pChainr, pChoice, pFail -- * Operator table (parser) , OperatorTable, Associativity(..), pOperators @@ -48,8 +48,6 @@ -- | A parser with tokens as symbol type type TokenParser = Parser Token -instance UU.Symbol Token - instance (UU.Symbol s, Ord s) => UU.IsParser (Parser s) s where ~(P p) <*> ~(P q) = P (p UU.<*> q) ~(P p) <* ~(P q) = P (p UU.<* q) @@ -107,19 +105,31 @@ pQConid = makeTokT isTokenQConId TokenQConId pString = makeTokS isTokenString TokenString pInt = makeTokN isTokenInt TokenInt -pReal = makeTokN isTokenReal TokenReal +pReal = makeTokR isTokenReal TokenReal pKey = makeTokA TokenKeyword pSpec = makeTokA TokenSpecial -- helpers -makeTokS f con = makeTok f "" (con minString) (con maxString) -makeTokT f con = makeTok f ("","") (con minString minString) (con maxString maxString) -makeTokN f con = makeTok f 0 (con minBound) (con maxBound) -makeTokA con a = makeTok (const Nothing) a (con a) (con a) +makeTokS :: (Token -> Maybe a) -> (String -> Pos -> Token) -> TokenParser a +makeTokS f con = makeTok (fromJust . f) (con minString) (con maxString) -makeTok f a con1 con2 = - (fromMaybe a . f) UU.<$> con1 minPos UU.<..> con2 maxPos +makeTokT :: (Token -> Maybe a) -> (String -> String -> Pos -> Token) -> TokenParser a +makeTokT f con = makeTok (fromJust . f) (con minString minString) (con maxString maxString) +makeTokN :: (Token -> Maybe Int) -> (Int -> Pos -> Token) -> TokenParser Int +makeTokN f con = makeTok (fromJust . f) (con minBound) (con maxBound) + +makeTokR :: (Token -> Maybe Double) -> (Double -> Pos -> Token) -> TokenParser Double +makeTokR f con = makeTok (fromJust . f) (con (-d)) (con d) + where d = (10 :: Double) ^ (500 :: Int) + +makeTokA :: (a -> Pos -> Token) -> a -> TokenParser a +makeTokA con a = makeTok (const a) (con a) (con a) + +makeTok :: (Token -> a) -> (Pos -> Token) -> (Pos -> Token) -> TokenParser a +makeTok f con1 con2 = + f UU.<$> con1 minPos UU.<..> con2 maxPos + minPos, maxPos :: Pos minPos = Pos minBound minBound maxPos = Pos maxBound maxBound @@ -128,14 +138,6 @@ minString = [] maxString = replicate 100 maxBound -minDouble, maxDouble :: Double -minDouble = -(10^500) -- -Infinity -maxDouble = 10^500 -- Infinity - -instance Bounded Double where - minBound = minDouble - maxBound = maxDouble - ---------------------------------------------------------- -- Derived token parsers @@ -178,10 +180,10 @@ (*>) = (UU.*>) (<*) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s a -(<*) a = (UU.<*) a +(<*) = (UU.<*) (<|>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s a -> Parser s a -(<|>) a = (UU.<|>) a +(<|>) = (UU.<|>) optional :: (Ord s, UU.Symbol s) => Parser s a -> a -> Parser s a optional = UU.opt @@ -190,6 +192,9 @@ pList = UU.pList pList1 = UU.pList1 +pSepList :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s [a] +pSepList p q = (:) <$> p <*> pList (q *> p) + pChainl, pChainr :: (Ord s, UU.Symbol s) => Parser s (a -> a -> a) -> Parser s a -> Parser s a pChainl = UU.pChainl pChainr = UU.pChainr @@ -212,8 +217,8 @@ -- | Construct a parser using an operator table pOperators :: OperatorTable a -> TokenParser a -> TokenParser a -pOperators table p = foldr op p table - where op (a, ops) q = +pOperators table p = foldr combine p table + where combine (a, ops) q = case a of -- The NoMix variant is actually hard to define efficiently. Since we should not mix operators -- that have the same priority, we have to inspect which operator we are dealing with before diff --git a/src/Text/Scanning.hs b/src/Text/Scanning.hs --- a/src/Text/Scanning.hs +++ b/src/Text/Scanning.hs @@ -29,6 +29,7 @@ import Control.Monad import Data.List import Data.Char +import qualified UU.Parsing as UU ---------------------------------------------------------- -- * Data types @@ -50,6 +51,8 @@ | TokenReal Double Pos deriving (Eq, Ord) +instance UU.Symbol Token + instance Show Pos where show (Pos l c) = "(" ++ show l ++ "," ++ show c ++ ")" @@ -189,7 +192,7 @@ make f = f s pos : rec newp xs newp = incr (length s) pos _ -> error "unexpected case in scanner" - | isNumber input = + | isNum input = case scanNumber pos input of Just (Left i, newp, xs) -> TokenInt i pos : rec newp xs Just (Right d, newp, xs) -> TokenReal d pos : rec newp xs @@ -217,16 +220,16 @@ let newp = incr 1 pos in TokenSpecial x pos : rec newp rest - isNumber :: String -> Bool - isNumber ('-':x:_) = isDigit x && unaryMinus scanner - isNumber (x:_) = isDigit x - isNumber _ = False + isNum :: String -> Bool + isNum ('-':x:_) = isDigit x && unaryMinus scanner + isNum (x:_) = isDigit x + isNum _ = False scanIdentifier :: Scanner -> String -> Maybe (Maybe String, String, String) scanIdentifier scanner (x:rest) | isAlpha x = - case break (not . isIdentifierCharacter scanner) rest of + case span (isIdentifierCharacter scanner) rest of (xs, '.':y:rest2) | qualifiedIdentifiers scanner && isAlpha y -> - let (ys, zs) = break (not . isIdentifierCharacter scanner) rest2 + let (ys, zs) = span (isIdentifierCharacter scanner) rest2 in Just (Just (x:xs), y:ys, zs) (xs, ys) -> Just (Nothing, x:xs, ys) @@ -259,7 +262,7 @@ fractionPart _ _ = Nothing powerPart :: Pos -> String -> Maybe (Pos, String) -powerPart pos (s:rest) | s == 'e' || s == 'E' = do +powerPart pos (s:rest) | s `elem` "eE" = do (_, p, ys) <- scanInt pos rest return (incr 1 p, ys) powerPart _ _ = Nothing @@ -273,7 +276,7 @@ scanNatural :: Pos -> String -> Maybe (Int, Pos, String) scanNatural pos input = do - let (xs, ys) = break (not . isDigit) input + let (xs, ys) = span isDigit input guard (not (null xs)) let nat = foldl' (\a b -> a*10+ord b-48) 0 xs return (nat, incr (length xs) pos, ys) diff --git a/src/Text/UTF8.hs b/src/Text/UTF8.hs --- a/src/Text/UTF8.hs +++ b/src/Text/UTF8.hs @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- module Text.UTF8 ( encode, encodeM, decode, decodeM - , isUTF8, allBytes, testEncoding + , isUTF8, allBytes, propEncoding ) where import Data.Char @@ -105,10 +105,8 @@ -- Test encoding -- | QuickCheck internal encoding/decoding functions -testEncoding :: IO () -testEncoding = do - putStrLn "** UTF8 encoding" - quickCheck $ forAll (sized gen) valid +propEncoding :: Property +propEncoding = forAll (sized gen) valid where gen n = replicateM n someChar someChar = liftM chr $ oneof diff --git a/src/Text/XML.hs b/src/Text/XML.hs --- a/src/Text/XML.hs +++ b/src/Text/XML.hs @@ -63,7 +63,7 @@ where rec i (Element n as xs) = let ipl = i+2 - cd n = Left ('\n' : replicate n ' ') + cd j = Left ('\n' : replicate j ' ') f = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)]) body | null xs = xs | otherwise = concatMap f xs ++ [cd i] 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 @@ -21,7 +21,8 @@ import Control.Monad.Error () import qualified Text.XML.Document as D import System.FilePath (takeDirectory, pathSeparator) -import Data.Char (chr) +import Data.Char (chr, ord) +import Data.Maybe data Element = Element { name :: Name @@ -64,9 +65,7 @@ refToContent :: D.Reference -> Content refToContent (D.CharRef i) = [Left [chr i]] refToContent (D.EntityRef s) = - case lookup s entities of - Just c -> c - Nothing -> undefined -- [] -- error + fromJust (lookup s entities) entities :: [(String, Content)] entities = @@ -92,13 +91,21 @@ where toElement :: Element -> D.Element toElement (Element n as c) = - D.Element n (map toAttribute as) (map toXML c) + D.Element n (map toAttribute as) (concatMap toXML c) toAttribute :: Attribute -> D.Attribute toAttribute (n := s) = (D.:=) n (map Left s) - toXML :: Either String Element -> D.XML - toXML = either D.CharData (D.Tagged . toElement) + toXML :: Either String Element -> [D.XML] + toXML = either fromString (return . D.Tagged . toElement) + + fromString :: String -> [D.XML] + fromString [] = [] + fromString xs@(hd:tl) + | null xs1 = D.Reference (D.CharRef (ord hd)) : fromString tl + | otherwise = D.CharData xs1 : fromString xs2 + where + (xs1, xs2) = break ((> 127) . ord) xs ----------------------------------------------------- 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 @@ -62,11 +62,11 @@ P.notFollowedBy (P.try (string xs >> return ' ')) return x -symbol :: Char -> Parser Char -symbol = P.char +symbol :: Char -> Parser () +symbol c = P.char c >> return () -string :: String -> Parser String -string = P.string +string :: String -> Parser () +string s = P.string s >> return () ranges :: [(Char, Char)] -> Parser Char ranges xs = P.choice [ a <..> b | (a, b) <- xs ] 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 @@ -13,8 +13,7 @@ -- http://www.w3.org/TR/2006/REC-xml-20060816 ----------------------------------------------------------------------------- - -module Text.XML.Parser where +module Text.XML.Parser (document, extParsedEnt, extSubset) where import Prelude hiding (seq) import Control.Monad @@ -41,7 +40,7 @@ -- [1] document ::= prolog element Misc* document :: Parser XMLDoc document = do - (mxml, dtd) <- prolog + (mxml, mdtd) <- prolog rt <- element miscs let (ver, enc, sa) = @@ -52,7 +51,7 @@ { D.versionInfo = ver , D.encoding = enc , D.standalone = sa - , D.dtd = dtd + , D.dtd = mdtd , D.externals = [] , root = rt } @@ -61,19 +60,21 @@ -- ** 2.2 Characters -- [2] Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] +{- char :: Parser Char char = ranges xs <|> oneOf "\x9\xA\xD" where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')] +-} -------------------------------------------------- -- ** 2.3 Common Syntactic Constructs -- [3] S ::= (#x20 | #x9 | #xD | #xA)+ -space :: Parser String -space = many1 (oneOf "\x20\x9\xA\xD") +space :: Parser () +space = many1 (oneOf "\x20\x9\xA\xD") >> return () -mspace :: Parser String -- for S? -mspace = many (oneOf "\x20\x9\xA\xD") +mspace :: Parser () -- for S? +mspace = many (oneOf "\x20\x9\xA\xD") >> return () -- [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender nameChar :: Parser Char @@ -86,17 +87,21 @@ cs <- many nameChar return (c:cs) +{- -- [6] Names ::= Name (#x20 Name)* names :: Parser [String] names = sepBy1 name (symbol '\x20') +-} -- [7] Nmtoken ::= (NameChar)+ nmtoken :: Parser String nmtoken = many1 nameChar +{- -- [8] Nmtokens ::= Nmtoken (#x20 Nmtoken)* nmtokens :: Parser [String] nmtokens = sepBy1 nmtoken (symbol '\x20') +-} -- [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' -- | "'" ([^%&'] | PEReference | Reference)* "'" @@ -128,7 +133,7 @@ where xs = [('a', 'z'), ('A', 'Z'), ('0', '9')] singleQuote - | withSingleQuote = symbol '\'' + | withSingleQuote = symbol '\'' >> return '\'' | otherwise = fail "pubidChar" -------------------------------------------------- @@ -153,9 +158,7 @@ pInstr :: Parser String pInstr = packed (string "") where - p = do - piTarget - option "" (space >> stopOn ["?>"]) + p = piTarget >> option "" (space >> stopOn ["?>"]) -- [17] PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) piTarget :: Parser String @@ -216,7 +219,9 @@ -- [26] VersionNum ::= '1.0' versionNum :: Parser String -versionNum = string "1.0" +versionNum = do + string "1.0" + return "1.0" -- [27] Misc ::= Comment | PI | S misc :: Parser () 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 @@ -17,7 +17,6 @@ import Text.XML.Interface import Text.XML.Document (trim) import Control.Monad.Error -import Data.List import Data.Maybe {-testje = do 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 @@ -22,6 +22,7 @@ data Tree a = Node (Tree a) a (Tree a) | Leaf +isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool isLetter = checkTree $ makeTree letterMap isExtender = checkTree $ makeTree extenderMap isDigit = checkTree $ makeTree digitMap @@ -47,6 +48,7 @@ f :: Char -> (Char, Char) f c = (c, c) +letterMap :: [(Char, Char)] letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)] @@ -55,8 +57,10 @@ | otherwise = y:merge (x:xs) ys merge xs ys = xs++ys +extraMap :: [(Char, Char)] extraMap = map f "\161\170\184\185" +controlMap :: [(Char, Char)] controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'), ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'), ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'), @@ -65,6 +69,7 @@ ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'), ('\x10FFFE', '\x10FFFF')] +baseCharMap :: [(Char, Char)] baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'), ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'), ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'), @@ -121,9 +126,11 @@ f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'), ('\x3105','\x312C'), ('\xAC00','\xD7A3') ] +ideographicMap :: [(Char, Char)] ideographicMap = [ ('\x4E00','\x9FA5'), f '\x3007' , ('\x3021','\x3029') ] - + +combiningCharMap :: [(Char, Char)] combiningCharMap = [('\x0300','\x0345'), ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'), ('\x05A3','\x05B9'), ('\x05BB','\x05BD'), f '\x05BF' , ('\x05C1','\x05C2'), @@ -151,6 +158,7 @@ ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' , ('\x302A','\x302F'), f '\x3099' , f '\x309A' ] +digitMap :: [(Char, Char)] digitMap = [ ('\x0030','\x0039'), ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'), ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'), @@ -158,6 +166,7 @@ ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'), ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')] +extenderMap :: [(Char, Char)] extenderMap = [f '\x00B7' , f '\x02D0' , f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035') , ('\x309D','\x309E'), ('\x30FC','\x30FE') ]