diff --git a/ideas.cabal b/ideas.cabal --- a/ideas.cabal +++ b/ideas.cabal @@ -1,5 +1,5 @@ name: ideas -version: 0.7 +version: 1.0 synopsis: Feedback services for intelligent tutoring systems homepage: http://ideas.cs.uu.nl/www/ description: @@ -9,7 +9,7 @@ and Activemath. category: Education -copyright: (c) 2010 +copyright: (c) 2011 license: GPL license-file: LICENSE.txt author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring @@ -18,8 +18,12 @@ extra-source-files: CREDITS.txt build-type: Simple cabal-version: >= 1.8.0.2 -tested-with: GHC == 6.10.1, GHC == 6.12.1 +tested-with: GHC == 6.10.1, GHC == 7.0.2 +source-repository head + type: svn + location: https://ideas.cs.uu.nl/svn/Feedback/trunk/ + -------------------------------------------------------------------------------- Executable ideas @@ -27,24 +31,32 @@ ghc-options: -Wall hs-source-dirs: src other-modules: + Common.Algebra.Boolean + Common.Algebra.CoBoolean + Common.Algebra.CoField + Common.Algebra.CoGroup + Common.Algebra.Field + Common.Algebra.Group + Common.Algebra.Law + Common.Algebra.SmartGroup Common.Classes Common.Context Common.Derivation + Common.DerivationTree Common.Exercise Common.Id Common.Library Common.Navigator + Common.Predicate + Common.Rewriting Common.Rewriting.AC - Common.Rewriting.Axioms Common.Rewriting.Confluence Common.Rewriting.Difference - Common.Rewriting.Group - Common.Rewriting.Operator Common.Rewriting.RewriteRule Common.Rewriting.Substitution Common.Rewriting.Term Common.Rewriting.Unification - Common.Rewriting + Common.Strategy Common.Strategy.Abstract Common.Strategy.Combinators Common.Strategy.Configuration @@ -52,23 +64,27 @@ Common.Strategy.Location Common.Strategy.Parsing Common.Strategy.Prefix - Common.Strategy - Common.StringRef - Common.TestSuite + Common.Strategy.Tests Common.Transformation - Common.Uniplate Common.Utils + Common.Utils.QuickCheck + Common.Utils.StringRef + Common.Utils.TestSuite + Common.Utils.Uniplate Common.View Documentation.DefaultPage - Documentation.DerivationUnitTests + Documentation.ExampleFile Documentation.ExercisePage Documentation.Make + Documentation.OpenMathDerivations Documentation.OverviewPages Documentation.RulePage Documentation.RulePresenter Documentation.SelfCheck Documentation.ServicePage Documentation.TestsPage + Documentation.ViewPage + Domain.LinearAlgebra Domain.LinearAlgebra.Checks Domain.LinearAlgebra.EquationsRules Domain.LinearAlgebra.Exercises @@ -80,69 +96,73 @@ Domain.LinearAlgebra.Parser Domain.LinearAlgebra.Strategies Domain.LinearAlgebra.Vector - Domain.LinearAlgebra + Domain.Logic Domain.Logic.BuggyRules Domain.Logic.Examples Domain.Logic.Exercises - Domain.Logic.FeedbackText Domain.Logic.Formula Domain.Logic.GeneralizedRules Domain.Logic.Generator Domain.Logic.Parser - Domain.Logic.Proofs Domain.Logic.Rules Domain.Logic.Strategies Domain.Logic.Views - Domain.Logic Domain.Math.Approximation - Domain.Math.Clipboard + Domain.Math.CleanUp + Domain.Math.Data.DecimalFraction Domain.Math.Data.Interval + Domain.Math.Data.MixedFraction Domain.Math.Data.OrList Domain.Math.Data.Polynomial Domain.Math.Data.PrimeFactors Domain.Math.Data.Relation Domain.Math.Data.SquareRoot + Domain.Math.Data.WithBool + Domain.Math.Derivative.Examples Domain.Math.Derivative.Exercises Domain.Math.Derivative.Rules Domain.Math.Derivative.Strategies Domain.Math.Equation.BalanceRules Domain.Math.Equation.CoverUpExercise Domain.Math.Equation.CoverUpRules + Domain.Math.Equation.Examples Domain.Math.Equation.Views - Domain.Math.Examples.DWO1 - Domain.Math.Examples.DWO2 - Domain.Math.Examples.DWO3 - Domain.Math.Examples.DWO4 - Domain.Math.Examples.DWO5 + Domain.Math.ExerciseList + Domain.Math.Expr + Domain.Math.Expr.Clipboard Domain.Math.Expr.Data Domain.Math.Expr.Parser Domain.Math.Expr.Symbols Domain.Math.Expr.Views - Domain.Math.Expr Domain.Math.Numeric.Exercises Domain.Math.Numeric.Generators - Domain.Math.Numeric.Laws Domain.Math.Numeric.Rules Domain.Math.Numeric.Strategies Domain.Math.Numeric.Tests Domain.Math.Numeric.Views + Domain.Math.Polynomial.Balance + Domain.Math.Polynomial.BalanceUtils + Domain.Math.Polynomial.BuggyBalance Domain.Math.Polynomial.BuggyRules - Domain.Math.Polynomial.CleanUp Domain.Math.Polynomial.Equivalence + Domain.Math.Polynomial.Examples Domain.Math.Polynomial.Exercises Domain.Math.Polynomial.Generators Domain.Math.Polynomial.IneqExercises Domain.Math.Polynomial.LeastCommonMultiple + Domain.Math.Polynomial.RationalExamples Domain.Math.Polynomial.RationalExercises Domain.Math.Polynomial.RationalRules Domain.Math.Polynomial.Rules Domain.Math.Polynomial.Strategies Domain.Math.Polynomial.Tests Domain.Math.Polynomial.Views + Domain.Math.Power.Equation.Examples Domain.Math.Power.Equation.Exercises Domain.Math.Power.Equation.NormViews Domain.Math.Power.Equation.Rules Domain.Math.Power.Equation.Strategies + Domain.Math.Power.Examples Domain.Math.Power.Exercises Domain.Math.Power.NormViews Domain.Math.Power.OldViews @@ -150,29 +170,34 @@ Domain.Math.Power.Strategies Domain.Math.Power.Utils Domain.Math.Power.Views + Domain.Math.Safe Domain.Math.Simplification Domain.Math.SquareRoot.Tests Domain.Math.SquareRoot.Views + Domain.RelationAlgebra Domain.RelationAlgebra.Exercises Domain.RelationAlgebra.Formula Domain.RelationAlgebra.Generator Domain.RelationAlgebra.Parser Domain.RelationAlgebra.Rules Domain.RelationAlgebra.Strategies - Domain.RelationAlgebra + Main Main.IDEAS Main.LoggingDatabase Main.Options Main.Revision - Main Service.BasicServices Service.Diagnose Service.DomainReasoner Service.Evaluator - Service.ExercisePackage + Service.FeedbackScript.Analysis + Service.FeedbackScript.Parser + Service.FeedbackScript.Run + Service.FeedbackScript.Syntax Service.FeedbackText Service.ModeJSON Service.ModeXML + Service.OpenMathSupport Service.ProblemDecomposition Service.Request Service.RulesInfo @@ -184,7 +209,6 @@ Service.Types Text.HTML Text.JSON - Text.OpenMath.ContentDictionary Text.OpenMath.Dictionary.Arith1 Text.OpenMath.Dictionary.Calculus1 Text.OpenMath.Dictionary.Fns1 @@ -201,27 +225,22 @@ Text.OpenMath.Symbol Text.OpenMath.Tests Text.Parsing - Text.Scanning Text.UTF8 + Text.XML Text.XML.Document Text.XML.Interface - Text.XML.ParseLib Text.XML.Parser - Text.XML.TestSuite Text.XML.Unicode - Text.XML build-depends: base >= 4.2 && < 5, directory, time, mtl, cgi, containers, - QuickCheck >= 2.1.0.3, + QuickCheck >= 2.4.1, random, - uulib, filepath, parsec, - old-time, uniplate -------------------------------------------------------------------------------- diff --git a/src/Common/Algebra/Boolean.hs b/src/Common/Algebra/Boolean.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/Boolean.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.Boolean + ( -- * Boolean algebra + BoolValue(..), Boolean(..) + , ands, ors, implies, equivalent + , andOverOrLaws, orOverAndLaws + , complementAndLaws, complementOrLaws + , absorptionAndLaws, absorptionOrLaws + , deMorganAnd, deMorganOr + , doubleComplement, complementTrue, complementFalse + , booleanLaws + -- * Dual monoid + , DualMonoid(..) + -- * And monoid + , And(..), fromAndLaw + -- * Or monoid + , Or(..), fromOrLaw + -- * Properties + , propsBoolean + ) where + +import Common.Algebra.Group +import Common.Algebra.Law +import Control.Applicative +import Test.QuickCheck hiding ((><)) + +-------------------------------------------------------- +-- Boolean algebra + +-- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse +class BoolValue a where + true :: a + false :: a + fromBool :: Bool -> a + isTrue :: a -> Bool + isFalse :: a -> Bool + -- default definitions + true = fromBool True + false = fromBool False + fromBool b = if b then true else false + +class BoolValue a => Boolean a where + (<&&>) :: a -> a -> a + (<||>) :: a -> a -> a + complement :: a -> a + +instance BoolValue Bool where + fromBool = id + isTrue = id + isFalse = not + +instance Boolean Bool where + (<&&>) = (&&) + (<||>) = (||) + complement = not + +ands :: Boolean a => [a] -> a -- or use mconcat with And monoid +ands xs | null xs = true + | otherwise = foldr1 (<&&>) xs + +ors :: Boolean a => [a] -> a +ors xs | null xs = false + | otherwise = foldr1 (<||>) xs + +implies :: Boolean a => a -> a -> a +implies a b = complement a <||> b + +equivalent :: Boolean a => a -> a -> a +equivalent a b = (a <&&> b) <||> (complement a <&&> complement b) + +andOverOrLaws, orOverAndLaws :: Boolean a => [Law a] +andOverOrLaws = map fromAndLaw dualDistributive +orOverAndLaws = map fromOrLaw dualDistributive + +complementAndLaws, complementOrLaws :: Boolean a => [Law a] +complementAndLaws = map fromAndLaw dualComplement +complementOrLaws = map fromOrLaw dualComplement + +absorptionAndLaws, absorptionOrLaws :: Boolean a => [Law a] +absorptionAndLaws = map fromAndLaw dualAbsorption +absorptionOrLaws = map fromOrLaw dualAbsorption + +deMorganAnd, deMorganOr :: Boolean a => Law a +deMorganAnd = fromAndLaw deMorgan +deMorganOr = fromOrLaw deMorgan + +doubleComplement :: Boolean a => Law a +doubleComplement = law "double-complement" $ \a -> + complement (complement a) :==: a + +complementTrue, complementFalse :: Boolean a => Law a +complementTrue = fromAndLaw dualTrueFalse +complementFalse = fromOrLaw dualTrueFalse + +booleanLaws :: Boolean a => [Law a] +booleanLaws = + map fromAndLaw (idempotent : zeroLaws ++ commutativeMonoidLaws) ++ + map fromOrLaw (idempotent : zeroLaws ++ commutativeMonoidLaws) ++ + andOverOrLaws ++ orOverAndLaws ++ complementAndLaws ++ complementOrLaws ++ + absorptionAndLaws ++ absorptionOrLaws ++ + [deMorganAnd, deMorganOr, doubleComplement, complementTrue, complementFalse] + +-------------------------------------------------------- +-- Dual monoid for a monoid (and for or, and vice versa) + +class MonoidZero a => DualMonoid a where + (><) :: a -> a -> a + dualCompl :: a -> a + +dualDistributive :: DualMonoid a => [Law a] +dualDistributive = + [leftDistributiveFor (<>) (><), rightDistributiveFor (<>) (><)] + +dualAbsorption :: DualMonoid a => [Law a] +dualAbsorption = + [ law "absorption" $ \a b -> a `f` (a `g` b) :==: a + | f <- [(<>), flip (<>)] + , g <- [(><), flip (><)] + ] + +dualComplement :: DualMonoid a => [Law a] +dualComplement = + [ law "complement" $ \a -> dualCompl a <> a :==: mzero + , law "complement" $ \a -> a <> dualCompl a :==: mzero + ] + +dualTrueFalse :: DualMonoid a => Law a +dualTrueFalse = law "true-false" $ dualCompl mempty :==: mzero + +deMorgan :: DualMonoid a => Law a +deMorgan = law "demorgan" $ \a b -> + dualCompl (a <> b) :==: dualCompl a >< dualCompl b + +-------------------------------------------------------- +-- And monoid + +newtype And a = And {fromAnd :: a} + deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) + +instance Functor And where -- could be derived + fmap f = And . f . fromAnd + +instance Applicative And where + pure = And + And f <*> And a = And (f a) + +instance Boolean a => Monoid (And a) where + mempty = pure true + mappend = liftA2 (<&&>) + +instance Boolean a => MonoidZero (And a) where + mzero = pure false + +instance Boolean a => DualMonoid (And a) where + (><) = liftA2 (<||>) + dualCompl = liftA complement + +fromAndLaw :: Law (And a) -> Law a +fromAndLaw = mapLaw And fromAnd + +-------------------------------------------------------- +-- Or monoid + +newtype Or a = Or {fromOr :: a} + deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) + +instance Functor Or where -- could be derived + fmap f = Or . f . fromOr + +instance Applicative Or where + pure = Or + Or f <*> Or a = Or (f a) + +instance Boolean a => Monoid (Or a) where + mempty = pure false + mappend = liftA2 (<||>) + +instance Boolean a => MonoidZero (Or a) where + mzero = pure true + +instance Boolean a => DualMonoid (Or a) where + (><) = liftA2 (<&&>) + dualCompl = liftA complement + +fromOrLaw :: Law (Or a) -> Law a +fromOrLaw = mapLaw Or fromOr + +-------------------------------------------------------- +-- Tests for Bool instance + +propsBoolean :: [Property] +propsBoolean = map property (booleanLaws :: [Law Bool]) diff --git a/src/Common/Algebra/CoBoolean.hs b/src/Common/Algebra/CoBoolean.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/CoBoolean.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.CoBoolean + ( CoBoolean(..) + , conjunctions, disjunctions + , (.||.), (.&&.) + ) where + +import Common.Algebra.Boolean +import Common.Algebra.CoGroup +import Common.Algebra.Group +import Common.Algebra.SmartGroup +import Control.Arrow +import Data.Maybe + +class BoolValue a => CoBoolean a where + isAnd :: a -> Maybe (a, a) + isOr :: a -> Maybe (a, a) + isComplement :: a -> Maybe a + +instance CoBoolean a => CoMonoid (And a) where + isEmpty = isTrue . fromAnd + isAppend = fmap (And *** And) . isAnd . fromAnd + +instance CoBoolean a => CoMonoidZero (And a) where + isMonoidZero = isFalse . fromAnd + +instance CoBoolean a => CoMonoid (Or a) where + isEmpty = isFalse . fromOr + isAppend = fmap (Or *** Or) . isOr . fromOr + +instance CoBoolean a => CoMonoidZero (Or a) where + isMonoidZero = isTrue . fromOr + +conjunctions :: CoBoolean a => a -> [a] +conjunctions = map fromAnd . associativeList . And + +disjunctions :: CoBoolean a => a -> [a] +disjunctions = map fromOr . associativeList . Or + +instance BoolValue a => BoolValue (Smart a) where + fromBool = Smart . fromBool + isTrue = isTrue . fromSmart + isFalse = isFalse . fromSmart + +instance (Boolean a, CoBoolean a) => Boolean (Smart a) where + a <&&> b = fmap fromAnd $ fromSmartZero $ + SmartZero (fmap And a) <> SmartZero (fmap And b) + a <||> b = fmap fromOr $ fromSmartZero $ + SmartZero (fmap Or a) <> SmartZero (fmap Or b) + complement (Smart a) + | isTrue a = false + | isFalse a = true + | otherwise = Smart $ fromMaybe (complement a) (isComplement a) + +infixr 4 .||. +infixr 5 .&&. + +(.&&.), (.||.) :: (Boolean a, CoBoolean a) => a -> a -> a +a .&&. b = fromSmart $ Smart a <&&> Smart b +a .||. b = fromSmart $ Smart a <||> Smart b diff --git a/src/Common/Algebra/CoField.hs b/src/Common/Algebra/CoField.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/CoField.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.CoField + ( CoSemiRing(..), CoRing(..), CoField(..) + , SmartField(..) + , (.+.), (.-.), neg, (.*.), (./.) + ) where + +import Common.Algebra.CoGroup +import Common.Algebra.Field +import Common.Algebra.Group +import Common.Algebra.SmartGroup +import Control.Arrow ((***)) +import Control.Monad +import qualified Control.Applicative as A + +class CoSemiRing a where + -- additive + isPlus :: a -> Maybe (a, a) + isZero :: a -> Bool + -- multiplicative + isTimes :: a -> Maybe (a, a) + isOne :: a -> Bool + +-- Minimal complete definition: plusInverse or <-> +class CoSemiRing a => CoRing a where + isNegate :: a -> Maybe a + isMinus :: a -> Maybe (a, a) + -- default definition + isMinus _ = Nothing + +class CoRing a => CoField a where + isRecip :: a -> Maybe a + isDivision :: a -> Maybe (a, a) + -- default definition + isDivision _ = Nothing + +instance CoSemiRing a => CoMonoid (Additive a) where + isEmpty = isZero . fromAdditive + isAppend = fmap (Additive *** Additive) . isPlus . fromAdditive + +instance CoRing a => CoGroup (Additive a) where + isInverse = fmap Additive . isNegate . fromAdditive + isAppendInv = fmap (Additive *** Additive) . isMinus . fromAdditive + +instance CoSemiRing a => CoMonoid (Multiplicative a) where + isEmpty = isOne . fromMultiplicative + isAppend = fmap (Multiplicative *** Multiplicative) . isTimes . fromMultiplicative + +instance CoField a => CoGroup (Multiplicative a) where + isInverse = fmap Multiplicative . isRecip . fromMultiplicative + isAppendInv = fmap (Multiplicative *** Multiplicative) . isDivision . fromMultiplicative + +instance CoSemiRing a => CoMonoidZero (Multiplicative a) where + isMonoidZero = isZero . fromMultiplicative + +------------------------------------------------------------------ + +newtype SmartField a = SmartField {fromSmartField :: a} + deriving (CoSemiRing, CoRing, CoField) + +instance Functor SmartField where -- could be derived + fmap f = SmartField . f . fromSmartField + +instance A.Applicative SmartField where + pure = SmartField + SmartField f <*> SmartField a = SmartField (f a) + +instance (CoField a, Field a) => SemiRing (SmartField a) where + zero = SmartField zero + one = SmartField one + SmartField a <+> SmartField b = SmartField $ fromAdditive $ fromSmartGroup $ + SmartGroup (Additive a) <> SmartGroup (Additive b) + a <*> b + | Just x <- isNegate a = plusInverse (x <*> b) + | Just x <- isNegate b = plusInverse (a <*> x) + | isZero a || isZero b = zero + | isOne a = b + | isOne b = a + | Just (x, y) <- isTimes b = (a <*> x) <*> y + | Just (x, y) <- isDivision b = (a <*> x) y + | otherwise = A.liftA2 (<*>) a b + +instance (CoField a, Field a) => Ring (SmartField a) where + plusInverse = SmartField . fromAdditive . fromSmartGroup . inverse + . SmartGroup . Additive . fromSmartField + SmartField a <-> SmartField b = SmartField $ fromAdditive $ fromSmartGroup $ + SmartGroup (Additive a) <>- SmartGroup (Additive b) + +instance (CoField a, Field a) => Field (SmartField a) where + timesInverse a + | Just x <- isNegate a = plusInverse (timesInverse x) + | Just (x, y) <- isDivision a, isOne y = x + | otherwise = A.liftA timesInverse a + a b + | Just x <- isNegate a = plusInverse (x b) + | Just x <- isNegate b = plusInverse (a x) + | isOne b = a + | Just (x, y) <- isDivision a = x (y <*> b) + | otherwise = A.liftA2 () a b + +------------------------------------------------------------------ + +infixl 7 .*., ./. +infixl 6 .-., .+. + +(.+.) :: (CoField a, Field a) => a -> a -> a +a .+. b = fromSmartField $ SmartField a <+> SmartField b + +(.-.) :: (CoField a, Field a) => a -> a -> a +a .-. b = fromSmartField $ SmartField a <-> SmartField b + +neg :: (CoField a, Field a) => a -> a +neg = fromSmartField . plusInverse . SmartField + +(.*.) :: (CoField a, Field a) => a -> a -> a +a .*. b = fromSmartField $ SmartField a <*> SmartField b + +(./.) :: (CoField a, Field a) => a -> a -> a +a ./. b = fromSmartField $ SmartField a SmartField b + +-- myrecip :: (CoField a, Field a) => a -> a +-- myrecip = fromSmartField . timesInverse . SmartField diff --git a/src/Common/Algebra/CoGroup.hs b/src/Common/Algebra/CoGroup.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/CoGroup.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.CoGroup + ( CoMonoid(..), CoGroup(..), CoMonoidZero(..) + , associativeList + ) where + +import Common.Algebra.Group +import Common.Classes +import Control.Applicative +import Control.Arrow +import Data.Maybe +import qualified Data.Set as S +--import qualified Data.Map as M +--import qualified Data.Sequence as Q + +class CoMonoid a where + isEmpty :: a -> Bool + isAppend :: a -> Maybe (a, a) + +class CoMonoid a => CoGroup a where + isInverse :: a -> Maybe a + isAppendInv :: a -> Maybe (a, a) + -- default definition + isAppendInv = const Nothing + +class CoMonoid a => CoMonoidZero a where + isMonoidZero :: a -> Bool + +fromSemiGroup :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b +fromSemiGroup f = rec + where + rec a = maybe (f a) make (isAppend a) + make (x, y) = rec x <> rec y +{- +fromMonoid :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b +fromMonoid f = fromSemiGroup $ \a -> + if isEmpty a then mempty else f a + +fromGroup :: (CoGroup a, Group b) => (a -> b) -> a -> b +fromGroup f = rec + where + rec = fromMonoid $ \a -> + case isInverse a of + Just x -> inverse (rec x) + Nothing -> + case isAppendInverse a of + Just (x, y) -> rec x <>- rec y + Nothing -> f a + +fromMonoidZero :: (CoMonoidZero a, MonoidZero b) => (a -> b) -> a -> b +fromMonoidZero f = fromMonoid $ \a -> + if isZero a then zero else f a + +---------------------- +-} +associativeList :: CoMonoid a => a -> [a] +associativeList = fromSemiGroup singleton +{- +monoidList :: CoMonoid a => a -> [a] +monoidList = fromMonoid singleton + +-- For commutative (and associative) monoids +monoidMultiSet :: (CoMonoid a, Ord a) => a -> MultiSet a +monoidMultiSet = fromMonoid singleton + +-- For associative, commutative, idempotent (ACI) monoids +monoidSet :: (CoMonoid a, Ord a) => a -> S.Set a +monoidSet = fromMonoid singleton + +groupSequence :: (CoGroup a, Eq a) => a -> GroupSequence a +groupSequence = fromGroup singleton + +abelianMultiSet :: (CoGroup a, Ord a) => a -> MultiSet a +abelianMultiSet = fromGroup singleton + +monoidZeroList :: CoMonoidZero a => a -> WithZero [a] +monoidZeroList = fromMonoidZero (pure . singleton) + +---------------------- + +newtype MultiSet a = MS (M.Map a Int) + +instance Collection MultiSet where + singleton a = MS (M.singleton a 1) + +instance Ord a => Monoid (MultiSet a) where + mempty = MS mempty + mappend (MS m1) (MS m2) = MS (M.unionWith (+) m1 m2) + +instance Ord a => Group (MultiSet a) where + inverse (MS m) = MS (fmap negate m) + +---------------------- + +newtype GroupSequence a = GS (Q.Seq (a, Bool)) + +instance Collection GroupSequence where + singleton a = GS (Q.singleton (a, False)) + +instance Eq a => Monoid (GroupSequence a) where + mempty = GS mempty + mappend (GS xs) (GS ys) = + case (Q.viewr xs, Q.viewl ys) of + (as Q.:> (a, ai), (b, bi) Q.:< bs) | a == b && ai /= bi -> + mappend (GS as) (GS bs) + _ -> GS (xs <> ys) + +instance Eq a => Group (GroupSequence a) where + inverse (GS xs) = GS (fmap (second not) xs) -- actually: reverse order!! +-} +---------------------- + +instance CoMonoid [a] where + isEmpty = null + isAppend (x:xs@(_:_)) = Just ([x], xs) + isAppend _ = Nothing + +instance CoMonoid (S.Set a) where + isEmpty = S.null + isAppend s + | S.size s > 1 = Just (first S.singleton (S.deleteFindMin s)) + | otherwise = Nothing + +{- +instance CoMonoid (Q.Seq a) where + isEmpty = Q.null + isAppend xs + | n > 1 = Just (Q.splitAt (n `div` 2) xs) + | otherwise = Nothing + where + n = Q.length xs +-} +instance CoMonoid a => CoMonoid (WithZero a) where + isEmpty = maybe False isEmpty . fromWithZero + isAppend a = fromWithZero a >>= fmap (pure *** pure) . isAppend + +instance CoMonoid a => CoMonoidZero (WithZero a) where + isMonoidZero = isNothing . fromWithZero diff --git a/src/Common/Algebra/Field.hs b/src/Common/Algebra/Field.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/Field.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.Field + ( -- * Semi-ring + SemiRing(..), leftDistributive, rightDistributive + , distributiveLaws, semiRingLaws + -- * Ring + , Ring(..), leftNegateTimes, rightNegateTimes + , negateTimesLaws, ringLaws, commutativeRingLaws + , distributiveSubtractionLaws + -- * Field + , Field(..), exchangeInverses, fieldLaws + -- * Additive monoid + , Additive(..), fromAdditiveLaw + -- * Multiplicative monoid + , Multiplicative(..), fromMultiplicativeLaw + -- * Datatype for safe numeric operators + , SafeNum, safeNum + , propsField + ) where + +import Common.Algebra.Group +import Common.Algebra.Law +import Control.Monad +import Test.QuickCheck +import qualified Control.Applicative as A + +-------------------------------------------------------- +-- Semi-ring + +infixl 6 <+> +infixl 7 <*> + +class SemiRing a where + -- additive + (<+>) :: a -> a -> a + zero :: a + -- multiplicative + (<*>) :: a -> a -> a + one :: a + +leftDistributive :: SemiRing a => Law a +leftDistributive = leftDistributiveFor (<*>) (<+>) + +rightDistributive :: SemiRing a => Law a +rightDistributive = rightDistributiveFor (<*>) (<+>) + +distributiveLaws :: SemiRing a => [Law a] +distributiveLaws = [leftDistributive, rightDistributive] + +semiRingLaws :: SemiRing a => [Law a] +semiRingLaws = + map fromAdditiveLaw commutativeMonoidLaws ++ + map fromMultiplicativeLaw monoidZeroLaws ++ + distributiveLaws + +-------------------------------------------------------- +-- Ring + +infixl 6 <-> + +-- Minimal complete definition: plusInverse or <-> +class SemiRing a => Ring a where + plusInverse :: a -> a + (<->) :: a -> a -> a + -- default definitions + plusInverse = (zero <->) + a <-> b = a <+> plusInverse b + +leftNegateTimes :: Ring a => Law a +leftNegateTimes = law "left-negate-times" $ \a b -> + plusInverse a <*> b :==: plusInverse (a <*> b) + +rightNegateTimes :: Ring a => Law a +rightNegateTimes = law "right-negate-times" $ \a b -> + a <*> plusInverse b :==: plusInverse (a <*> b) + +negateTimesLaws :: Ring a => [Law a] +negateTimesLaws = [leftNegateTimes, rightNegateTimes] + +ringLaws :: Ring a => [Law a] +ringLaws = + map fromAdditiveLaw abelianGroupLaws ++ + map fromMultiplicativeLaw monoidZeroLaws ++ + distributiveLaws ++ negateTimesLaws + +commutativeRingLaws :: Ring a => [Law a] +commutativeRingLaws = + fromMultiplicativeLaw commutative : ringLaws + +distributiveSubtractionLaws :: Ring a => [Law a] +distributiveSubtractionLaws = + [leftDistributiveFor (<*>) (<->), rightDistributiveFor (<*>) (<->)] + +-------------------------------------------------------- +-- Field + +infixl 7 + +-- Minimal complete definition: mulInverse or +class Ring a => Field a where + timesInverse :: a -> a + () :: a -> a -> a + -- default definitions + timesInverse = (one ) + a b = a <*> timesInverse b + +exchangeInverses :: Field a => Law a +exchangeInverses = law "exchange-inverses" $ \a -> + timesInverse (plusInverse a) :==: plusInverse (timesInverse a) + +fieldLaws :: Field a => [Law a] +fieldLaws = + map fromAdditiveLaw abelianGroupLaws ++ + map fromMultiplicativeLaw abelianGroupLaws ++ + distributiveLaws ++ negateTimesLaws ++ [exchangeInverses] + +-------------------------------------------------------- +-- Additive monoid + +newtype Additive a = Additive {fromAdditive :: a} + deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) + +instance Functor Additive where -- could be derived + fmap f = Additive . f . fromAdditive + +instance A.Applicative Additive where + pure = Additive + Additive f <*> Additive a = Additive (f a) + +instance SemiRing a => Monoid (Additive a) where + mempty = A.pure zero + mappend = A.liftA2 (<+>) + +instance Ring a => Group (Additive a) where + inverse = A.liftA plusInverse + appendInv = A.liftA2 (<->) + +fromAdditiveLaw :: Law (Additive a) -> Law a +fromAdditiveLaw = mapLaw Additive fromAdditive + +-------------------------------------------------------- +-- Multiplicative monoid + +newtype Multiplicative a = Multiplicative {fromMultiplicative :: a} + deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) + +instance Functor Multiplicative where -- could be derived + fmap f = Multiplicative . f . fromMultiplicative + +instance A.Applicative Multiplicative where + pure = Multiplicative + Multiplicative f <*> Multiplicative a = Multiplicative (f a) + +instance SemiRing a => Monoid (Multiplicative a) where + mempty = A.pure one + mappend = A.liftA2 (<*>) + +instance Field a => Group (Multiplicative a) where + inverse = A.liftA timesInverse + appendInv = A.liftA2 () + +instance SemiRing a => MonoidZero (Multiplicative a) where + mzero = Multiplicative zero + +fromMultiplicativeLaw :: Law (Multiplicative a) -> Law a +fromMultiplicativeLaw = mapLaw Multiplicative fromMultiplicative + +-------------------------------------------------------- +-- Datatype for safe numeric operators + +data SafeNum a = Ok a | Exception String + +safeNum :: SafeNum a -> Either String a +safeNum (Ok a) = Right a +safeNum (Exception s) = Left s + +instance Arbitrary a => Arbitrary (SafeNum a) where + arbitrary = liftM return arbitrary + +instance Eq a => Eq (SafeNum a) where + Ok a == Ok b = a == b + _ == _ = True + +instance Ord a => Ord (SafeNum a) where + Ok a `compare` Ok b = a `compare` b + _ `compare` _ = EQ + +instance Show a => Show (SafeNum a) where + show = either ("Exception: " ++) show . safeNum + +instance Functor SafeNum where + fmap f = either Exception (return . f) . safeNum + +instance Monad SafeNum where + return = Ok + fail = Exception + m >>= f = either Exception f (safeNum m) + +instance Num a => Num (SafeNum a) where + (+) = liftM2 (+) + (*) = liftM2 (*) + (-) = liftM2 (-) + negate = liftM negate + abs = liftM abs + signum = liftM signum + fromInteger = return . fromInteger + +instance Fractional a => Fractional (SafeNum a) where + a / b = liftM2 (/) a (safeDivisor b) + recip = liftM recip . safeDivisor + fromRational = return . fromRational + +instance Num a => SemiRing (SafeNum a) where + (<+>) = (+) + (<*>) = (*) + zero = 0 + one = 1 + +instance Num a => Ring (SafeNum a) where + plusInverse = negate + (<->) = (-) + +instance Fractional a => Field (SafeNum a) where + timesInverse = recip + () = (/) + +safeDivisor :: Num a => SafeNum a -> SafeNum a +safeDivisor m = m >>= \a -> + if a == 0 then fail "division by zero" else return a + +propsField :: [Property] +propsField = map property (fieldLaws :: [Law (SafeNum Rational)]) diff --git a/src/Common/Algebra/Group.hs b/src/Common/Algebra/Group.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/Group.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.Group + ( -- * Monoids + module Data.Monoid, (<>), associative, leftIdentity + , rightIdentity, identityLaws, monoidLaws, commutativeMonoidLaws + , idempotent + -- * Groups + , Group(..), (<>-), leftInverse, rightInverse, doubleInverse + , inverseIdentity, inverseDistrFlipped, inverseLaws, groupLaws + , appendInverseLaws + -- * Abelian groups + , commutative, inverseDistr, abelianGroupLaws + -- * Monoids with a zero element + , MonoidZero(..), leftZero, rightZero, zeroLaws, monoidZeroLaws + , WithZero, fromWithZero + -- * Generalized laws + , associativeFor, commutativeFor, idempotentFor + , leftDistributiveFor, rightDistributiveFor + ) where + +import Common.Algebra.Law +import Control.Applicative (Applicative) +import Control.Monad (liftM2) +import Data.Foldable (Foldable) +import Data.Monoid +import Data.Traversable (Traversable) + +-------------------------------------------------------- +-- Monoids + +infixl 6 <> + +(<>) :: Monoid a => a -> a -> a +(<>) = mappend + +associative :: Monoid a => Law a +associative = associativeFor (<>) + +leftIdentity :: Monoid a => Law a +leftIdentity = law "left-identity" $ \a -> mempty <> a :==: a + +rightIdentity :: Monoid a => Law a +rightIdentity = law "right-identity" $ \a -> a <> mempty :==: a + +identityLaws :: Monoid a => [Law a] +identityLaws = [leftIdentity, rightIdentity] + +monoidLaws :: Monoid a => [Law a] +monoidLaws = associative : identityLaws + +commutativeMonoidLaws :: Monoid a => [Law a] +commutativeMonoidLaws = monoidLaws ++ [commutative] + +-- | Not all monoids are idempotent (see: idempotentFor) +idempotent :: Monoid a => Law a +idempotent = idempotentFor (<>) + +-------------------------------------------------------- +-- Groups + +-- | Minimal complete definition: inverse or appendInverse +class Monoid a => Group a where + inverse :: a -> a + appendInv :: a -> a -> a + -- default definitions + inverse = (mempty <>-) + appendInv a b = a <> inverse b + +infixl 6 <>- + +(<>-) :: Group a => a -> a -> a +(<>-) = appendInv + +leftInverse :: Group a => Law a +leftInverse = law "left-inverse" $ \a -> inverse a <> a :==: mempty + +rightInverse :: Group a => Law a +rightInverse = law "right-inverse" $ \a -> a <> inverse a :==: mempty + +doubleInverse :: Group a => Law a +doubleInverse = law "double-inverse" $ \a -> inverse (inverse a) :==: a + +inverseIdentity :: Group a => Law a +inverseIdentity = law "inverse-identity" $ inverse mempty :==: mempty + +inverseDistrFlipped :: Group a => Law a +inverseDistrFlipped = law "inverse-distr-flipped" $ \a b -> + inverse (a <> b) :==: inverse b <> inverse a + +inverseLaws :: Group a => [Law a] +inverseLaws = [leftInverse, rightInverse] + +groupLaws :: Group a => [Law a] +groupLaws = monoidLaws ++ inverseLaws ++ + [doubleInverse, inverseIdentity, inverseDistrFlipped] + +appendInverseLaws :: Group a => [Law a] +appendInverseLaws = + [ make 1 $ \a b -> a <>- b :==: a <> inverse b + , make 2 $ \a -> a <>- a :==: mempty + , make 3 $ \a -> a <>- mempty :==: a + , make 4 $ \a -> mempty <>- a :==: inverse a + , make 5 $ \a b c -> a <>- (b <> c) :==: (a <>- b) <>- c + , make 6 $ \a b c -> a <>- (b <>- c) :==: (a <>- b) <> c + , make 7 $ \a b c -> a <> (b <>- c) :==: (a <> b) <>- c + , make 8 $ \a b -> a <>- inverse b :==: a <> b + , make 9 $ \a b -> inverse (a <>- b) :==: inverse a <> b + ] + where + make n = law ("append-inverse-law" ++ show (n :: Int)) + +-------------------------------------------------------- +-- Abelian groups + +commutative :: Monoid a => Law a +commutative = commutativeFor (<>) + +inverseDistr :: Group a => Law a +inverseDistr = law "inverse-distr" $ \a b -> + inverse (a <> b) :==: (inverse a <> inverse b) + +abelianGroupLaws :: Group a => [Law a] +abelianGroupLaws = groupLaws ++ [commutative, inverseDistr] + +-------------------------------------------------------- +-- Monoids with a zero element +-- This element could be the additive identity from a (semi-)ring for +-- the multiplicative monoid + +class Monoid a => MonoidZero a where + mzero :: a + +leftZero :: MonoidZero a => Law a +leftZero = law "left-zero" $ \a -> mzero <> a :==: mzero + +rightZero:: MonoidZero a => Law a +rightZero = law "right-zero" $ \a -> a <> mzero :==: mzero + +zeroLaws :: MonoidZero a => [Law a] +zeroLaws = [leftZero, rightZero] + +monoidZeroLaws :: MonoidZero a => [Law a] +monoidZeroLaws = monoidLaws ++ zeroLaws + +-- Type that adds a zero element +newtype WithZero a = WZ { fromWithZero :: Maybe a } + deriving (Eq, Ord, Functor, Foldable, Traversable, Applicative) + +instance Monoid a => Monoid (WithZero a) where + mempty = WZ (Just mempty) + mappend x y = WZ (liftM2 mappend (fromWithZero x) (fromWithZero y)) + +instance Monoid a => MonoidZero (WithZero a) where + mzero = WZ Nothing + +-------------------------------------------------------- +-- Generalized laws + +associativeFor :: (a -> a -> a) -> Law a +associativeFor (?) = law "associative" $ \a b c -> + a ? (b ? c) :==: (a ? b) ? c + +commutativeFor :: (a -> a -> a) -> Law a +commutativeFor (?) = law "commutative" $ \a b -> a ? b :==: b ? a + +idempotentFor :: (a -> a -> a) -> Law a +idempotentFor (?) = law "idempotent" $ \a -> a ? a :==: a + +leftDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a +leftDistributiveFor (<*>) (<+>) = law "left-distributive" $ \a b c -> + a <*> (b <+> c) :==: (a <*> b) <+> (a <*> c) + +rightDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a +rightDistributiveFor (<*>) (<+>) = law "right-distributive" $ \a b c -> + (a <+> b) <*> c :==: (a <*> c) <+> (b <*> c) diff --git a/src/Common/Algebra/Law.hs b/src/Common/Algebra/Law.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/Law.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.Law + ( Law, LawSpec((:==:)), law, mapLaw + , propertyLaw, rewriteLaw + ) where + +import Common.Rewriting +import Test.QuickCheck + +infix 1 :==: + +data Law a = Law String (LawSpec a) + +instance Show (Law a) where + show (Law s _) = s + +data LawSpec a = Abs (a -> LawSpec a) | a :==: a + +law :: LawBuilder l a => String -> l -> Law a +law s l = Law s (lawSpec l) + +class LawBuilder l a | l -> a where + lawSpec :: l -> LawSpec a + +instance LawBuilder (LawSpec a) a where + lawSpec = id + +instance LawBuilder b a => LawBuilder (a -> b) a where + lawSpec f = Abs (lawSpec . f) + +instance (Show a, Eq a, Arbitrary a) => Testable (Law a) where + property = propertyLaw (==) + +mapLaw :: (b -> a) -> (a -> b) -> Law a -> Law b +mapLaw to from (Law s l) = Law s (rec l) + where + rec (Abs f) = Abs (rec . f . to) + rec (a :==: b) = from a :==: from b + +propertyLaw :: (Arbitrary a, Show a, Testable b) => (a -> a -> b) -> Law a -> Property +propertyLaw eq = rec . getLawSpec + where + rec (Abs f) = property (rec . f) + rec (a :==: b) = property (eq a b) + +rewriteLaw :: (Different a, IsTerm a, Arbitrary a, Show a) => Law a -> RewriteRule a +rewriteLaw (Law s l) = rewriteRule s l + +instance (Arbitrary a, IsTerm a, Show a, Different a) => RuleBuilder (LawSpec a) a where + buildRuleSpec i (a :==: b) = buildRuleSpec i (a :~> b) + buildRuleSpec i (Abs f) = buildRuleSpec i f + buildGenerator (a :==: b) = buildGenerator (a :~> b) + buildGenerator (Abs f) = buildGenerator f + +getLawSpec :: Law a -> LawSpec a +getLawSpec (Law _ l) = l diff --git a/src/Common/Algebra/SmartGroup.hs b/src/Common/Algebra/SmartGroup.hs new file mode 100644 --- /dev/null +++ b/src/Common/Algebra/SmartGroup.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Algebra.SmartGroup where + +import Common.Algebra.CoGroup +import Common.Algebra.Group +import Control.Applicative +import Control.Monad (mplus) +import Data.Maybe + +newtype Smart a = Smart {fromSmart :: a} + deriving (Show, Eq, Ord, CoMonoid, MonoidZero, CoMonoidZero) + +instance Functor Smart where -- could be derived + fmap f = Smart . f . fromSmart + +instance Applicative Smart where + pure = Smart + Smart f <*> Smart a = Smart (f a) + +instance (CoMonoid a, Monoid a) => Monoid (Smart a) where + mempty = Smart mempty + mappend a b + | isEmpty a = b + | isEmpty b = a + | otherwise = liftA2 (<>) a b + +-------------------------------------------------------------- + +newtype SmartZero a = SmartZero {fromSmartZero :: a} + deriving (Show, Eq, Ord, MonoidZero, CoMonoid, CoMonoidZero) + +instance Functor SmartZero where -- could be derived + fmap f = SmartZero . f . fromSmartZero + +instance Applicative SmartZero where + pure = SmartZero + SmartZero f <*> SmartZero a = SmartZero (f a) + +instance (CoMonoidZero a, MonoidZero a) => Monoid (SmartZero a) where + mempty = SmartZero mempty + mappend a b + | isMonoidZero a || isMonoidZero b = mzero + | otherwise = liftA2 (<>) a b + +-------------------------------------------------------------- + +newtype SmartGroup a = SmartGroup {fromSmartGroup :: a} + deriving (Show, Eq, Ord, CoMonoid, CoGroup, CoMonoidZero, MonoidZero) + +instance Functor SmartGroup where -- could be derived + fmap f = SmartGroup . f . fromSmartGroup + +instance Applicative SmartGroup where + pure = SmartGroup + SmartGroup f <*> SmartGroup a = SmartGroup (f a) + +instance (CoGroup a, Group a) => Monoid (SmartGroup a) where + mempty = SmartGroup mempty + mappend a b + | isEmpty a = b + | otherwise = fromMaybe (liftA2 (<>) a b) (matchGroup alg b) + where + alg = (a, \x y -> (a <> x) <> y, \x -> a <>- x, \x y -> (a <> x) <>- y) + +instance (CoGroup a, Group a) => Group (SmartGroup a) where + inverse a = fromMaybe (liftA inverse a) (matchGroup alg a) + where + alg = (mempty, \x y -> inverse x <>- y, id, \x y -> inverse x <> y) + appendInv a b + | isEmpty a = inverse b + | otherwise = fromMaybe (liftA2 (<>-) a b) (matchGroup alg b) + where + alg = (a, \x y -> (a <>- x) <>- y, \x -> a <> x, \x y -> (a <>- x) <> y) + +-------------------------------------------------------------- + +type GroupMatch a b = (b, a -> a -> b, a -> b, a -> a -> b) + +matchGroup :: CoGroup a => GroupMatch a b -> a -> Maybe b +matchGroup (emp, app, inv, appinv) a = + (if isEmpty a then Just emp else Nothing) `mplus` + fmap (uncurry app) (isAppend a) `mplus` + fmap inv (isInverse a) `mplus` + fmap (uncurry appinv) (isAppendInv a) diff --git a/src/Common/Classes.hs b/src/Common/Classes.hs --- a/src/Common/Classes.hs +++ b/src/Common/Classes.hs @@ -1,112 +1,108 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Type classes and instances. --- ------------------------------------------------------------------------------ -module Common.Classes - ( Apply(..), applicable, applyD, applyM - , Switch(..), Crush(..), Zip(..) - ) where - -import Common.Utils (safeHead) -import Data.Maybe -import Control.Monad.Identity -import qualified Data.IntMap as IM -import qualified Data.Map as M - ------------------------------------------------------------ --- * Type class |Apply| - --- | A type class for functors that can be applied to a value. Transformation, Rule, and --- Strategy are all instances of this type class. Minimal complete definition: only one of --- the two member functions should be defined. -class Apply t where - apply :: t a -> a -> Maybe a -- ^ Returns zero or one results - applyAll :: t a -> a -> [a] -- ^ Returns zero or more results - -- default definitions - apply ta = safeHead . applyAll ta - applyAll ta = maybe [] return . apply ta - --- | Checks whether the functor is applicable (at least one result) -applicable :: Apply t => t a -> a -> Bool -applicable ta = isJust . apply ta - --- | If not applicable, return the current value (as default) -applyD :: Apply t => t a -> a -> a -applyD ta a = fromMaybe a (apply ta a) - --- | Same as apply, except that the result (at most one) is returned in some monad -applyM :: (Apply t, Monad m) => t a -> a -> m a -applyM ta = maybe (fail "applyM") return . apply ta - ------------------------------------------------------------ --- * Type class |Switch| - -class Functor f => Switch f where - switch :: Monad m => f (m a) -> m (f a) - -instance Switch [] where - switch = sequence - -instance Switch Maybe where - switch = maybe (return Nothing) (liftM Just) - -instance Switch Identity where - switch (Identity m) = liftM Identity m - -instance Eq a => Switch (M.Map a) where - switch m = do - let (ns, ms) = unzip (M.toList m) - as <- sequence ms - return $ M.fromAscList $ zip ns as - -instance Switch IM.IntMap where - switch m = do - let (ns, ms) = unzip (IM.toList m) - as <- sequence ms - return $ IM.fromAscList $ zip ns as - ------------------------------------------------------------ --- * Type class |Crush| - -class Functor f => Crush f where - crush :: f a -> [a] - -instance Crush [] where - crush = id - -instance Crush Maybe where - crush = maybe [] return - -instance Crush Identity where - crush = return . runIdentity - -instance Crush (M.Map a) where - crush = M.elems - -instance Crush IM.IntMap where - crush = IM.elems - ------------------------------------------------------------ --- * Type class |Zip| - -class Functor f => Zip f where - fzip :: f a -> f b -> f (a, b) - fzipWith :: (a -> b -> c) -> f a -> f b -> f c - -- default implementation - fzip = fzipWith (,) - fzipWith f a b = fmap (uncurry f) (fzip a b) - -instance Zip [] where - fzipWith = zipWith - -instance Zip Maybe where - fzipWith = liftM2 +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Type classes and instances. +-- +----------------------------------------------------------------------------- +module Common.Classes + ( -- * Type class Apply + Apply, apply, applyAll, applicable, applyD, applyM + -- * Type class Container + , Container, singleton, getSingleton + -- * Type class BiArrow + , BiArrow(..) + -- * Type class BiFunctor + , BiFunctor, biMap, mapFirst, mapSecond, mapBoth + ) where + +import Common.Utils (safeHead) +import Control.Arrow +import Data.Maybe + +import qualified Data.Set as S + +----------------------------------------------------------- +-- Type class Apply + +-- | A type class for functors that can be applied to a value. Transformation, +-- Rule, and Strategy are all instances of this type class. +class Apply t where + applyAll :: t a -> a -> [a] -- ^ Returns zero or more results + +-- | Returns zero or one results +apply :: Apply t => t a -> a -> Maybe a +apply ta = safeHead . applyAll ta + +-- | Checks whether the functor is applicable (at least one result) +applicable :: Apply t => t a -> a -> Bool +applicable ta = isJust . apply ta + +-- | If not applicable, return the current value (as default) +applyD :: Apply t => t a -> a -> a +applyD ta a = fromMaybe a (apply ta a) + +-- | Same as apply, except that the result (at most one) is returned in some monad +applyM :: (Apply t, Monad m) => t a -> a -> m a +applyM ta = maybe (fail "applyM") return . apply ta + +----------------------------------------------------------- +-- Type class Container + +-- | Instances should satisfy the following law: @getSingleton . singleton == Just@ +class Container f where + singleton :: a -> f a + getSingleton :: f a -> Maybe a + +instance Container [] where + singleton = return + getSingleton [a] = Just a + getSingleton _ = Nothing + +instance Container S.Set where + singleton = S.singleton + getSingleton = getSingleton . S.toList + +----------------------------------------------------------- +-- Type class BiArrow + +infix 1 <-> + +-- |Type class for bi-directional arrows. @<->@ should be used instead of +-- @arr@ from the arrow interface. Minimal complete definition: @<->@. +class Arrow arr => BiArrow arr where + (<->) :: (a -> b) -> (b -> a) -> arr a b + (!->) :: (a -> b) -> arr a b + (<-!) :: (b -> a) -> arr a b + -- default definitions + (!->) f = f <-> errBiArrow + (<-!) f = errBiArrow <-> f + +errBiArrow :: a +errBiArrow = error "BiArrow: not bi-directional" + +----------------------------------------------------------- +-- Type class BiFunctor + +class BiFunctor f where + biMap :: (a -> c) -> (b -> d) -> f a b -> f c d + mapFirst :: (a -> b) -> f a c -> f b c + mapSecond :: (b -> c) -> f a b -> f a c + -- default definitions + mapFirst = flip biMap id + mapSecond = biMap id + +instance BiFunctor Either where + biMap f g = either (Left . f) (Right . g) + +instance BiFunctor (,) where + biMap f g (a, b) = (f a, g b) + +mapBoth :: BiFunctor f => (a -> b) -> f a a -> f b b +mapBoth f = biMap f f diff --git a/src/Common/Context.hs b/src/Common/Context.hs --- a/src/Common/Context.hs +++ b/src/Common/Context.hs @@ -1,250 +1,261 @@ -{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A context for a term that maintains an environment of --- key-value pairs. A context is both showable and parsable. --- ------------------------------------------------------------------------------ -module Common.Context - ( -- * Abstract data type - Context, fromContext, newContext, getEnvironment - -- * Key-value pair environment (abstract) - , Environment, emptyEnv, nullEnv, keysEnv, lookupEnv, storeEnv - , diffEnv, deleteEnv - -- * Variables - , Var, newVar, makeVar - -- * Lifting - , liftToContext, liftTransContext - , use, useC, termNavigator, applyTop - -- * Context Monad - , ContextMonad, readVar, writeVar, modifyVar - , maybeCM, withCM, evalCM - ) where - -import Common.Navigator -import Common.Rewriting -import Common.Transformation -import Common.Utils (commaList, readM) -import Common.View -import Control.Monad -import Data.Maybe -import Data.Dynamic -import qualified Data.Map as M - ----------------------------------------------------------- --- Abstract data type - --- | Abstract data type for a context: a context stores an envrionent --- (key-value pairs) and a value -data Context a = C - { getEnvironment :: Environment -- ^ Returns the environment - , getNavigator :: Navigator a -- ^ Retrieve a value from its context - } - -fromContext :: Monad m => Context a -> m a -fromContext = leave . getNavigator - -instance Eq a => Eq (Context a) where - x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y) - -instance Show a => Show (Context a) where - show (C env a) = - let rest | null (keysEnv env) = "" - | otherwise = " {" ++ show env ++ "}" - in show a ++ rest - -instance IsNavigator Context where - up (C env a) = liftM (C env) (up a) - allDowns (C env a) = map (C env) (allDowns a) - current (C _ a) = current a - location (C _ a) = location a - changeM f (C env a) = liftM (C env) (changeM f a) - -instance TypedNavigator Context where - changeT f (C env a) = liftM (C env) (changeT f a) - currentT (C _ a) = currentT a - leaveT (C _ a) = leaveT a - castT v (C env a) = liftM (C env) (castT v a) - --- | Construct a context -newContext :: Environment -> Navigator a -> Context a -newContext = C - ----------------------------------------------------------- --- Key-value pair environment (abstract) - -newtype Environment = Env { envMap :: M.Map String (Maybe Dynamic, String) } - -instance Show Environment where - show = - let f (k, (_, v)) = k ++ "=" ++ v - in commaList . map f . M.toList . envMap - -emptyEnv :: Environment -emptyEnv = Env M.empty - -nullEnv :: Environment -> Bool -nullEnv = null . keysEnv - -keysEnv :: Environment -> [String] -keysEnv = M.keys . envMap - -lookupEnv :: Typeable a => String -> Environment -> Maybe a -lookupEnv s (Env m) = result - where - result -- Special case for result type String - | typeOf result == typeOf (Just "") = do - (_, txt) <- M.lookup s m - cast txt - | otherwise = do - (md, _) <- M.lookup s m - d <- md - fromDynamic d - -storeEnv :: (Typeable a, Show a) => String -> a -> Environment -> Environment -storeEnv = storeEnvWith show - --- Generalized helper-function -storeEnvWith :: Typeable a => (a -> String) -> String -> a -> Environment -> Environment -storeEnvWith f s a (Env m) = Env (M.insert s pair m) - where -- Special case for type String - pair = - case cast a of - Just txt -> (Nothing, txt) - Nothing -> (Just (toDyn a), f a) - -diffEnv :: Environment -> Environment -> Environment -diffEnv (Env m1) (Env m2) = Env (M.filterWithKey p m1) - where p k (_, s) = maybe True ((/=s) . snd) (M.lookup k m2) - -deleteEnv :: String -> Environment -> Environment -deleteEnv s (Env m) = Env (M.delete s m) - ----------------------------------------------------------- --- Variables - --- | A variable has a name and a default value (for initializing). Each --- stored value must be readable and showable. -data Var a = V - { varName :: String - , varInitial :: a - , varShow :: a -> String - , varRead :: String -> Maybe a - } - --- | Simple constructor function for creating a variable. Uses the --- Show and Read type classes -newVar :: (Show a, Read a) => String -> a -> Var a -newVar = makeVar show readM - --- | Extended constructor function for creating a variable. The show --- and read functions are supplied explicitly. -makeVar :: (a -> String) -> (String -> Maybe a) -> String -> a -> Var a -makeVar showF readF s a = V s a showF readF - ----------------------------------------------------------- --- Lifting rewrite rules - --- | Lift a rule to operate on a term in a context -liftToContext :: Rule a -> Rule (Context a) -liftToContext = liftRuleIn contextView - -liftTransContext :: Transformation a -> Transformation (Context a) -liftTransContext = liftTransIn contextView - --- | Apply a function at top-level. Afterwards, try to return the focus --- to the old position -applyTop :: (a -> a) -> Context a -> Context a -applyTop f c = - case top c of - Just ok -> navigateTowards (location c) (change f ok) - Nothing -> c - -termNavigator :: IsTerm a => a -> Navigator a -termNavigator a = fromMaybe (noNavigator a) (make a) - where - make = castT termView . viewNavigatorWith spineHoles . toTerm - - spineHoles :: Term -> [(Term, Term -> Term)] - spineHoles term - | null xs = [] - | otherwise = (x, flip makeTerm xs) : zipWith f [0..] xs - where - (x, xs) = getSpine term - f i y = (y, makeTerm x . changeAt i) - changeAt i b = - case splitAt i xs of - (ys, _:zs) -> ys ++ b:zs - _ -> xs - -use :: (IsTerm a, IsTerm b) => Rule a -> Rule (Context b) -use = useC . liftToContext - -useC :: (IsTerm a, IsTerm b) => Rule (Context a) -> Rule (Context b) -useC = liftRule (makeView (castT termView) (fromJust . castT termView)) - -contextView :: View (Context a) (a, Context a) -contextView = newView "views.contextView" f g - where - f ctx = current ctx >>= \a -> Just (a, ctx) - g = uncurry replace - ----------------------------------------------------------- --- Context monad - -newtype ContextMonad a = CM { unCM :: Environment -> Maybe (a, Environment) } - -withCM :: (a -> ContextMonad a) -> Context a -> Maybe (Context a) -withCM f c = do - a0 <- current c - (a, env) <- unCM (f a0) (getEnvironment c) - let nav = replace a (getNavigator c) - return (newContext env nav) - -evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b -evalCM f c = do - a0 <- current c - (b, _) <- unCM (f a0) (getEnvironment c) - return b - -instance Functor ContextMonad where - fmap = liftM - -instance Monad ContextMonad where - fail = const mzero - return a = CM (\env -> return (a, env)) - CM m >>= f = CM (\env -> do (a, e) <- m env - let CM g = f a - g e) - -instance MonadPlus ContextMonad where - mzero = CM (const mzero) - mplus (CM f) (CM g) = CM (\env -> f env `mplus` g env) - -readVar :: Typeable a => Var a -> ContextMonad a -readVar var = CM $ \env -> return $ - let name = varName var - txt = fromMaybe "" $ lookupEnv name env - in case (lookupEnv name env, varRead var txt) of - (Just a, _) -> (a, env) - (_, Just a) -> (a, storeEnvWith (varShow var) name a env) - _ -> (varInitial var, env) - -writeVar :: Typeable a => Var a -> a -> ContextMonad () -writeVar var a = - let f = storeEnvWith (varShow var) (varName var) a - in CM $ \env -> return ((), f env) - -modifyVar :: Typeable a => Var a -> (a -> a) -> ContextMonad () -modifyVar var f = readVar var >>= (writeVar var . f) - -maybeCM :: Maybe a -> ContextMonad a +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A context for a term that maintains an environment of +-- key-value pairs. A context is both showable and parsable. +-- +----------------------------------------------------------------------------- +module Common.Context + ( -- * Abstract data type + Context, fromContext, fromContextWith, fromContextWith2 + , newContext, getEnvironment, modifyEnvironment + -- * Key-value pair environment (abstract) + , Environment, emptyEnv, nullEnv, keysEnv, lookupEnv, storeEnv + , diffEnv, deleteEnv + -- * Variables + , Var, newVar, makeVar + -- * Lifting + , liftToContext, liftTransContext + , use, useC, termNavigator, applyTop + -- * Context Monad + , ContextMonad, readVar, writeVar, modifyVar + , maybeCM, withCM, evalCM + ) where + +import Common.Id +import Common.Navigator +import Common.Rewriting +import Common.Transformation +import Common.Utils (commaList, readM) +import Common.View +import Control.Monad +import Data.Dynamic +import Data.Maybe +import qualified Data.Map as M + +---------------------------------------------------------- +-- Abstract data type + +-- | Abstract data type for a context: a context stores an envrionent +-- (key-value pairs) and a value +data Context a = C + { getEnvironment :: Environment -- ^ Returns the environment + , getNavigator :: Navigator a -- ^ Retrieve a value from its context + } + +fromContext :: Monad m => Context a -> m a +fromContext = leave . getNavigator + +fromContextWith :: Monad m => (a -> b) -> Context a -> m b +fromContextWith f = liftM f . fromContext + +fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c +fromContextWith2 f a b = liftM2 f (fromContext a) (fromContext b) + +instance Eq a => Eq (Context a) where + x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y) + +instance Show a => Show (Context a) where + show (C env a) = + let rest | null (keysEnv env) = "" + | otherwise = " {" ++ show env ++ "}" + in show a ++ rest + +instance IsNavigator Context where + up (C env a) = liftM (C env) (up a) + allDowns (C env a) = map (C env) (allDowns a) + current (C _ a) = current a + location (C _ a) = location a + changeM f (C env a) = liftM (C env) (changeM f a) + +instance TypedNavigator Context where + changeT f (C env a) = liftM (C env) (changeT f a) + currentT (C _ a) = currentT a + leaveT (C _ a) = leaveT a + castT v (C env a) = liftM (C env) (castT v a) + +-- | Construct a context +newContext :: Environment -> Navigator a -> Context a +newContext = C + +modifyEnvironment :: (Environment -> Environment) -> Context a -> Context a +modifyEnvironment f c = c {getEnvironment = f (getEnvironment c)} + +---------------------------------------------------------- +-- Key-value pair environment (abstract) + +newtype Environment = Env { envMap :: M.Map String (Maybe Dynamic, String) } + +instance Show Environment where + show = + let f (k, (_, v)) = k ++ "=" ++ v + in commaList . map f . M.toList . envMap + +emptyEnv :: Environment +emptyEnv = Env M.empty + +nullEnv :: Environment -> Bool +nullEnv = null . keysEnv + +keysEnv :: Environment -> [String] +keysEnv = M.keys . envMap + +lookupEnv :: Typeable a => String -> Environment -> Maybe a +lookupEnv s (Env m) = result + where + result -- Special case for result type String + | typeOf result == typeOf (Just "") = do + (_, txt) <- M.lookup s m + cast txt + | otherwise = do + (md, _) <- M.lookup s m + d <- md + fromDynamic d + +storeEnv :: (Typeable a, Show a) => String -> a -> Environment -> Environment +storeEnv = storeEnvWith show + +-- Generalized helper-function +storeEnvWith :: Typeable a => (a -> String) -> String -> a -> Environment -> Environment +storeEnvWith f s a (Env m) = Env (M.insert s pair m) + where -- Special case for type String + pair = + case cast a of + Just txt -> (Nothing, txt) + Nothing -> (Just (toDyn a), f a) + +diffEnv :: Environment -> Environment -> Environment +diffEnv (Env m1) (Env m2) = Env (M.filterWithKey p m1) + where p k (_, s) = maybe True ((/=s) . snd) (M.lookup k m2) + +deleteEnv :: String -> Environment -> Environment +deleteEnv s (Env m) = Env (M.delete s m) + +---------------------------------------------------------- +-- Variables + +-- | A variable has a name and a default value (for initializing). Each +-- stored value must be readable and showable. +data Var a = V + { varName :: String + , varInitial :: a + , varShow :: a -> String + , varRead :: String -> Maybe a + } + +-- | Simple constructor function for creating a variable. Uses the +-- Show and Read type classes +newVar :: (Show a, Read a) => String -> a -> Var a +newVar = makeVar show readM + +-- | Extended constructor function for creating a variable. The show +-- and read functions are supplied explicitly. +makeVar :: (a -> String) -> (String -> Maybe a) -> String -> a -> Var a +makeVar showF readF s a = V s a showF readF + +---------------------------------------------------------- +-- Lifting rewrite rules + +-- | Lift a rule to operate on a term in a context +liftToContext :: Rule a -> Rule (Context a) +liftToContext = liftRuleIn contextView + +liftTransContext :: Transformation a -> Transformation (Context a) +liftTransContext = liftTransIn contextView + +-- | Apply a function at top-level. Afterwards, try to return the focus +-- to the old position +applyTop :: (a -> a) -> Context a -> Context a +applyTop f c = + case top c of + Just ok -> navigateTowards (location c) (change f ok) + Nothing -> c + +termNavigator :: IsTerm a => a -> Navigator a +termNavigator a = fromMaybe (noNavigator a) (make a) + where + make = castT termView . viewNavigatorWith spineHoles . toTerm + + spineHoles :: Term -> [(Term, Term -> Term)] + spineHoles term + | null xs = [] + | otherwise = (x, flip makeTerm xs) : zipWith f [0..] xs + where + (x, xs) = getSpine term + f i y = (y, makeTerm x . changeAt i) + changeAt i b = + case splitAt i xs of + (ys, _:zs) -> ys ++ b:zs + _ -> xs + +use :: (IsTerm a, IsTerm b) => Rule a -> Rule (Context b) +use = useC . liftToContext + +useC :: (IsTerm a, IsTerm b) => Rule (Context a) -> Rule (Context b) +useC = liftRule (makeView (castT termView) (fromJust . castT termView)) + +contextView :: View (Context a) (a, Context a) +contextView = "views.contextView" @> makeView f g + where + f ctx = current ctx >>= \a -> Just (a, ctx) + g = uncurry replace + +---------------------------------------------------------- +-- Context monad + +newtype ContextMonad a = CM { unCM :: Environment -> Maybe (a, Environment) } + +withCM :: (a -> ContextMonad a) -> Context a -> Maybe (Context a) +withCM f c = do + a0 <- current c + (a, env) <- unCM (f a0) (getEnvironment c) + let nav = replace a (getNavigator c) + return (newContext env nav) + +evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b +evalCM f c = do + a0 <- current c + (b, _) <- unCM (f a0) (getEnvironment c) + return b + +instance Functor ContextMonad where + fmap = liftM + +instance Monad ContextMonad where + fail = const mzero + return a = CM (\env -> return (a, env)) + CM m >>= f = CM (\env -> do (a, e) <- m env + let CM g = f a + g e) + +instance MonadPlus ContextMonad where + mzero = CM (const mzero) + mplus (CM f) (CM g) = CM (\env -> f env `mplus` g env) + +readVar :: Typeable a => Var a -> ContextMonad a +readVar var = CM $ \env -> return $ + let name = varName var + txt = fromMaybe "" $ lookupEnv name env + in case (lookupEnv name env, varRead var txt) of + (Just a, _) -> (a, env) + (_, Just a) -> (a, storeEnvWith (varShow var) name a env) + _ -> (varInitial var, env) + +writeVar :: Typeable a => Var a -> a -> ContextMonad () +writeVar var a = + let f = storeEnvWith (varShow var) (varName var) a + in CM $ \env -> return ((), f env) + +modifyVar :: Typeable a => Var a -> (a -> a) -> ContextMonad () +modifyVar var f = readVar var >>= (writeVar var . f) + +maybeCM :: Maybe a -> ContextMonad a maybeCM = maybe mzero return diff --git a/src/Common/Derivation.hs b/src/Common/Derivation.hs --- a/src/Common/Derivation.hs +++ b/src/Common/Derivation.hs @@ -1,238 +1,105 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Datatype for representing derivations as a tree. The datatype stores all --- intermediate results as well as annotations for the steps. --- ------------------------------------------------------------------------------ -module Common.Derivation - ( -- * Data types - DerivationTree, Derivations, Derivation - -- * Constructors - , singleNode, addBranch, addBranches, newDerivation - -- * Query - , root, endpoint, branches, annotations, subtrees - , results, lengthMax - -- * Adapters - , restrictHeight, restrictWidth, commit - , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps - , changeLabel, sortTree - -- * Query a derivation - , isEmpty, derivationLength, terms, steps, triples, filterDerivation - , mapStepsDerivation, derivationM - -- * Conversions - , derivation, randomDerivation, derivations - ) where - -import Common.Utils (safeHead) -import Control.Arrow -import Control.Monad -import Data.List -import Data.Maybe -import System.Random - ------------------------------------------------------------------------------ --- Data type definitions for derivation trees and derivation lists - -data DerivationTree s a = DT - { root :: a -- ^ The root of the tree - , endpoint :: Bool -- ^ Is this node an endpoint? - , branches :: [(s, DerivationTree s a)] -- ^ All branches - } - deriving Show - -type Derivations s a = [Derivation s a] - -data Derivation s a = D a [(s, a)] - -instance (Show s, Show a) => Show (Derivation s a) where - show (D a xs) = unlines $ - show a : concatMap (\(r, b) -> [" => " ++ show r, show b]) xs - -instance Functor (DerivationTree s) where - fmap f (DT a b xs) = DT (f a) b (map (second (fmap f)) xs) - -instance Functor (Derivation s) where - fmap f (D a xs) = D (f a) (map (second f) xs) - ------------------------------------------------------------------------------ --- Constructors for a derivation tree - --- | Constructs a node without branches; the boolean indicates whether the --- node is an endpoint or not -singleNode :: a -> Bool -> DerivationTree s a -singleNode a b = DT a b [] - --- | Add a single branch -addBranch :: (s, DerivationTree s a) -> DerivationTree s a -> DerivationTree s a -addBranch = addBranches . return - --- | Branches are attached after the existing ones (order matters) -addBranches :: [(s, DerivationTree s a)] -> DerivationTree s a -> DerivationTree s a -addBranches new (DT a b xs) = DT a b (xs ++ new) - ------------------------------------------------------------------------------ --- Inspecting a derivation tree - --- | Returns the annotations at a given node -annotations :: DerivationTree s a -> [s] -annotations = map fst . branches - --- | Returns all subtrees at a given node -subtrees :: DerivationTree s a -> [DerivationTree s a] -subtrees = map snd . branches - --- | Returns all final terms -results :: DerivationTree s a -> [a] -results = map f . derivations - where f (D a xs) = last (a:map snd xs) - --- | The argument supplied is the maximum number of steps; if more steps are --- needed, Nothing is returned -lengthMax :: Int -> DerivationTree s a -> Maybe Int -lengthMax n = join . fmap (f . derivationLength) . derivation - . commit . restrictHeight (n+1) - where - f i = if i<=n then Just i else Nothing - ------------------------------------------------------------------------------ --- Changing a derivation tree - --- | Restrict the height of the tree (by cutting off branches at a certain depth). --- Nodes at this particular depth are turned into endpoints -restrictHeight :: Int -> DerivationTree s a -> DerivationTree s a -restrictHeight n t - | n == 0 = singleNode (root t) True - | otherwise = t {branches = map f (branches t)} - where - f = second (restrictHeight (n-1)) - --- | Restrict the width of the tree (by cuttin off branches). -restrictWidth :: Int -> DerivationTree s a -> DerivationTree s a -restrictWidth n = rec - where - rec t = t {branches = map (second rec) (take n (branches t))} - --- | Commit to the left-most derivation (even if this path is unsuccessful) -commit :: DerivationTree s a -> DerivationTree s a -commit = restrictWidth 1 - --- | Filter out intermediate steps, and merge its branches (and endpoints) with --- the rest of the derivation tree -mergeSteps :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a -mergeSteps p = rec - where - rec t = addBranches (concat list) (singleNode (root t) isEnd) - where - new = map rec (subtrees t) - (bools, list) = unzip (zipWith f (annotations t) new) - isEnd = endpoint t || or bools - f s st - | p s = (False, [(s, st)]) - | otherwise = (endpoint st, branches st) - --- Change the annotation -mapSteps :: (s -> t) -> DerivationTree s a -> DerivationTree t a -mapSteps f t = t {branches = map g (branches t)} - where g (s, st) = (f s, mapSteps f st) - -changeLabel :: (l -> m) -> DerivationTree l a -> DerivationTree m a -changeLabel f = rec - where - rec t = t {branches = map (f *** rec) (branches t)} - -sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a -sortTree f t = t {branches = change (branches t) } - where - change = map (second (sortTree f)) . sortBy cmp - cmp (l1, _) (l2, _) = f l1 l2 - -mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a -mergeMaybeSteps = mapSteps fromJust . mergeSteps isJust - -cutOnStep :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a -cutOnStep p = rec - where - rec t = t {branches = map f (branches t)} - f (s, t) - | p s = (s, singleNode (root t) True) - | otherwise = (s, rec t) - ------------------------------------------------------------------------------ --- Inspecting a derivation - -newDerivation :: a -> [(s, a)] -> Derivation s a -newDerivation = D - --- | Tests whether the derivation is empty -isEmpty :: Derivation s a -> Bool -isEmpty (D _ xs) = null xs - -mapStepsDerivation :: (s -> t) -> Derivation s a -> Derivation t a -mapStepsDerivation f (D a xs) = D a (map (first f) xs) - --- | Returns the number of steps in a derivation -derivationLength :: Derivation s a -> Int -derivationLength (D _ xs) = length xs - --- | All terms in a derivation -terms :: Derivation s a -> [a] -terms (D a xs) = a:map snd xs - --- | All steps in a derivation -steps :: Derivation s a -> [s] -steps (D _ xs) = map fst xs - --- | The triples of a derivation, consisting of the before term, the --- step, and the after term. -triples :: Derivation s a -> [(a, s, a)] -triples d = zip3 (terms d) (steps d) (tail (terms d)) - --- | Filter steps from a derivation -filterDerivation :: (s -> a -> Bool) -> Derivation s a -> Derivation s a -filterDerivation p (D a xs) = D a (filter (uncurry p) xs) - --- | Apply a monadic function to each term, and to each step -derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m () -derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) xs - ------------------------------------------------------------------------------ --- Conversions from a derivation tree - --- | All possible derivations (returned in a list) -derivations :: DerivationTree s a -> Derivations s a -derivations t = map (D (root t)) $ - [ [] | endpoint t ] ++ - [ (r,a2):ys | (r, st) <- branches t, D a2 ys <- derivations st ] - --- | The first derivation (if any) -derivation :: DerivationTree s a -> Maybe (Derivation s a) -derivation = safeHead . derivations - --- | Return a random derivation (if any exists at all) -randomDerivation :: RandomGen g => g -> DerivationTree s a -> Maybe (Derivation s a) -randomDerivation g t = msum xs - where - (xs, g0) = shuffle g list - list = map (fmap (D (root t))) $ - [ Just [] | endpoint t ] ++ map make (branches t) - make (r, st) = do - D a2 ys <- randomDerivation g0 st - return ((r,a2):ys) - -shuffle :: RandomGen g => g -> [a] -> ([a], g) -shuffle g0 xs = rec g0 [] (length xs) xs - where - rec g acc n ys = - case splitAt i ys of - (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs) - _ -> (acc, g) - where - (i, g1) = randomR (0, n-1) g +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Datatype for representing a derivation (parameterized both in the terms +-- and the steps) +-- +----------------------------------------------------------------------------- +module Common.Derivation + ( -- * Data type + Derivation + -- * Constructing a derivation + , emptyDerivation, prepend, extend + -- * Querying a derivation + , isEmpty, derivationLength, terms, steps, triples + , firstTerm, lastTerm, lastStep, withoutLast + , updateSteps, derivationM + ) where + +import Common.Classes +import Common.Utils (safeHead) +import qualified Data.Foldable as F +import qualified Data.Sequence as S + +----------------------------------------------------------------------------- +-- Data type definition and instances + +data Derivation s a = D a (S.Seq (s, a)) + +instance (Show s, Show a) => Show (Derivation s a) where + show (D a xs) = unlines $ + show a : concatMap (\(r, b) -> [" => " ++ show r, show b]) (F.toList xs) + +instance Functor (Derivation s) where + fmap = mapSecond + +instance BiFunctor Derivation where + biMap f g (D a xs) = D (g a) (fmap (biMap f g) xs) + +----------------------------------------------------------------------------- +-- Constructing a derivation + +emptyDerivation :: a -> Derivation s a +emptyDerivation a = D a S.empty + +prepend :: (a, s) -> Derivation s a -> Derivation s a +prepend (a, s) (D b xs) = D a ((s, b) S.<| xs) + +extend :: Derivation s a -> (s, a) -> Derivation s a +extend (D a xs) p = D a (xs S.|> p) + +----------------------------------------------------------------------------- +-- Querying a derivation + +-- | Tests whether the derivation is empty +isEmpty :: Derivation s a -> Bool +isEmpty (D _ xs) = S.null xs + +-- | Returns the number of steps in a derivation +derivationLength :: Derivation s a -> Int +derivationLength (D _ xs) = S.length xs + +-- | All terms in a derivation +terms :: Derivation s a -> [a] +terms (D a xs) = a:map snd (F.toList xs) + +-- | All steps in a derivation +steps :: Derivation s a -> [s] +steps (D _ xs) = map fst (F.toList xs) + +-- | The triples of a derivation, consisting of the before term, the +-- step, and the after term. +triples :: Derivation s a -> [(a, s, a)] +triples d = zip3 (terms d) (steps d) (tail (terms d)) + +firstTerm :: Derivation s a -> a +firstTerm = head . terms + +lastTerm :: Derivation s a -> a +lastTerm = last . terms + +lastStep:: Derivation s a -> Maybe s +lastStep = safeHead . reverse . steps + +withoutLast :: Derivation s a -> Derivation s a +withoutLast d@(D a xs) = + case S.viewr xs of + S.EmptyR -> d + ys S.:> _ -> D a ys + +updateSteps :: (a -> s -> a -> t) -> Derivation s a -> Derivation t a +updateSteps f d = + let ts = [ f a b c | (a, b, c) <- triples d ] + x:xs = terms d + in D x (S.fromList (zip ts xs)) + +-- | Apply a monadic function to each term, and to each step +derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m () +derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs) diff --git a/src/Common/DerivationTree.hs b/src/Common/DerivationTree.hs new file mode 100644 --- /dev/null +++ b/src/Common/DerivationTree.hs @@ -0,0 +1,188 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Datatype for representing derivations as a tree. The datatype stores all +-- intermediate results as well as annotations for the steps. +-- +----------------------------------------------------------------------------- +module Common.DerivationTree + ( -- * Data types + DerivationTree + -- * Constructors + , singleNode, addBranches, makeTree + -- * Query + , root, endpoint, branches, subtrees + , leafs, lengthMax + -- * Adapters + , restrictHeight, restrictWidth, updateAnnotations + , cutOnStep, mergeMaybeSteps, sortTree + -- * Conversions + , derivation, randomDerivation, derivations + ) where + +import Common.Classes +import Common.Derivation +import Common.Utils (safeHead) +import Control.Monad +import Data.List +import Data.Maybe +import System.Random + +----------------------------------------------------------------------------- +-- Data type definitions for derivation trees and derivation lists + +data DerivationTree s a = DT + { root :: a -- ^ The root of the tree + , endpoint :: Bool -- ^ Is this node an endpoint? + , branches :: [(s, DerivationTree s a)] -- ^ All branches + } + deriving Show + +instance Functor (DerivationTree s) where + fmap = mapSecond + +instance BiFunctor DerivationTree where + biMap f g (DT a b xs) = DT (g a) b (map (biMap f (biMap f g)) xs) + +----------------------------------------------------------------------------- +-- Constructors for a derivation tree + +-- | Constructs a node without branches; the boolean indicates whether the +-- node is an endpoint or not +singleNode :: a -> Bool -> DerivationTree s a +singleNode a b = DT a b [] + +-- | Branches are attached after the existing ones (order matters) +addBranches :: [(s, DerivationTree s a)] -> DerivationTree s a -> DerivationTree s a +addBranches new (DT a b xs) = DT a b (xs ++ new) + +makeTree :: (a -> (Bool, [(s, a)])) -> a -> DerivationTree s a +makeTree f = rec + where + rec a = let (b, xs) = f a + in addBranches (map (mapSecond rec) xs) (singleNode a b) + +----------------------------------------------------------------------------- +-- Inspecting a derivation tree + +-- | Returns the annotations at a given node +annotations :: DerivationTree s a -> [s] +annotations = map fst . branches + +-- | Returns all subtrees at a given node +subtrees :: DerivationTree s a -> [DerivationTree s a] +subtrees = map snd . branches + +-- | Returns all leafs, i.e., final results in derivation. Be careful: +-- the returned list may be very long +leafs :: DerivationTree s a -> [a] +leafs t = [ root t | endpoint t ] ++ concatMap leafs (subtrees t) + +-- | The argument supplied is the maximum number of steps; if more steps are +-- needed, Nothing is returned +lengthMax :: Int -> DerivationTree s a -> Maybe Int +lengthMax n = join . fmap (f . derivationLength) . derivation + . commit . restrictHeight (n+1) + where + f i = if i<=n then Just i else Nothing + +updateAnnotations :: (a -> s -> a -> t) -> DerivationTree s a -> DerivationTree t a +updateAnnotations f = rec + where + rec (DT a b xs) = + let g (s, t) = (f a s (root t), rec t) + in DT a b (map g xs) + +----------------------------------------------------------------------------- +-- Changing a derivation tree + +-- | Restrict the height of the tree (by cutting off branches at a certain depth). +-- Nodes at this particular depth are turned into endpoints +restrictHeight :: Int -> DerivationTree s a -> DerivationTree s a +restrictHeight n t + | n == 0 = singleNode (root t) True + | otherwise = t {branches = map f (branches t)} + where + f = mapSecond (restrictHeight (n-1)) + +-- | Restrict the width of the tree (by cutting off branches). +restrictWidth :: Int -> DerivationTree s a -> DerivationTree s a +restrictWidth n = rec + where + rec t = t {branches = map (mapSecond rec) (take n (branches t))} + +-- | Commit to the left-most derivation (even if this path is unsuccessful) +commit :: DerivationTree s a -> DerivationTree s a +commit = restrictWidth 1 + +-- | Filter out intermediate steps, and merge its branches (and endpoints) with +-- the rest of the derivation tree +mergeSteps :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a +mergeSteps p = rec + where + rec t = addBranches (concat list) (singleNode (root t) isEnd) + where + new = map rec (subtrees t) + (bools, list) = unzip (zipWith f (annotations t) new) + isEnd = endpoint t || or bools + f s st + | p s = (False, [(s, st)]) + | otherwise = (endpoint st, branches st) + +sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a +sortTree f t = t {branches = change (branches t) } + where + change = map (mapSecond (sortTree f)) . sortBy cmp + cmp (l1, _) (l2, _) = f l1 l2 + +mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a +mergeMaybeSteps = mapFirst fromJust . mergeSteps isJust + +cutOnStep :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a +cutOnStep p = rec + where + rec t = t {branches = map f (branches t)} + f (s, t) + | p s = (s, singleNode (root t) True) + | otherwise = (s, rec t) + +----------------------------------------------------------------------------- +-- Conversions from a derivation tree + +-- | All possible derivations (returned in a list) +derivations :: DerivationTree s a -> [Derivation s a] +derivations t = + [ emptyDerivation (root t) | endpoint t ] ++ + [ (root t, r) `prepend` d | (r, st) <- branches t, d <- derivations st ] + +-- | The first derivation (if any) +derivation :: DerivationTree s a -> Maybe (Derivation s a) +derivation = safeHead . derivations + +-- | Return a random derivation (if any exists at all) +randomDerivation :: RandomGen g => g -> DerivationTree s a -> Maybe (Derivation s a) +randomDerivation g t = msum xs + where + (xs, g0) = shuffle g list + list = [ Just (emptyDerivation (root t)) | endpoint t ] ++ + map make (branches t) + make (r, st) = do + d <- randomDerivation g0 st + return ((root t, r) `prepend` d) + +shuffle :: RandomGen g => g -> [a] -> ([a], g) +shuffle g0 xs = rec g0 [] (length xs) xs + where + rec g acc n ys = + case splitAt i ys of + (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs) + _ -> (acc, g) + where + (i, g1) = randomR (0, n-1) g diff --git a/src/Common/Exercise.hs b/src/Common/Exercise.hs --- a/src/Common/Exercise.hs +++ b/src/Common/Exercise.hs @@ -1,447 +1,496 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines the concept of an exercise --- ------------------------------------------------------------------------------ -module Common.Exercise - ( -- * Exercises - Exercise, testableExercise, makeExercise, emptyExercise - , exerciseId, status, parser, prettyPrinter - , equivalence, similarity, isReady, isSuitable, eqWithContext - , strategy, navigation, canBeRestarted, extraRules, ruleOrdering - , difference, ordering, testGenerator, randomExercise, examples, getRule - , simpleGenerator, useGenerator - , randomTerm, randomTermWith, ruleset - , makeContext, inContext, recognizeRule, ruleIsRecognized - , ruleOrderingWith, ruleOrderingWithId - -- * Exercise status - , Status(..), isPublic, isPrivate - -- * Miscellaneous - , prettyPrinterContext - , equivalenceContext, restrictGenerator - , showDerivation, printDerivation - , ExerciseDerivation, defaultDerivation, derivationDiffEnv - , checkExercise, checkParserPretty - , checkExamples, exerciseTestSuite - , module Common.Id -- for backwards compatibility - ) where - -import Common.Classes -import Common.Context -import Common.Strategy hiding (not, fail, replicate) -import qualified Common.Strategy as S -import Common.Derivation -import Common.Id -import Common.Navigator -import Common.TestSuite -import Common.Transformation -import Common.Utils (ShowString(..)) -import Common.View (makeView) -import Control.Monad.Error -import Data.List -import Data.Maybe -import Data.Ord -import System.Random -import Test.QuickCheck hiding (label) -import Test.QuickCheck.Gen - -data Exercise a = Exercise - { -- identification and meta-information - exerciseId :: Id -- identifier that uniquely determines the exercise - , status :: Status - -- parsing and pretty-printing - , parser :: String -> Either String a - , prettyPrinter :: a -> String - -- syntactic and semantic checks - , equivalence :: a -> a -> Bool - , similarity :: a -> a -> Bool -- possibly more liberal than syntactic equality - , ordering :: a -> a -> Ordering -- syntactic comparison - , isReady :: a -> Bool - , isSuitable :: a -> Bool - , difference :: Bool -> a -> a -> Maybe (a, a) - , eqWithContext :: Maybe (Context a -> Context a -> Bool) -- special equivalence with context info - -- strategies and rules - , strategy :: LabeledStrategy (Context a) - , navigation :: a -> Navigator a - , canBeRestarted :: Bool -- By default, assumed to be the case - , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy - , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst) - -- testing and exercise generation - , testGenerator :: Maybe (Gen a) - , randomExercise :: Maybe (StdGen -> Int -> a) - , examples :: [a] - } - -instance Eq (Exercise a) where - e1 == e2 = getId e1 == getId e2 - -instance Ord (Exercise a) where - compare = comparing getId - -instance Apply Exercise where - applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex - -instance HasId (Exercise a) where - getId = exerciseId - changeId f ex = ex { exerciseId = f (exerciseId ex) } - -testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a -testableExercise = makeExercise - { testGenerator = Just arbitrary - } - -makeExercise :: (Show a, Ord a) => Exercise a -makeExercise = emptyExercise - { prettyPrinter = show - , similarity = (==) - , ordering = compare - } - -emptyExercise :: Exercise a -emptyExercise = Exercise - { -- identification and meta-information - exerciseId = error "no exercise code" - , status = Experimental - -- parsing and pretty-printing - , parser = const (Left "<>") - , prettyPrinter = const "<>" - -- syntactic and semantic checks - , equivalence = \_ _ -> True - , similarity = \_ _ -> True - , ordering = \_ _ -> EQ - , isReady = const True - , isSuitable = const True - , difference = \_ _ _ -> Nothing - , eqWithContext = Nothing - -- strategies and rules - , strategy = label "Fail" S.fail - , navigation = noNavigator - , canBeRestarted = True - , extraRules = [] - , ruleOrdering = compareId - -- testing and exercise generation - , testGenerator = Nothing - , randomExercise = Nothing - , examples = [] - } - -makeContext :: Exercise a -> Environment -> a -> Context a -makeContext ex env = newContext env . navigation ex - --- | Put a value into an empty environment -inContext :: Exercise a -> a -> Context a -inContext = flip makeContext emptyEnv - ---------------------------------------------------------------- --- Exercise generators - --- returns a sorted list of rules (no duplicates) -ruleset :: Exercise a -> [Rule (Context a)] -ruleset ex = nub (sortBy compareId list) - where - list = rulesInStrategy (strategy ex) ++ extraRules ex - -simpleGenerator :: Gen a -> Maybe (StdGen -> Int -> a) -simpleGenerator = useGenerator (const True) . const - -useGenerator :: (a -> Bool) -> (Int -> Gen a) -> Maybe (StdGen -> Int -> a) -useGenerator p makeGen = Just (\rng -> rec rng . makeGen) - where - rec rng gen@(MkGen f) - | p a = a - | otherwise = rec (snd (next rng)) gen - where - (size, r) = randomR (0, 100) rng - a = f r size - -restrictGenerator :: (a -> Bool) -> Gen a -> Gen a -restrictGenerator p g = do - a <- g - if p a then return a - else restrictGenerator p g - -randomTerm :: Int -> Exercise a -> IO a -randomTerm level ex = do - rng <- newStdGen - return (randomTermWith rng level ex) - -randomTermWith :: StdGen -> Int -> Exercise a -> a -randomTermWith rng level ex = - case randomExercise ex of - Just f -> f rng level - Nothing - | null xs -> error "randomTermWith: no generator" - | otherwise -> - xs !! fst (randomR (0, length xs - 1) rng) - where xs = examples ex - -ruleIsRecognized :: Exercise a -> Rule (Context a) -> Context a -> Context a -> Bool -ruleIsRecognized ex r ca = not . null . recognizeRule ex r ca - --- Recognize a rule at (possibly multiple) locations -recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [Location] -recognizeRule ex r ca cb = rec (fromMaybe ca (top ca)) - where - rec x = [ location x | here r x cb ] ++ concatMap rec (allDowns x) - here = ruleRecognizer $ \cx cy -> fromMaybe False $ - liftM2 (similarity ex) (fromContext cx) (fromContext cy) - -ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering -ruleOrderingWith = ruleOrderingWithId . map getId - -ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering -ruleOrderingWithId bs r1 r2 = - let xs = map getId bs in - case (findIndex (==getId r1) xs, findIndex (==getId r2) xs) of - (Just i, Just j ) -> i `compare` j - (Just _, Nothing) -> LT - (Nothing, Just _ ) -> GT - (Nothing, Nothing) -> compareId r1 r2 - ---------------------------------------------------------------- --- Exercise status - -data Status - = Stable -- ^ A released exercise that has undergone some thorough testing - | Provisional -- ^ A released exercise, possibly with some deficiencies - | Alpha -- ^ An exercise that is under development - | Experimental -- ^ An exercise for experimentation purposes only - deriving (Show, Eq) - --- | An exercise with the status @Stable@ or @Provisional@ -isPublic :: Exercise a -> Bool -isPublic ex = status ex `elem` [Stable, Provisional] - --- | An exercise that is not public -isPrivate :: Exercise a -> Bool -isPrivate = not . isPublic - ---------------------------------------------------------------- --- Rest - -equivalenceContext :: Exercise a -> Context a -> Context a -> Bool -equivalenceContext ex a b = - case eqWithContext ex of - Just f -> f a b - Nothing -> fromMaybe False $ - liftM2 (equivalence ex) (fromContext a) (fromContext b) - -prettyPrinterContext :: Exercise a -> Context a -> String -prettyPrinterContext ex = - maybe "<>" (prettyPrinter ex) . fromContext - -getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a)) -getRule ex a = - case filter ((a ==) . getId) (ruleset ex) of - [hd] -> return hd - [] -> fail $ "Could not find ruleid " ++ showId a - _ -> fail $ "Ambiguous ruleid " ++ showId a - --- |Shows a derivation for a given start term. The specified rule ordering --- is used for selection. -showDerivation :: Exercise a -> a -> String -showDerivation ex a = show (present der) ++ extra - where - der = derivationDiffEnv (defaultDerivation ex a) - extra = - case fromContext (last (terms der)) of - Nothing -> "<>" - Just b | isReady ex b -> "" - | otherwise -> "<>" - present = mapStepsDerivation (ShowString . uncurry f) - . fmap (ShowString . prettyPrinterContext ex) - f b env | nullEnv env = showId b - | otherwise = showId b ++ "\n " ++ show env - -type ExerciseDerivation a = Derivation (Rule (Context a)) (Context a) - -defaultDerivation :: Exercise a -> a -> ExerciseDerivation a -defaultDerivation ex a = - let ca = inContext ex a - tree = sortTree (ruleOrdering ex) (derivationTree (strategy ex) ca) - single = newDerivation ca [] - in fromMaybe single (derivation tree) - -derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a) -derivationDiffEnv d = - -- A bit of hack to show the delta between two environments, not including - -- the location variable - let t:ts = terms d - xs = zipWith3 f (steps d) (drop 1 (terms d)) (terms d) - f b x y = (b, deleteEnv "location" (diffEnv (getEnvironment x) (getEnvironment y))) -- ShowString (show a ++ extra) - in newDerivation t (zip xs ts) - -printDerivation :: Exercise a -> a -> IO () -printDerivation ex = putStrLn . showDerivation ex - ---------------------------------------------------------------- --- Checks for an exercise -{- -checkExercise :: Exercise a -> IO () -checkExercise ex = do - putStrLn ("** " ++ show (exerciseCode ex)) - -- Derivations for examples - checkExamples ex - -- Derivations for test generator - case testGenerator ex of - Nothing -> return () - Just gen -> do - putStrLn "Checking with test generator" - forM_ [0 .. 100] $ \i -> do - -- putChar '.' - g <- newStdGen - checksForTerm False ex (generate i g gen) - return () - -- Derivations for random exercise generator - case randomExercise ex of - Nothing -> return () - Just f -> do - putStrLn "Checking with random exercise generator" - forM_ [0 .. 109] $ \i -> do - -- putChar '.' - g <- newStdGen - checksForTerm False ex (f g (i `div` 10)) - return () - -- Soundness of rules - case testGenerator ex of - Nothing -> return () - Just gen -> do - putStrLn "Soundness of rules with test generator" - forM_ (filter (not . isBuggyRule) (ruleset ex)) $ \r -> do - putStr ("[" ++ show r ++ "] ") - xs <- generateIO 300 (smartGen r (liftM (inContext ex) gen)) - let list = [ (x, y) | x <- xs, y <- applyAll r x ] - p (x, y) = not (equivalenceContext ex x y) - case filter p list of - [] | null list -> putStrLn "Warning: no applications found" - | otherwise -> putStrLn "Ok" - (x, y):_ -> report $ - "counter example: " ++ prettyPrinterContext ex x - ++ " => " ++ prettyPrinterContext ex y -} - -checkExercise :: Exercise a -> IO () -checkExercise = runTestSuite . exerciseTestSuite - -exerciseTestSuite :: Exercise a -> TestSuite -exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do - checkExamples ex - case testGenerator ex of - Nothing -> return () - Just gen -> do - let showAsGen = showAs (prettyPrinter ex) gen - addProperty "parser/pretty printer" $ forAll showAsGen $ - checkParserPrettyEx ex . from - - suite "Soundness non-buggy rules" $ - forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> - let eq a b = equivalenceContext ex (from a) (from b) - myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) - myView = makeView (return . from) (S (prettyPrinterContext ex)) - args = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100} - in addPropertyWith (showId r) args $ - propRuleSmart eq (liftRule myView r) myGen - - addProperty "soundness strategy/generator" $ - forAll showAsGen $ - maybe False (isReady ex) . fromContext - . applyD (strategy ex) . inContext ex . from - -data ShowAs a = S {showS :: a -> String, from :: a} - -instance Show (ShowAs a) where - show a = showS a (from a) - -showAs :: (a -> String) -> Gen a -> Gen (ShowAs a) -showAs f = liftM (S f) - --- check combination of parser and pretty-printer -checkParserPretty :: (a -> a -> Bool) -> (String -> Either b a) -> (a -> String) -> a -> Bool -checkParserPretty eq p pretty a = - either (const False) (eq a) (p (pretty a)) - -checkParserPrettyEx :: Exercise a -> a -> Bool -checkParserPrettyEx ex = - checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex) - -checkExamples :: Exercise a -> TestSuite -checkExamples ex = do - let xs = examples ex - unless (null xs) $ suite "Examples" $ - mapM_ (checksForTerm True ex) xs - -checksForTerm :: Bool -> Exercise a -> a -> TestSuite -checksForTerm leftMost ex a = do - let tree = derivationTree (strategy ex) (inContext ex a) - -- Left-most derivation - when leftMost $ - case derivation tree of - Just d -> checksForDerivation ex d - Nothing -> - fail $ "no derivation for " ++ prettyPrinter ex a - -- Random derivation - g <- liftIO getStdGen - case randomDerivation g tree of - Just d -> checksForDerivation ex d - Nothing -> return () - -checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> TestSuite -checksForDerivation ex d = do - -- Conditions on starting term - let start = head (terms d) - assertTrueMsg "start term" - ("not suitable: " ++ prettyPrinterContext ex start) $ - maybe False (isSuitable ex) (fromContext start) - - {- - b2 <- do let b = False -- maybe True (isReady ex) (fromContext start) - when b $ report $ - "start term is ready: " ++ prettyPrinterContext ex start - return b-} - -- Conditions on final term - let final = last (terms d) - {- - b3 <- do let b = False -- maybe True (isSuitable ex) (fromContext final) - when b $ report $ - "final term is suitable: " ++ prettyPrinterContext ex start - ++ " => " ++ prettyPrinterContext ex final - return b -} - assertTrueMsg "final term" - ("not ready: " ++ prettyPrinterContext ex start - ++ " => " ++ prettyPrinterContext ex final) $ - maybe False (isReady ex) (fromContext final) - - -- Parser/pretty printer on terms - let ts = terms d - p1 = maybe False (not . checkParserPrettyEx ex) . fromContext - assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd -> - let s = prettyPrinterContext ex hd - in "parse error for " ++ s ++ ": parsed as " - ++ either show (prettyPrinter ex) (parser ex s) - - - -- Equivalences between terms - let pairs = [ (x, y) | x <- ts, y <- ts ] - p2 (x, y) = not (equivalenceContext ex x y) - assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) -> - "not equivalent: " ++ prettyPrinterContext ex x - ++ " with " ++ prettyPrinterContext ex y - - -- Similarity of terms - let p3 (x, _, y) = fromMaybe False $ - liftM2 (similarity ex) (fromContext x) (fromContext y) - assertNull "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) -> - "similar subsequent terms: " ++ prettyPrinterContext ex x - ++ " with " ++ prettyPrinterContext ex y - ++ " using " ++ show r - - let xs = [ x | cx <- terms d, x <- fromContext cx, not (similarity ex x x) ] - assertNull "self similarity" $ take 1 $ flip map xs $ \hd -> - "term not similar to itself: " ++ prettyPrinter ex hd +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines the concept of an exercise +-- +----------------------------------------------------------------------------- +module Common.Exercise + ( -- * Exercises + Exercise, makeExercise, emptyExercise + , exerciseId, status, parser, prettyPrinter + , equivalence, similarity, ready, suitable, isReady, isSuitable + , hasTermView + , strategy, navigation, canBeRestarted, extraRules, ruleOrdering + , difference, differenceEqual + , testGenerator, randomExercise, examples, getRule + , simpleGenerator, useGenerator + , randomTerm, randomTermWith, ruleset + , makeContext, inContext, recognizeRule + , ruleOrderingWith, ruleOrderingWithId + , Examples, mapExamples, Difficulty(..), readDifficulty, level + , hasTypeable, useTypeable, castFrom, castTo + -- * Exercise status + , Status(..), isPublic, isPrivate + -- * Miscellaneous + , withoutContext, simpleSimilarity, simpleEquivalence + , prettyPrinterContext, restrictGenerator + , showDerivation, printDerivation + , ExerciseDerivation, defaultDerivation + , derivationDiffEnv, derivationPrevious + , checkExercise, checkParserPretty + , checkExamples, exerciseTestSuite + ) where + +import Common.Classes +import Common.Context +import Common.Derivation +import Common.DerivationTree +import Common.Id +import Common.Navigator +import Common.Predicate +import Common.Rewriting +import Common.Strategy hiding (not, fail, repeat, replicate) +import Common.Transformation +import Common.Utils (ShowString(..), commaList) +import Common.Utils.TestSuite +import Common.View +import Control.Monad.Error +import Data.Char +import Data.Function +import Data.List +import Data.Maybe +import Data.Ord +import Data.Typeable +import System.Random +import Test.QuickCheck hiding (label) +import Test.QuickCheck.Gen +import qualified Common.Rewriting.Difference as Diff +import qualified Common.Strategy as S + +data Exercise a = Exercise + { -- identification and meta-information + exerciseId :: Id -- identifier that uniquely determines the exercise + , status :: Status + -- parsing and pretty-printing + , parser :: String -> Either String a + , prettyPrinter :: a -> String + -- syntactic and semantic checks + , equivalence :: Context a -> Context a -> Bool + , similarity :: Context a -> Context a -> Bool -- possibly more liberal than syntactic equality + , ready :: Predicate a + , suitable :: Predicate a + , hasTermView :: Maybe (View Term a) + , hasTypeable :: Maybe (IsTypeable a) + -- strategies and rules + , strategy :: LabeledStrategy (Context a) + , navigation :: a -> Navigator a + , canBeRestarted :: Bool -- By default, assumed to be the case + , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy + , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst) + -- testing and exercise generation + , testGenerator :: Maybe (Gen a) + , randomExercise :: Maybe (StdGen -> Difficulty -> a) + , examples :: [(Difficulty, a)] + } + +instance Eq (Exercise a) where + e1 == e2 = getId e1 == getId e2 + +instance Ord (Exercise a) where + compare = comparing getId + +instance Apply Exercise where + applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex + +instance HasId (Exercise a) where + getId = exerciseId + changeId f ex = ex { exerciseId = f (exerciseId ex) } + +makeExercise :: (Show a, Eq a, IsTerm a) => Exercise a +makeExercise = emptyExercise + { prettyPrinter = show + , similarity = (==) + , hasTermView = Just termView + } + +emptyExercise :: Exercise a +emptyExercise = Exercise + { -- identification and meta-information + exerciseId = error "no exercise code" + , status = Experimental + -- parsing and pretty-printing + , parser = const (Left "<>") + , prettyPrinter = const "<>" + -- syntactic and semantic checks + , equivalence = \_ _ -> True + , similarity = \_ _ -> True + , ready = true + , suitable = true + , hasTermView = Nothing + , hasTypeable = Nothing + -- strategies and rules + , strategy = label "Fail" S.fail + , navigation = noNavigator + , canBeRestarted = True + , extraRules = [] + , ruleOrdering = compareId + -- testing and exercise generation + , testGenerator = Nothing + , randomExercise = Nothing + , examples = [] + } + +makeContext :: Exercise a -> Environment -> a -> Context a +makeContext ex env = newContext env . navigation ex + +-- | Put a value into an empty environment +inContext :: Exercise a -> a -> Context a +inContext = flip makeContext emptyEnv + +--------------------------------------------------------------- +-- Difficulty levels + +type Examples a = [(Difficulty, a)] + +mapExamples :: (a -> b) -> Examples a -> Examples b +mapExamples f = map (second f) + +data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult + deriving (Eq, Ord, Enum) + +instance Show Difficulty where + show = (xs !!) . fromEnum + where + xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"] + +readDifficulty :: String -> Maybe Difficulty +readDifficulty s = + case filter p [VeryEasy .. VeryDifficult] of + [a] -> Just a + _ -> Nothing + where + normal = filter isAlpha . map toLower + p = (== normal s) . normal . show + +level :: Difficulty -> [a] -> Examples a +level = zip . repeat + +--------------------------------------------------------------- +-- Exercise generators + +-- returns a sorted list of rules (no duplicates) +ruleset :: Exercise a -> [Rule (Context a)] +ruleset ex = nub (sortBy compareId list) + where + list = extraRules ex ++ rulesInStrategy (strategy ex) + +simpleGenerator :: Gen a -> Maybe (StdGen -> Difficulty -> a) +simpleGenerator = useGenerator (const True) . const + +useGenerator :: (a -> Bool) -> (Difficulty -> Gen a) -> Maybe (StdGen -> Difficulty -> a) +useGenerator p makeGen = Just (\rng -> rec rng . makeGen) + where + rec rng gen@(MkGen f) + | p a = a + | otherwise = rec (snd (next rng)) gen + where + (size, r) = randomR (0, 100) rng + a = f r size + +restrictGenerator :: (a -> Bool) -> Gen a -> Gen a +restrictGenerator p g = do + a <- g + if p a then return a + else restrictGenerator p g + +randomTerm :: Difficulty -> Exercise a -> IO a +randomTerm dif ex = do + rng <- newStdGen + return (randomTermWith rng dif ex) + +randomTermWith :: StdGen -> Difficulty -> Exercise a -> a +randomTermWith rng dif ex = + case randomExercise ex of + Just f -> f rng dif + Nothing + | null xs -> error "randomTermWith: no generator" + | otherwise -> + snd (xs !! fst (randomR (0, length xs - 1) rng)) + where xs = examples ex + +difference :: Exercise a -> a -> a -> Maybe (a, a) +difference ex a b = do + v <- hasTermView ex + Diff.differenceWith v a b + +differenceEqual :: Exercise a -> a -> a -> Maybe (a, a) +differenceEqual ex a b = do + v <- hasTermView ex + Diff.differenceEqualWith v (simpleEquivalence ex) a b + +-- Recognize a rule at (possibly multiple) locations +recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, ArgValues)] +recognizeRule ex r ca cb = rec (fromMaybe ca (top ca)) + where + rec x = + let here = case ruleRecognizer (similarity ex) r x cb of + Just as -> [(location x, as)] + Nothing -> [] + in here ++ concatMap rec (allDowns x) + +ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering +ruleOrderingWith = ruleOrderingWithId . map getId + +ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering +ruleOrderingWithId bs r1 r2 = + let xs = map getId bs in + case (findIndex (==getId r1) xs, findIndex (==getId r2) xs) of + (Just i, Just j ) -> i `compare` j + (Just _, Nothing) -> LT + (Nothing, Just _ ) -> GT + (Nothing, Nothing) -> compareId r1 r2 + +--------------------------------------------------------------- +-- Using type representations for casts + +data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b) + (forall b . Typeable b => b -> Maybe a) + +useTypeable :: Typeable a => Maybe (IsTypeable a) +useTypeable = Just (IT cast cast) + +castFrom :: Typeable b => Exercise a -> a -> Maybe b +castFrom ex a = do + IT f _ <- hasTypeable ex + f a + +castTo :: Typeable b => Exercise a -> b -> Maybe a +castTo ex a = do + IT _ g <- hasTypeable ex + g a + +--------------------------------------------------------------- +-- Exercise status + +data Status + = Stable -- ^ A released exercise that has undergone some thorough testing + | Provisional -- ^ A released exercise, possibly with some deficiencies + | Alpha -- ^ An exercise that is under development + | Experimental -- ^ An exercise for experimentation purposes only + deriving (Show, Eq) + +-- | An exercise with the status @Stable@ or @Provisional@ +isPublic :: Exercise a -> Bool +isPublic ex = status ex `elem` [Stable, Provisional] + +-- | An exercise that is not public +isPrivate :: Exercise a -> Bool +isPrivate = not . isPublic + +--------------------------------------------------------------- +-- Rest + +-- | Function for defining equivalence or similarity without taking +-- the context into account. +withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool +withoutContext f a b = fromMaybe False (fromContextWith2 f a b) + +isReady :: Exercise a -> a -> Bool +isReady = evalPredicate . ready + +isSuitable :: Exercise a -> a -> Bool +isSuitable = evalPredicate . suitable + +-- | Similarity on terms without a context +simpleSimilarity :: Exercise a -> a -> a -> Bool +simpleSimilarity ex = similarity ex `on` inContext ex + +-- | Equivalence on terms without a context +simpleEquivalence :: Exercise a -> a -> a -> Bool +simpleEquivalence ex = equivalence ex `on` inContext ex + +prettyPrinterContext :: Exercise a -> Context a -> String +prettyPrinterContext ex = + maybe "<>" (prettyPrinter ex) . fromContext + +getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a)) +getRule ex a = + case filter ((a ==) . getId) (ruleset ex) of + [hd] -> return hd + [] -> fail $ "Could not find ruleid " ++ showId a + _ -> fail $ "Ambiguous ruleid " ++ showId a + +-- |Shows a derivation for a given start term. The specified rule ordering +-- is used for selection. +showDerivation :: Exercise a -> a -> String +showDerivation ex a = show (present der) ++ extra + where + der = derivationPrevious (derivationDiffEnv (defaultDerivation ex a)) + extra = + case fromContext (lastTerm der) of + Nothing -> "<>" + Just b | isReady ex b -> "" + | otherwise -> "<>" + present = biMap (ShowString . f) (ShowString . prettyPrinterContext ex) + f ((b, env), old) = showId b ++ part1 ++ part2 + where + newl = "\n " + g (ArgValue descr x) = labelArgument descr ++ "=" ++ showArgument descr x + part1 = case expectedArguments b old of + Just xs -> newl ++ commaList (map g xs) + Nothing -> "" + part2 | nullEnv env = "" + | otherwise = newl ++ show env + +type ExerciseDerivation a = Derivation (Rule (Context a)) (Context a) + +defaultDerivation :: Exercise a -> a -> ExerciseDerivation a +defaultDerivation ex a = + let ca = inContext ex a + tree = sortTree (ruleOrdering ex) (derivationTree (strategy ex) ca) + single = emptyDerivation ca + in fromMaybe single (derivation tree) + +derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a) +derivationDiffEnv = updateSteps $ \y b x -> + let env = diffEnv (getEnvironment x) (getEnvironment y) + in (b, deleteEnv "location" env) + +-- helper, needed for showing arguments +derivationPrevious :: Derivation s a -> Derivation (s, a) a +derivationPrevious = updateSteps $ \a s _ -> (s, a) + +printDerivation :: Exercise a -> a -> IO () +printDerivation ex = putStrLn . showDerivation ex + +--------------------------------------------------------------- +-- Checks for an exercise + +checkExercise :: Exercise a -> IO () +checkExercise = runTestSuite . exerciseTestSuite + +exerciseTestSuite :: Exercise a -> TestSuite +exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do + -- get some exercises + xs <- if isJust (randomExercise ex) + then liftIO $ replicateM 10 (randomTerm Medium ex) + else return (map snd (examples ex)) + -- do tests + assertTrue "Exercise terms defined" (not (null xs)) + assertTrue "Equivalence implemented" $ + let eq a b = equivalence ex (inContext ex a) (inContext ex b) + in length (nubBy eq xs) > 1 + assertTrue "Similarity implemented" $ + let sim a b = similarity ex (inContext ex a) (inContext ex b) + in length (nubBy sim xs) > 1 + checkExamples ex + case testGenerator ex of + Nothing -> return () + Just gen -> do + let showAsGen = showAs (prettyPrinter ex) gen + addProperty "parser/pretty printer" $ forAll showAsGen $ + checkParserPrettyEx ex . inContext ex . fromS + + suite "Soundness non-buggy rules" $ + forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> + let eq a b = equivalence ex (fromS a) (fromS b) + myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) + myView = makeView (return . fromS) (S (prettyPrinterContext ex)) + args = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100} + in addPropertyWith (showId r) args $ + propRuleSmart eq (liftRule myView r) myGen + + addProperty "soundness strategy/generator" $ + forAll showAsGen $ + maybe False (isReady ex) . fromContext + . applyD (strategy ex) . inContext ex . fromS + +data ShowAs a = S {showS :: a -> String, fromS :: a} + +instance Show (ShowAs a) where + show a = showS a (fromS a) + +showAs :: (a -> String) -> Gen a -> Gen (ShowAs a) +showAs f = liftM (S f) + +-- check combination of parser and pretty-printer +checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool +checkParserPretty eq p pretty a = + either (const False) (eq a) (p (pretty a)) + +checkParserPrettyEx :: Exercise a -> Context a -> Bool +checkParserPrettyEx ex ca = + let f = mapSecond make . parser ex + make = newContext (getEnvironment ca) . navigation ex + in checkParserPretty (similarity ex) f (prettyPrinterContext ex) ca + +checkExamples :: Exercise a -> TestSuite +checkExamples ex = do + let xs = map snd (examples ex) + unless (null xs) $ suite "Examples" $ + mapM_ (checksForTerm True ex) xs + +checksForTerm :: Bool -> Exercise a -> a -> TestSuite +checksForTerm leftMost ex a = do + let tree = derivationTree (strategy ex) (inContext ex a) + -- Left-most derivation + when leftMost $ + case derivation tree of + Just d -> checksForDerivation ex d + Nothing -> + fail $ "no derivation for " ++ prettyPrinter ex a + -- Random derivation + g <- liftIO getStdGen + case randomDerivation g tree of + Just d -> checksForDerivation ex d + Nothing -> return () + +checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> TestSuite +checksForDerivation ex d = do + -- Conditions on starting term + let start = firstTerm d + assertTrue + ("start term not suitable: " ++ prettyPrinterContext ex start) $ + maybe False (isSuitable ex) (fromContext start) + + {- + b2 <- do let b = False -- maybe True (isReady ex) (fromContext start) + when b $ report $ + "start term is ready: " ++ prettyPrinterContext ex start + return b-} + -- Conditions on final term + let final = lastTerm d + {- + b3 <- do let b = False -- maybe True (isSuitable ex) (fromContext final) + when b $ report $ + "final term is suitable: " ++ prettyPrinterContext ex start + ++ " => " ++ prettyPrinterContext ex final + return b -} + assertTrue + ("final term not ready: " ++ prettyPrinterContext ex start + ++ " => " ++ prettyPrinterContext ex final) $ + maybe False (isReady ex) (fromContext final) + + -- Parser/pretty printer on terms + let ts = terms d + p1 = not . checkParserPrettyEx ex + assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd -> + let s = prettyPrinterContext ex hd + in "parse error for " ++ s ++ ": parsed as " + ++ either show (prettyPrinter ex) (parser ex s) + + -- Equivalences between terms + let pairs = [ (x, y) | x <- ts, y <- ts ] + p2 (x, y) = not (equivalence ex x y) + assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) -> + "not equivalent: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + + -- Similarity of terms + let p3 (x, r, y) = not (isFinalRule r) && similarity ex x y + assertNull "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) -> + "similar subsequent terms: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + ++ " using " ++ show r + + let xs = [ x | x <- terms d, not (similarity ex x x) ] + assertNull "self similarity" $ take 1 $ flip map xs $ \hd -> + "term not similar to itself: " ++ prettyPrinterContext ex hd diff --git a/src/Common/Id.hs b/src/Common/Id.hs --- a/src/Common/Id.hs +++ b/src/Common/Id.hs @@ -1,163 +1,184 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Identification of entities --- ------------------------------------------------------------------------------ -module Common.Id - ( Id, IsId(..), HasId(..), ( # ), sameId - , unqualified, qualifiers, qualification - , describe, description, showId, compareId - ) where - -import Data.Char -import Data.List -import Data.Monoid -import Data.Ord -import Common.StringRef -import Common.Utils (splitsWithElem) - ---------------------------------------------------------------------- --- Abstract data type and its instances - -data Id = Id - { idList :: [String] - , idDescription :: String - , idRef :: !StringRef - } - -instance Show Id where - show = concat . intersperse "." . idList - -instance Eq Id where - a == b = idRef a == idRef b - -instance Ord Id where - compare = comparing idRef - -instance Monoid Id where - mempty = stringId "" - mappend = ( # ) - ---------------------------------------------------------------------- --- Type class for constructing identifiers - -class IsId a where - newId :: a -> Id - concatId :: [a] -> Id -- for String instance - -- default definition - concatId = mconcat . map newId - -instance IsId Id where - newId = id - -instance IsId Char where - newId c = stringId [c] - concatId = stringId - -instance IsId a => IsId [a] where - newId = concatId - concatId = mconcat . map newId - -instance IsId () where - newId = const mempty - -instance (IsId a, IsId b) => IsId (a, b) where - newId (a, b) = newId a # newId b - -instance (IsId a, IsId b, IsId c) => IsId (a, b, c) where - newId (a, b, c) = newId a # newId b # newId c - -instance IsId a => IsId (Maybe a) where - newId = maybe mempty newId - -instance (IsId a, IsId b) => IsId (Either a b) where - newId = either newId newId - ------------------------------------------------------ --- Type class for structures containing an identifier - -class HasId a where - getId :: a -> Id - changeId :: (Id -> Id) -> a -> a - -instance HasId Id where - getId = id - changeId = id - -instance (HasId a, HasId b) => HasId (Either a b) where - getId = either getId getId - changeId f = either (Left . changeId f) (Right . changeId f) - ---------------------------------------------------------------------- --- Private constructors - -appendId :: Id -> Id -> Id -appendId a b - | null (idList a) = b - | null (idList b) = a - | otherwise = Id (idList a ++ idList b) "" ref - where - ref = stringRef (show a ++ "." ++ show b) - --- Only allow alphanum and '-' ('.' has a special meaning) -stringId :: String -> Id -stringId txt = Id (make s) "" (stringRef s) - where - s = norm txt - make = filter (not . null) . splitsWithElem '.' - norm = filter ok . map toLower - ok c = isAlphaNum c || c `elem` ".-_" - ---------------------------------------------------------------------- --- Additional functionality (overloaded) - -infixr 8 # - -( # ) :: (IsId a, IsId b) => a -> b -> Id -a # b = appendId (newId a) (newId b) - -sameId :: (IsId a, IsId b) => a -> b -> Bool -sameId a b = newId a == newId b - -unqualified :: HasId a => a -> String -unqualified a - | null xs = "" - | otherwise = last xs - where - xs = idList (getId a) - -qualifiers :: HasId a => a -> [String] -qualifiers a - | null xs = [] - | otherwise = init xs - where - xs = idList (getId a) - -qualification :: HasId a => a -> String -qualification = concat . intersperse "." . qualifiers - -description :: HasId a => a -> String -description = idDescription . getId - -showId :: HasId a => a -> String -showId = show . getId - -compareId :: HasId a => a -> a -> Ordering -compareId = comparing showId - -describe :: HasId a => String -> a -> a -describe = changeId . describeId - where - describeId s a - | null (idDescription a) = - a {idDescription = s} - | otherwise = +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Identification of entities +-- +----------------------------------------------------------------------------- +module Common.Id + ( Id, IsId(..), HasId(..), Identify(..), ( # ), sameId + , unqualified, qualifiers, qualification + , describe, description, showId, compareId + , mempty, isEmptyId + ) where + +import Common.Classes +import Common.Utils (splitsWithElem) +import Common.Utils.StringRef +import Control.Monad +import Data.Char +import Data.List +import Data.Monoid +import Data.Ord +import Test.QuickCheck + +--------------------------------------------------------------------- +-- Abstract data type and its instances + +data Id = Id + { idList :: [String] + , idDescription :: String + , idRef :: !StringRef + } + +instance Show Id where + show = intercalate "." . idList + +instance Eq Id where + a == b = idRef a == idRef b + +instance Ord Id where + compare = comparing idRef + +instance Monoid Id where + mempty = emptyId + mappend = ( # ) + +instance Arbitrary Id where + arbitrary = frequency + [ (4, do n <- choose (0, 8) + xs <- replicateM n (elements ['a' .. 'z']) + return $ newId xs) + , (1, liftM2 mappend arbitrary arbitrary) + ] + +--------------------------------------------------------------------- +-- Type class for constructing identifiers + +class IsId a where + newId :: a -> Id + concatId :: [a] -> Id -- for String instance + -- default definition + concatId = mconcat . map newId + +instance IsId Id where + newId = id + +instance IsId Char where + newId c = stringId [c] + concatId = stringId + +instance IsId a => IsId [a] where + newId = concatId + concatId = mconcat . map newId + +instance IsId () where + newId = const emptyId + +instance (IsId a, IsId b) => IsId (a, b) where + newId (a, b) = newId a # newId b + +instance (IsId a, IsId b, IsId c) => IsId (a, b, c) where + newId (a, b, c) = newId a # newId b # newId c + +instance IsId a => IsId (Maybe a) where + newId = maybe emptyId newId + +instance (IsId a, IsId b) => IsId (Either a b) where + newId = either newId newId + +----------------------------------------------------- +-- Type class for structures containing an identifier + +class HasId a where + getId :: a -> Id + changeId :: (Id -> Id) -> a -> a + +instance HasId Id where + getId = id + changeId = id + +instance (HasId a, HasId b) => HasId (Either a b) where + getId = either getId getId + changeId f = biMap (changeId f) (changeId f) + +class HasId a => Identify a where + (@>) :: IsId n => n -> a -> a + +--------------------------------------------------------------------- +-- Private constructors + +appendId :: Id -> Id -> Id +appendId a b + | null (idList a) = b + | null (idList b) = a + | otherwise = Id (idList a ++ idList b) "" ref + where + ref = stringRef (show a ++ "." ++ show b) + +-- Only allow alphanum and '-' ('.' has a special meaning) +stringId :: String -> Id +stringId txt = Id (make s) "" (stringRef s) + where + s = norm txt + make = filter (not . null) . splitsWithElem '.' + norm = filter ok . map toLower + ok c = isAlphaNum c || c `elem` ".-_" + +emptyId :: Id +emptyId = Id [] "" (stringRef "") + +--------------------------------------------------------------------- +-- Additional functionality (overloaded) + +infixr 8 # + +( # ) :: (IsId a, IsId b) => a -> b -> Id +a # b = appendId (newId a) (newId b) + +sameId :: (IsId a, IsId b) => a -> b -> Bool +sameId a b = newId a == newId b + +unqualified :: HasId a => a -> String +unqualified a + | null xs = "" + | otherwise = last xs + where + xs = idList (getId a) + +qualifiers :: HasId a => a -> [String] +qualifiers a + | null xs = [] + | otherwise = init xs + where + xs = idList (getId a) + +qualification :: HasId a => a -> String +qualification = intercalate "." . qualifiers + +description :: HasId a => a -> String +description = idDescription . getId + +showId :: HasId a => a -> String +showId = show . getId + +compareId :: HasId a => a -> a -> Ordering +compareId = comparing showId + +isEmptyId :: Id -> Bool +isEmptyId = (== emptyId) + +describe :: HasId a => String -> a -> a +describe = changeId . describeId + where + describeId s a + | null (idDescription a) = + a {idDescription = s} + | otherwise = a {idDescription = s ++ " " ++ idDescription a} diff --git a/src/Common/Library.hs b/src/Common/Library.hs --- a/src/Common/Library.hs +++ b/src/Common/Library.hs @@ -1,54 +1,56 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Exports most from package Common --- ------------------------------------------------------------------------------ -module Common.Library - ( module Common.Classes, module Common.Transformation - , module Common.Context, module Common.Navigator - , module Common.Derivation - , module Common.Rewriting, module Common.Exercise - , module Common.Strategy, module Common.View - , failS, notS, repeatS, replicateS, sequenceS - ) where - -import Common.Classes -import Common.Context -import Common.Derivation -import Common.Exercise -import Common.Navigator hiding (left, right) -import Common.Rewriting hiding (difference) -import Common.Strategy hiding (fail, not, repeat, replicate, sequence) -import Common.Transformation -import Common.View - -import qualified Common.Strategy as S -import Prelude (Int) - --- | Alias for strategy combinator @fail@ -failS :: Strategy a -failS = S.fail - --- | Alias for strategy combinator @not@ -notS :: IsStrategy f => f a -> Strategy a -notS = S.not - --- | Alias for strategy combinator @repeat@ -repeatS :: IsStrategy f => f a -> Strategy a -repeatS = S.repeat - --- | Alias for strategy combinator @replicate@ -replicateS :: IsStrategy f => Int -> f a -> Strategy a -replicateS = S.replicate - --- | Alias for strategy combinator @sequence@ -sequenceS :: IsStrategy f => [f a] -> Strategy a -sequenceS = S.sequence +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exports most from package Common +-- +----------------------------------------------------------------------------- +module Common.Library + ( module Export + , failS, notS, repeatS, replicateS, sequenceS, untilS + ) where + +import Common.Classes as Export +import Common.Context as Export +import Common.Derivation as Export +import Common.DerivationTree as Export +import Common.Exercise as Export +import Common.Id as Export +import Common.Navigator as Export hiding (left, right) +import Common.Predicate as Export +import Common.Rewriting as Export +import Common.Strategy as Export hiding (fail, not, repeat, replicate, sequence, until) +import Common.Transformation as Export +import Common.View as Export + +import qualified Common.Strategy as S + +-- | Alias for strategy combinator @fail@ +failS :: Strategy a +failS = S.fail + +-- | Alias for strategy combinator @not@ +notS :: IsStrategy f => f a -> Strategy a +notS = S.not + +-- | Alias for strategy combinator @repeat@ +repeatS :: IsStrategy f => f a -> Strategy a +repeatS = S.repeat + +-- | Alias for strategy combinator @replicate@ +replicateS :: IsStrategy f => Int -> f a -> Strategy a +replicateS = S.replicate + +-- | Alias for strategy combinator @sequence@ +sequenceS :: IsStrategy f => [f a] -> Strategy a +sequenceS = S.sequence + +-- | Alias for strategy combinator @until@ +untilS :: IsStrategy f => (a -> Bool) -> f a -> Strategy a +untilS = S.until diff --git a/src/Common/Navigator.hs b/src/Common/Navigator.hs --- a/src/Common/Navigator.hs +++ b/src/Common/Navigator.hs @@ -1,277 +1,272 @@ -{-# LANGUAGE ExistentialQuantification #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines a type class for navigating an expression. --- ------------------------------------------------------------------------------ -module Common.Navigator - ( -- * Type classes for navigating expressions - IsNavigator(..), TypedNavigator(..) - -- * Types and constructors - , Navigator, Location - , navigator, noNavigator, viewNavigator, viewNavigatorWith - -- * Derived navigations - , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo - , navigateTowards, top, leafs, downFirst, downLast, left, right - , replaceT - ) where - -import Common.Uniplate hiding (leafs) -import Common.View hiding (left, right) -import Control.Monad -import Data.Maybe -import Data.Typeable - ---------------------------------------------------------------- --- Type class for navigating expressions - -type Location = [Int] - --- | For a minimal complete definition, provide an implemention for downs or --- allDowns. All other functions need an implementation as well, except for --- change. Note that a constructor (a -> f a) is not included in the type class --- to allow additional type class constraints on type a. -class IsNavigator f where - -- navigation - up :: Monad m => f a -> m (f a) - down :: Monad m => Int -> f a -> m (f a) - allDowns :: f a -> [f a] - -- inspection - current :: Monad m => f a -> m a - location :: f a -> Location - -- adaption - change :: (a -> a) -> f a -> f a - changeM :: Monad m => (a -> m a) -> f a -> m (f a) - -- default definitions - down n a = - case drop n (allDowns a) of - [] -> fail ("down " ++ show n) - hd:_ -> return hd - allDowns a = - [ fa | i <- [0 .. arity a-1], fa <- down i a ] - change f a = - fromMaybe a (changeM (Just . f) a) - -class IsNavigator f => TypedNavigator f where - changeT :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a) - currentT :: (Monad m, Typeable b) => f a -> m b - leaveT :: (Monad m, Typeable b) => f a -> m b - castT :: (Monad m, Typeable e) => View e b -> f a -> m (f b) - -- By default, fail - changeT _ _ = fail "changeT: not defined" - currentT _ = fail "currentT: not defined" - leaveT _ = fail "leaveT: not defined" - castT _ _ = fail "castT: not defined" - ---------------------------------------------------------------- --- Derived navigations - -leave :: (IsNavigator f, Monad m) => f a -> m a -leave a = maybe (current a) leave (up a) - -replace :: IsNavigator f => a -> f a -> f a -replace = change . const - -arity :: IsNavigator f => f a -> Int -arity = length . allDowns - -isTop :: IsNavigator f => f a -> Bool -isTop = isNothing . up - -isLeaf :: IsNavigator f => f a -> Bool -isLeaf = null . allDowns - -ups :: (IsNavigator f, Monad m) => Int -> f a -> m (f a) -ups n a = foldM (const . up) a [1..n] - -downs :: (IsNavigator f, Monad m) => [Int] -> f a -> m (f a) -downs is a = foldM (flip down) a is - -navigateTo :: (IsNavigator f, Monad m) => Location -> f a -> m (f a) -navigateTo is a = ups (length js - n) a >>= downs (drop n is) - where - js = location a - n = length (takeWhile id (zipWith (==) is js)) - -navigateTowards :: IsNavigator f => Location -> f a -> f a -navigateTowards is a = - case ups (length js - n) a of - Just b -> safeDowns (drop n is) b - Nothing -> a - where - js = location a - n = length (takeWhile id (zipWith (==) is js)) - - safeDowns [] b = b - safeDowns (m:ms) b = maybe b (safeDowns ms) (down m b) - -top :: (IsNavigator f, Monad m) => f a -> m (f a) -top = navigateTo [] - -leafs :: IsNavigator f => f a -> [f a] -leafs a - | isLeaf a = [a] - | otherwise = concatMap leafs (allDowns a) - -downFirst :: (IsNavigator f, Monad m) => f a -> m (f a) -downFirst = down 0 - -downLast :: (IsNavigator f, Monad m) => f a -> m (f a) -downLast a = down (arity a - 1) a - -left :: (IsNavigator f, Monad m) => f a -> m (f a) -left a0 = rec a0 - where - rec a - | isTop a = downFirst a0 - | i == 0 = up a >>= rec - | otherwise = up a >>= down (i-1) - where - i = last (location a) - -right :: (IsNavigator f, Monad m) => f a -> m (f a) -right a0 = rec a0 - where - rec a - | isTop a = downLast a0 - | otherwise = do - p <- up a - let n = arity p - if i >= n-1 then rec p else down (i+1) p - where - i = last (location a) - ---------------------------------------------------------------- --- Instance based on Uniplate - --- The uniplate function is stored in the data type to get rid of the --- Uniplate type class constraints in the member functions of the --- Navigator type class. -data UniplateNav a = UN (HolesType a) [(Int, a -> a)] a - -type HolesType a = a -> [(a, a -> a)] - -makeUN :: HolesType a -> a -> UniplateNav a -makeUN f = UN f [] - -instance Show a => Show (UniplateNav a) where - show = showNav - -instance IsNavigator UniplateNav where - up (UN _ [] _) = fail "up" - up (UN uni ((_, f):xs) a) = return (UN uni xs (f a)) - - allDowns (UN uni xs a) = - let make i (b, f) = UN uni ((i, f):xs) b - in zipWith make [0..] (uni a) - - location (UN _ xs _) = reverse (map fst xs) - - changeM f (UN uni xs a) = liftM (UN uni xs) (f a) - current (UN _ _ a) = return a - -showNav :: (IsNavigator f, Show a) => f a -> String -showNav a = maybe "???" show (leave a) ++ " { " - ++ maybe "???" show (current a) - ++ " @ " ++ show (location a) ++ " }" - ---------------------------------------------------------------- --- Instance based on a View - -data ViewNav a b = VN (View a b) (UniplateNav a) - -instance Show a => Show (ViewNav a b) where - show (VN _ a) = show a - -instance IsNavigator (ViewNav a) where - up (VN v a) = liftM (VN v) (up a) - allDowns (VN v a) = liftM (VN v) (allDowns a) - location (VN _ a) = location a - current (VN v a) = current a >>= matchM v - changeM f (VN v a) = - let g b = matchM v b >>= (liftM (build v) . f) - in liftM (VN v) (changeM g a) - -instance Typeable a => TypedNavigator (ViewNav a) where - changeT f (VN v a) = do - new <- current a >>= castM >>= f >>= castM - return (VN v (replace new a)) - currentT (VN _ a) = - current a >>= castM - leaveT (VN _ a) = - leave a >>= castM - castT v (VN v0 a) - | tp1 == tp2 = return (VN (castView v) a) - | otherwise = fail $ "castT: " ++ show tp1 ++ " and " ++ show tp2 - where - tp1 = typeOf (getTp v) - tp2 = typeOf (getTp v0) - - getTp :: View a b -> a - getTp = error "castT: getTp" - -replaceT :: (Monad m, TypedNavigator f, Typeable b) => b -> f a -> m (f a) -replaceT = changeT . const . return - -castM :: (Monad m, Typeable a, Typeable b) => a -> m b -castM = maybe (fail "castM") return . cast - -castView :: (Typeable c, Typeable a) => View a b -> View c b -castView v = makeView f g - where - f e = castM e >>= matchM v - g = fromMaybe (error "castT: build") . castM . build v - ---------------------------------------------------------------- --- Uniform navigator type - -instance Show a => Show (Navigator a) where - show = showNav - -data Navigator a = forall f . TypedNavigator f => N (f a) -data Simple a = forall f . IsNavigator f => S (f a) - -instance IsNavigator Navigator where - up (N a) = liftM N (up a) - allDowns (N a) = map N (allDowns a) - current (N a) = current a - location (N a) = location a - changeM f (N a) = liftM N (changeM f a) - -instance TypedNavigator Navigator where - changeT f (N a) = liftM N (changeT f a) - currentT (N a) = currentT a - leaveT (N a) = leaveT a - castT v (N a) = liftM N (castT v a) - -instance IsNavigator Simple where - up (S a) = liftM S (up a) - allDowns (S a) = map S (allDowns a) - current (S a) = current a - location (S a) = location a - changeM f (S a) = liftM S (changeM f a) - -instance TypedNavigator Simple - ---------------------------------------------------------------- --- Constructors - -navigator :: Uniplate a => a -> Navigator a -navigator = N . S . makeUN holes - -noNavigator :: a -> Navigator a -noNavigator = N . S . UN (const []) [] - -viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a -viewNavigator = viewNavigatorWith holes - -viewNavigatorWith :: Typeable a => HolesType a -> a -> Navigator a +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines a type class for navigating an expression. +-- +----------------------------------------------------------------------------- +module Common.Navigator + ( -- * Type classes for navigating expressions + IsNavigator(..), TypedNavigator(..) + -- * Types and constructors + , Navigator, Location + , navigator, noNavigator, viewNavigator, viewNavigatorWith + -- * Derived navigations + , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo + , navigateTowards, top, downFirst, downLast, left, right + , replaceT + ) where + +import Common.Utils.Uniplate +import Common.View hiding (left, right) +import Control.Monad +import Data.Maybe +import Data.Typeable + +--------------------------------------------------------------- +-- Type class for navigating expressions + +type Location = [Int] + +-- | For a minimal complete definition, provide an implemention for downs or +-- allDowns. All other functions need an implementation as well, except for +-- change. Note that a constructor (a -> f a) is not included in the type class +-- to allow additional type class constraints on type a. +class IsNavigator f where + -- navigation + up :: Monad m => f a -> m (f a) + down :: Monad m => Int -> f a -> m (f a) + allDowns :: f a -> [f a] + -- inspection + current :: Monad m => f a -> m a + location :: f a -> Location + -- adaption + change :: (a -> a) -> f a -> f a + changeM :: Monad m => (a -> m a) -> f a -> m (f a) + -- default definitions + down n a = + case drop n (allDowns a) of + [] -> fail ("down " ++ show n) + hd:_ -> return hd + allDowns a = + [ fa | i <- [0 .. arity a-1], fa <- down i a ] + change f a = + fromMaybe a (changeM (Just . f) a) + +class IsNavigator f => TypedNavigator f where + changeT :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a) + currentT :: (Monad m, Typeable b) => f a -> m b + leaveT :: (Monad m, Typeable b) => f a -> m b + castT :: (Monad m, Typeable e) => View e b -> f a -> m (f b) + -- By default, fail + changeT _ _ = fail "changeT: not defined" + currentT _ = fail "currentT: not defined" + leaveT _ = fail "leaveT: not defined" + castT _ _ = fail "castT: not defined" + +--------------------------------------------------------------- +-- Derived navigations + +leave :: (IsNavigator f, Monad m) => f a -> m a +leave a = maybe (current a) leave (up a) + +replace :: IsNavigator f => a -> f a -> f a +replace = change . const + +arity :: IsNavigator f => f a -> Int +arity = length . allDowns + +isTop :: IsNavigator f => f a -> Bool +isTop = isNothing . up + +isLeaf :: IsNavigator f => f a -> Bool +isLeaf = null . allDowns + +ups :: (IsNavigator f, Monad m) => Int -> f a -> m (f a) +ups n a = foldM (const . up) a [1..n] + +downs :: (IsNavigator f, Monad m) => [Int] -> f a -> m (f a) +downs is a = foldM (flip down) a is + +navigateTo :: (IsNavigator f, Monad m) => Location -> f a -> m (f a) +navigateTo is a = ups (length js - n) a >>= downs (drop n is) + where + js = location a + n = length (takeWhile id (zipWith (==) is js)) + +navigateTowards :: IsNavigator f => Location -> f a -> f a +navigateTowards is a = + case ups (length js - n) a of + Just b -> safeDowns (drop n is) b + Nothing -> a + where + js = location a + n = length (takeWhile id (zipWith (==) is js)) + + safeDowns [] b = b + safeDowns (m:ms) b = maybe b (safeDowns ms) (down m b) + +top :: (IsNavigator f, Monad m) => f a -> m (f a) +top = navigateTo [] + +downFirst :: (IsNavigator f, Monad m) => f a -> m (f a) +downFirst = down 0 + +downLast :: (IsNavigator f, Monad m) => f a -> m (f a) +downLast a = down (arity a - 1) a + +left :: (IsNavigator f, Monad m) => f a -> m (f a) +left a0 = rec a0 + where + rec a + | isTop a = downFirst a0 + | i == 0 = up a >>= rec + | otherwise = up a >>= down (i-1) + where + i = last (location a) + +right :: (IsNavigator f, Monad m) => f a -> m (f a) +right a0 = rec a0 + where + rec a + | isTop a = downLast a0 + | otherwise = do + p <- up a + let n = arity p + if i >= n-1 then rec p else down (i+1) p + where + i = last (location a) + +--------------------------------------------------------------- +-- Instance based on Uniplate + +-- The uniplate function is stored in the data type to get rid of the +-- Uniplate type class constraints in the member functions of the +-- Navigator type class. +data UniplateNav a = UN (HolesType a) [(Int, a -> a)] a + +type HolesType a = a -> [(a, a -> a)] + +makeUN :: HolesType a -> a -> UniplateNav a +makeUN f = UN f [] + +instance Show a => Show (UniplateNav a) where + show = showNav + +instance IsNavigator UniplateNav where + up (UN _ [] _) = fail "up" + up (UN uni ((_, f):xs) a) = return (UN uni xs (f a)) + + allDowns (UN uni xs a) = + let make i (b, f) = UN uni ((i, f):xs) b + in zipWith make [0..] (uni a) + + location (UN _ xs _) = reverse (map fst xs) + + changeM f (UN uni xs a) = liftM (UN uni xs) (f a) + current (UN _ _ a) = return a + +showNav :: (IsNavigator f, Show a) => f a -> String +showNav a = maybe "???" show (leave a) ++ " { " + ++ maybe "???" show (current a) + ++ " @ " ++ show (location a) ++ " }" + +--------------------------------------------------------------- +-- Instance based on a View + +data ViewNav a b = VN (View a b) (UniplateNav a) + +instance Show a => Show (ViewNav a b) where + show (VN _ a) = show a + +instance IsNavigator (ViewNav a) where + up (VN v a) = liftM (VN v) (up a) + allDowns (VN v a) = liftM (VN v) (allDowns a) + location (VN _ a) = location a + current (VN v a) = current a >>= matchM v + changeM f (VN v a) = + let g b = matchM v b >>= (liftM (build v) . f) + in liftM (VN v) (changeM g a) + +instance Typeable a => TypedNavigator (ViewNav a) where + changeT f (VN v a) = do + new <- current a >>= castM >>= f >>= castM + return (VN v (replace new a)) + currentT (VN _ a) = + current a >>= castM + leaveT (VN _ a) = + leave a >>= castM + castT v (VN v0 a) + | tp1 == tp2 = return (VN (castView v) a) + | otherwise = fail $ "castT: " ++ show tp1 ++ " and " ++ show tp2 + where + tp1 = typeOf (getTp v) + tp2 = typeOf (getTp v0) + + getTp :: View a b -> a + getTp = error "castT: getTp" + +replaceT :: (Monad m, TypedNavigator f, Typeable b) => b -> f a -> m (f a) +replaceT = changeT . const . return + +castM :: (Monad m, Typeable a, Typeable b) => a -> m b +castM = maybe (fail "castM") return . cast + +castView :: (Typeable c, Typeable a) => View a b -> View c b +castView v = makeView f g + where + f e = castM e >>= matchM v + g = fromMaybe (error "castT: build") . castM . build v + +--------------------------------------------------------------- +-- Uniform navigator type + +instance Show a => Show (Navigator a) where + show = showNav + +data Navigator a = forall f . TypedNavigator f => N (f a) +data Simple a = forall f . IsNavigator f => S (f a) + +instance IsNavigator Navigator where + up (N a) = liftM N (up a) + allDowns (N a) = map N (allDowns a) + current (N a) = current a + location (N a) = location a + changeM f (N a) = liftM N (changeM f a) + +instance TypedNavigator Navigator where + changeT f (N a) = liftM N (changeT f a) + currentT (N a) = currentT a + leaveT (N a) = leaveT a + castT v (N a) = liftM N (castT v a) + +instance IsNavigator Simple where + up (S a) = liftM S (up a) + allDowns (S a) = map S (allDowns a) + current (S a) = current a + location (S a) = location a + changeM f (S a) = liftM S (changeM f a) + +instance TypedNavigator Simple + +--------------------------------------------------------------- +-- Constructors + +navigator :: Uniplate a => a -> Navigator a +navigator = N . S . makeUN holes + +noNavigator :: a -> Navigator a +noNavigator = N . S . UN (const []) [] + +viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a +viewNavigator = viewNavigatorWith holes + +viewNavigatorWith :: Typeable a => HolesType a -> a -> Navigator a viewNavigatorWith f = N . VN identity . makeUN f diff --git a/src/Common/Predicate.hs b/src/Common/Predicate.hs new file mode 100644 --- /dev/null +++ b/src/Common/Predicate.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Representation for predicates +-- +----------------------------------------------------------------------------- +module Common.Predicate + ( -- * Predicate representation + Predicate, predicate, predicateView + , evalPredicate + -- * Exports from Boolean algebra + , BoolValue(..), Boolean(..) + , ands, ors, implies, equivalent + ) where + +import Common.Algebra.Boolean +import Common.Id +import Common.View + +data Predicate a + = Const Bool + | Prim (a -> Bool) + | forall b . PView (View a b) + | Compl (Predicate a) + | Predicate a :&&: Predicate a + | Predicate a :||: Predicate a + | Id :@ Predicate a + +instance BoolValue (Predicate a) where + fromBool = Const + isTrue (Const b) = b + isTrue _ = False + isFalse (Const b) = not b + isFalse _ = False + +instance Boolean (Predicate a) where + Const b <&&> y = if b then y else false + x <&&> Const b = if b then x else false + x <&&> y = x :&&: y + Const b <||> y = if b then true else y + x <||> Const b = if b then true else x + x <||> y = x :||: y + complement (Const b) = Const (not b) + complement x = Compl x + +instance HasId (Predicate a) where + getId (n :@ _) = n + getId (PView v) = getId v + getId _ = mempty + changeId f (n :@ a) = f n :@ a + changeId f a = f mempty :@ a + +instance Identify (Predicate a) where + n @> v | isEmptyId a = v + | otherwise = a :@ v + where + a = newId n + +predicate :: (a -> Bool) -> Predicate a +predicate = Prim + +predicateView :: View a b -> Predicate a +predicateView = PView + +evalPredicate :: Predicate a -> a -> Bool +evalPredicate p a = rec p + where + rec (Const b) = b + rec (Prim f) = f a + rec (PView v) = a `belongsTo` v + rec (Compl x) = not (rec x) + rec (x :&&: y) = rec x && rec y + rec (x :||: y) = rec x || rec y + rec (_ :@ x) = rec x diff --git a/src/Common/Rewriting.hs b/src/Common/Rewriting.hs --- a/src/Common/Rewriting.hs +++ b/src/Common/Rewriting.hs @@ -1,25 +1,18 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting - ( module Common.Rewriting.Term - , module Common.Rewriting.Group - , module Common.Rewriting.Operator - , module Common.Rewriting.Difference - , module Common.Rewriting.RewriteRule - ) where - -import Common.Rewriting.Difference -import Common.Rewriting.Group hiding (identity) -import Common.Rewriting.Operator hiding (unary, binary, isUnary, isBinary) -import Common.Rewriting.RewriteRule -import Common.Rewriting.Term hiding (Term(..)) -import Common.Rewriting.Term (Term) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting + ( module Common.Rewriting.Term + , module Common.Rewriting.RewriteRule + ) where + +import Common.Rewriting.RewriteRule +import Common.Rewriting.Term diff --git a/src/Common/Rewriting/AC.hs b/src/Common/Rewriting/AC.hs --- a/src/Common/Rewriting/AC.hs +++ b/src/Common/Rewriting/AC.hs @@ -1,120 +1,116 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.AC - ( -- * Types - Pairings, PairingsList, PairingsPair - -- * Pairings with operator - , pairings, pairingsMatch - -- * Primitive pairings functions - , pairingsNone, pairingsA - , pairingsC, pairingsAC - ) where - -import Common.View -import Common.Rewriting.Group -import Control.Monad -import Data.Maybe - -type Pairings a = a -> a -> [[(a, a)]] -type PairingsList a b = [a] -> [b] -> [[([a], [b])]] -type PairingsPair a b = (a, a) -> (b, b) -> [[(a, b)]] - ------------------------------------------------------------ --- Pairing terms with an AC theory --- matchMode: the left-hand sides cannot have the operator at top-level - -pairings, pairingsMatch :: IsMagma m => m a -> Pairings a -pairings = pairingsMode False -pairingsMatch = pairingsMode True - -pairingsMode :: IsMagma m => Bool -> m a -> Pairings a -pairingsMode matchMode op = - case (isAssociative op, isCommutative op) of - (True , True ) -> operatorPairings op (pairingsAC matchMode) - (True , False) -> operatorPairings op (pairingsA matchMode) - (False, True ) -> opPairings op pairingsC - (False, False) -> opPairings op pairingsNone - --- non-associative, non-commutative pairings -pairingsNone :: PairingsPair a b -pairingsNone (a1, a2) (b1, b2) = - [[(a1, b1), (a2, b2)]] - --- commutative pairings -pairingsC :: PairingsPair a b -pairingsC (a1, a2) (b1, b2) = - [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]] - --- associative pairings -pairingsA :: Bool -> PairingsList a b -pairingsA matchMode = rec - where - rec [] [] = [[]] - rec as bs = - [ (a1, b1):ps - | i <- if matchMode && not (null as) then [1] else [1 .. length as] - , j <- [1 .. length bs] - , i==1 || j==1 - , let (as1, as2) = splitAt i as - , let (bs1, bs2) = splitAt j bs - , let a1 = as1 - , let b1 = bs1 - , ps <- rec as2 bs2 - ] - --- associative/commutative pairings -pairingsAC :: Bool -> PairingsList a b -pairingsAC matchMode = rec - where - rec [] [] = [[]] - rec [] _ = [] - rec (a:as) bs = - [ (as1, bs1):ps - | (asr, as2) <- if matchMode then [([], as)] else splits as - , let as1 = a:asr - , (bs1, bs2) <- splits bs - , not (null bs1) - , length as1==1 || length bs1==1 - , ps <- rec as2 bs2 - ] - ----------------------------------------------------------- --- Helper functions - -opPairings :: IsMagma m => m a -> PairingsPair a a -> Pairings a -opPairings op f a b = fromMaybe [] $ - liftM2 f (match (magmaView op) a) (match (magmaView op) b) - -operatorPairings :: IsMagma m => m a -> PairingsList a a -> Pairings a -operatorPairings op g = curry $ - let f a = fromMaybe [a] $ match (magmaListView op) a - h = build (magmaListView op) - in map (map (onBoth h)) . uncurry g . onBoth f - -splits :: [a] -> [([a], [a])] -splits = foldr insert [([], [])] - where - insert a ps = - let toLeft (xs, ys) = (a:xs, ys) - toRight (xs, ys) = ( xs, a:ys) - in map toLeft ps ++ map toRight ps - -onBoth :: (a -> b) -> (a, a) -> (b, b) -onBoth f (x, y) = (f x, f y) - -{- -permutations :: [a] -> [[a]] -permutations = foldr (concatMap . insert) [[]] - where - insert a [] = [[a]] - insert a (x:xs) = (a:x:xs) : map (x:) (insert a xs) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.AC + ( -- * Types + Pairings, PairingsList, PairingsPair +-- , pairings, pairingsMatch + -- * Primitive pairings functions + , pairingsNone, pairingsA + , pairingsC, pairingsAC + ) where + +type Pairings a = a -> a -> [[(a, a)]] +type PairingsList a b = [a] -> [b] -> [[([a], [b])]] +type PairingsPair a b = (a, a) -> (b, b) -> [[(a, b)]] + +----------------------------------------------------------- +-- Pairing terms with an AC theory +-- matchMode: the left-hand sides cannot have the operator at top-level + +{- +pairings, pairingsMatch :: IsMagma m => m a -> Pairings a +pairings = pairingsMode False +pairingsMatch = pairingsMode True + +pairingsMode :: IsMagma m => Bool -> m a -> Pairings a +pairingsMode matchMode op = + case (isAssociative op, isCommutative op) of + (True , True ) -> operatorPairings op (pairingsAC matchMode) + (True , False) -> operatorPairings op (pairingsA matchMode) + (False, True ) -> opPairings op pairingsC + (False, False) -> opPairings op pairingsNone +-} + +-- non-associative, non-commutative pairings +pairingsNone :: PairingsPair a b +pairingsNone (a1, a2) (b1, b2) = + [[(a1, b1), (a2, b2)]] + +-- commutative pairings +pairingsC :: PairingsPair a b +pairingsC (a1, a2) (b1, b2) = + [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]] + +-- associative pairings +pairingsA :: Bool -> PairingsList a b +pairingsA matchMode = rec + where + rec [] [] = [[]] + rec as bs = + [ (a1, b1):ps + | i <- if matchMode && not (null as) then [1] else [1 .. length as] + , j <- [1 .. length bs] + , i==1 || j==1 + , let (as1, as2) = splitAt i as + , let (bs1, bs2) = splitAt j bs + , let a1 = as1 + , let b1 = bs1 + , ps <- rec as2 bs2 + ] + +-- associative/commutative pairings +pairingsAC :: Bool -> PairingsList a b +pairingsAC matchMode = rec + where + rec [] [] = [[]] + rec [] _ = [] + rec (a:as) bs = + [ (as1, bs1):ps + | (asr, as2) <- if matchMode then [([], as)] else splits as + , let as1 = a:asr + , (bs1, bs2) <- splits bs + , not (null bs1) + , length as1==1 || length bs1==1 + , ps <- rec as2 bs2 + ] + +---------------------------------------------------------- +-- Helper functions +{- +opPairings :: IsMagma m => m a -> PairingsPair a a -> Pairings a +opPairings op f a b = fromMaybe [] $ + liftM2 f (match (magmaView op) a) (match (magmaView op) b) + +operatorPairings :: IsMagma m => m a -> PairingsList a a -> Pairings a +operatorPairings op g = curry $ + let f a = fromMaybe [a] $ match (magmaListView op) a + h = build (magmaListView op) + in map (map (onBoth h)) . uncurry g . onBoth f +-} +splits :: [a] -> [([a], [a])] +splits = foldr insert [([], [])] + where + insert a ps = + let toLeft (xs, ys) = (a:xs, ys) + toRight (xs, ys) = ( xs, a:ys) + in map toLeft ps ++ map toRight ps + +{- +onBoth :: (a -> b) -> (a, a) -> (b, b) +onBoth f (x, y) = (f x, f y) + +permutations :: [a] -> [[a]] +permutations = foldr (concatMap . insert) [[]] + where + insert a [] = [[a]] + insert a (x:xs) = (a:x:xs) : map (x:) (insert a xs) -} diff --git a/src/Common/Rewriting/Axioms.hs b/src/Common/Rewriting/Axioms.hs deleted file mode 100644 --- a/src/Common/Rewriting/Axioms.hs +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Group axioms specified as rewrite rules (directed). --- ------------------------------------------------------------------------------ -module Common.Rewriting.Axioms - ( -- Semigroup - leftAssociative, rightAssociative, associative - -- Monoid - , leftIdentity, rightIdentity - -- Group - , leftInverse, rightInverse - , inverseIdentity, inverseTwice - , flippedInverseDistribution - , groupAxioms - -- Abelian group - , commutative, inverseDistribution - ) where - -import Common.Id -import Common.Rewriting.Group -import Common.Rewriting.RewriteRule - --- helper -rule :: (IsMagma m, IsId n, RuleBuilder f a, Rewrite a) => m a -> n -> f -> RewriteRule a -rule m s = rewriteRule (getId (toMagma m), s) - -------------------------------------------------------------------- --- * SemiGroup - -leftAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a -leftAssociative m = rule m "associative.left" $ - \x y z -> x.(y.z) :~> (x.y).z - where - (.) = operation m - -rightAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a -rightAssociative m = rule m "associative.right" $ - \x y z -> (x.y).z :~> x.(y.z) - where - (.) = operation m - -associative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a -associative m - | leftIsPreferred m = leftAssociative m - | otherwise = rightAssociative m - -------------------------------------------------------------------- --- * Monoid - -leftIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a -leftIdentity m = rule m "identity.left" $ - \x -> e.x :~> x - where - (.) = operation m - e = identity m - -rightIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a -rightIdentity m = rule m "identity.right" $ - \x -> x.e :~> x - where - (.) = operation m - e = identity m - -------------------------------------------------------------------- --- * Group - -leftInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a -leftInverse m = rule m "inverse.left" $ - \x -> f x.x :~> e - where - (.) = operation m - e = identity m - f = inverse m - -rightInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a -rightInverse m = rule m "inverse.right" $ - \x -> x.f x :~> e - where - (.) = operation m - e = identity m - f = inverse m - -inverseIdentity :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a -inverseIdentity m = rule m "inverse.identity" $ - f e :~> e - where - e = identity m - f = inverse m - -inverseTwice :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a -inverseTwice m = rule m "inverse.twice" $ - \x -> f (f x) :~> x - where - f = inverse m - -flippedInverseDistribution :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a -flippedInverseDistribution m = rule m "inverse.distribution.flipped" $ - \x y -> f (x.y) :~> f y.f x - where - (.) = operation m - f = inverse m - -groupAxioms :: (IsGroup m, Different a, Rewrite a) => m a -> [RewriteRule a] -groupAxioms g = map ($ g) - [ associative, leftIdentity, rightIdentity - , leftInverse, rightInverse - , inverseIdentity, inverseTwice, flippedInverseDistribution - ] ++ extra - where - extra - | leftIsPreferred g = - [ rule g "group1" $ \x y -> (y.x).f x :~> y - , rule g "group2" $ \x y -> (y.f x).x :~> y - ] - | otherwise = - [ rule g "group3" $ \x y -> f x.(x.y) :~> y - , rule g "group4" $ \x y -> x.(f x.y) :~> y - ] - (.) = operation g - f = inverse g - -------------------------------------------------------------------- --- * Abelian Group - --- The type class constraint IsAbelianGroup could be relaxed to --- IsCommutative (or something similar) -commutative :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a -commutative m = rule m "commutative" $ - \x y -> x.y :~> y.x - where - (.) = operation m - -inverseDistribution :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a -inverseDistribution m = rule m "inverse.distribution" $ - \x y -> f (x.y) :~> f x.f y - where - (.) = operation m - f = inverse m diff --git a/src/Common/Rewriting/Confluence.hs b/src/Common/Rewriting/Confluence.hs --- a/src/Common/Rewriting/Confluence.hs +++ b/src/Common/Rewriting/Confluence.hs @@ -1,163 +1,153 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.Confluence - ( isConfluent, checkConfluence, checkConfluenceWith - , somewhereM - , Config, defaultConfig, showTerm, complexity, termEquality - ) where - -import Common.Id -import Common.Navigator -import Common.Rewriting.RewriteRule -import Common.Rewriting.Substitution -import Common.Rewriting.Unification -import Common.Rewriting.Term -import Common.Uniplate hiding (rewriteM) -import Data.Char -import Data.Maybe - -normalForm :: [RewriteRule a] -> Term -> Term -normalForm rs = run [] - where - run hist a = - case [ b | r <- rs, b <- somewhereM (rewriteTerm r) a ] of - [] -> a - hd:_ -> if hd `elem` hist - then error "cyclic" - else run (a:hist) hd - -rewriteTerm :: RewriteRule a -> Term -> [Term] -rewriteTerm r t = do - let lhs :~> rhs = ruleSpecTerm r - sub <- match [] lhs t - return (sub |-> rhs) - --- uniplate-like helper-functions -somewhereM :: Uniplate a => (a -> [a]) -> a -> [a] -somewhereM f = concatMap leave . rec . navigator - where - rec ca = changeM f ca ++ concatMap rec (allDowns ca) - ----------------------------------------------------- - -type Pair a = (RewriteRule a, Term) -type Triple a = (RewriteRule a, Term, Term) - -superImpose :: RewriteRule a -> RewriteRule a -> [Navigator Term] -superImpose r1 r2 = rec (navigator lhs1) - where - lhs1 :~> _ = ruleSpecTerm r1 - lhs2 :~> _ = ruleSpecTerm (renumber r1 r2) - - rec ca = case current ca of - Just (Meta _) -> [] - Just a -> [ subTop s ca | s <- unifyM a lhs2 ] ++ concatMap rec (allDowns ca) - Nothing -> [] - - subTop s ca = fromMaybe ca $ - fmap (change (freeze . (s |->))) (top ca) >>= navigateTo (location ca) - - renumber r = case metaInRewriteRule r of - [] -> id - xs -> renumberRewriteRule (maximum xs + 1) - -criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)] -criticalPairs rs = - [ (freeze a, (r1, freeze b1), (r2, freeze b2)) - | r1 <- rs - , r2 <- rs - , na <- superImpose r1 r2 - , compareId r1 r2 == LT || not (null (location na)) - , a <- leave na - , b1 <- rewriteTerm r1 a - , b2 <- changeM (rewriteTerm r2) na >>= leave - ] - -noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)] -noDiamondPairs cfg rs = noDiamondPairsWith (normalForm rs) cfg rs - -noDiamondPairsWith :: (Term -> Term) -> Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)] -noDiamondPairsWith f cfg rs = - [ (a, (r1, e1, nf1), (r2, e2, nf2)) - | (a, (r1, e1), (r2, e2)) <- criticalPairs rs - , let (nf1, nf2) = (f e1, f e2) - , not (termEquality cfg nf1 nf2) - ] - -reportPairs :: Config -> [(Term, Triple a, Triple a)] -> IO () -reportPairs cfg = putStrLn . unlines . zipWith report [1::Int ..] - where - f = showTerm cfg . unfreeze - report i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines - [ show i ++ ") " ++ f a - , " " ++ showId r1 - , " " ++ f e1 ++ if e1==nf1 then "" else " --> " ++ f nf1 - , " " ++ showId r2 - , " " ++ f e2 ++ if e2==nf2 then "" else " --> " ++ f nf2 - ] - -freeze :: Term -> Term -freeze (Meta n) = Con (newId ('m' : show n)) -freeze term = descend freeze term - -unfreeze :: Term -> Term -unfreeze (Con s) = case showId s of - 'm':is | all isDigit is -> -- && not (null is) -> - Meta (read is) - _ -> Con s -unfreeze term = descend unfreeze term - - ----------------------------------------------------- - -isConfluent :: [RewriteRule a] -> Bool -isConfluent = null . noDiamondPairs defaultConfig - -checkConfluence :: [RewriteRule a] -> IO () -checkConfluence = checkConfluenceWith defaultConfig - -checkConfluenceWith :: Config -> [RewriteRule a] -> IO () -checkConfluenceWith cfg = reportPairs cfg . noDiamondPairs cfg - -data Config = Config - { showTerm :: Term -> String - , complexity :: Term -> Int - , termEquality :: Term -> Term -> Bool - } - -defaultConfig :: Config -defaultConfig = Config show (const 0) (==) - ----------------------------------------------------- --- Example -{- -r1, r2, r3, r4, r5 :: RewriteRule SLogic -r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r -r2 = rewriteRule "R2" $ \p q -> p :||: q :~> q :||: p -r3 = rewriteRule "R3" $ \p -> p :||: p :~> p -r4 = rewriteRule "R4" $ \p -> p :||: T :~> T -r5 = rewriteRule "R5" $ \p -> p :||: F :~> p - -this = [r1, r2, r3, r4, r5, r6] -go = reportPairs $ noDiamondPairs this - -r6 :: RewriteRule SLogic -r6 = rewriteRule "R6" $ \p -> p :||: T :~> F - -r1, r2, r3 :: RewriteRule Expr -r1 = rewriteRule "a1" $ \a -> 0+a :~> a -r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c -r3 = rewriteRule "a2" $ \a -> a+0 :~> a - -go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2] - checkConfluence [r1,r2,r3] +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Confluence + ( isConfluent, checkConfluence, checkConfluenceWith + , somewhereM + , Config, defaultConfig, showTerm, complexity, termEquality + ) where + +import Common.Id +import Common.Navigator +import Common.Rewriting.RewriteRule +import Common.Rewriting.Substitution +import Common.Rewriting.Term +import Common.Rewriting.Unification +import Common.Utils.Uniplate hiding (rewriteM) +import Data.Maybe + +normalForm :: [RewriteRule a] -> Term -> Term +normalForm rs = run [] + where + run hist a = + case [ b | r <- rs, b <- somewhereM (rewriteTerm r) a ] of + [] -> a + hd:_ -> if hd `elem` hist + then error "cyclic" + else run (a:hist) hd + +rewriteTerm :: RewriteRule a -> Term -> [Term] +rewriteTerm r t = do + let lhs :~> rhs = ruleSpecTerm $ + case metaVars t of + [] -> r + ns -> renumberRewriteRule (maximum ns+1) r + sub <- match lhs t + return (sub |-> rhs) + +-- uniplate-like helper-functions +somewhereM :: Uniplate a => (a -> [a]) -> a -> [a] +somewhereM f = concatMap leave . rec . navigator + where + rec ca = changeM f ca ++ concatMap rec (allDowns ca) + +---------------------------------------------------- + +type Pair a = (RewriteRule a, Term) +type Triple a = (RewriteRule a, Term, Term) + +superImpose :: RewriteRule a -> RewriteRule a -> [Navigator Term] +superImpose r1 r2 = rec (navigator lhs1) + where + lhs1 :~> _ = ruleSpecTerm r1 + lhs2 :~> _ = ruleSpecTerm (renumber r1 r2) + + rec ca = case current ca of + Just (TMeta _) -> [] + Just a -> maybe [] (return . (`subTop` ca)) (unify a lhs2) ++ concatMap rec (allDowns ca) + Nothing -> [] + + subTop s ca = fromMaybe ca $ + fmap (change (s |->)) (top ca) >>= navigateTo (location ca) + + renumber r = case metaInRewriteRule r of + [] -> id + xs -> renumberRewriteRule (maximum xs + 1) + +criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)] +criticalPairs rs = + [ (a, (r1, b1), (r2, b2)) + | r1 <- rs + , r2 <- rs + , na <- superImpose r1 r2 + , compareId r1 r2 == LT || not (null (location na)) + , a <- leave na + , b1 <- rewriteTerm r1 a + , b2 <- changeM (rewriteTerm r2) na >>= leave + ] + +noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)] +noDiamondPairs cfg rs = noDiamondPairsWith (normalForm rs) cfg rs + +noDiamondPairsWith :: (Term -> Term) -> Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)] +noDiamondPairsWith f cfg rs = + [ (a, (r1, e1, nf1), (r2, e2, nf2)) + | (a, (r1, e1), (r2, e2)) <- criticalPairs rs + , let (nf1, nf2) = (f e1, f e2) + , not (termEquality cfg nf1 nf2) + ] + +reportPairs :: Config -> [(Term, Triple a, Triple a)] -> IO () +reportPairs cfg = putStrLn . unlines . zipWith report [1::Int ..] + where + f = showTerm cfg + report i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines + [ show i ++ ") " ++ f a + , " " ++ showId r1 + , " " ++ f e1 ++ if e1==nf1 then "" else " --> " ++ f nf1 + , " " ++ showId r2 + , " " ++ f e2 ++ if e2==nf2 then "" else " --> " ++ f nf2 + ] + +---------------------------------------------------- + +isConfluent :: [RewriteRule a] -> Bool +isConfluent = null . noDiamondPairs defaultConfig + +checkConfluence :: [RewriteRule a] -> IO () +checkConfluence = checkConfluenceWith defaultConfig + +checkConfluenceWith :: Config -> [RewriteRule a] -> IO () +checkConfluenceWith cfg = reportPairs cfg . noDiamondPairs cfg + +data Config = Config + { showTerm :: Term -> String + , complexity :: Term -> Int + , termEquality :: Term -> Term -> Bool + } + +defaultConfig :: Config +defaultConfig = Config show (const 0) (==) + +---------------------------------------------------- +-- Example +{- +r1, r2, r3, r4, r5 :: RewriteRule SLogic +r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r +r2 = rewriteRule "R2" $ \p q -> p :||: q :~> q :||: p +r3 = rewriteRule "R3" $ \p -> p :||: p :~> p +r4 = rewriteRule "R4" $ \p -> p :||: T :~> T +r5 = rewriteRule "R5" $ \p -> p :||: F :~> p + +this = [r1, r2, r3, r4, r5, r6] +go = reportPairs $ noDiamondPairs this + +r6 :: RewriteRule SLogic +r6 = rewriteRule "R6" $ \p -> p :||: T :~> F + +r1, r2, r3 :: RewriteRule Expr +r1 = rewriteRule "a1" $ \a -> 0+a :~> a +r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c +r3 = rewriteRule "a2" $ \a -> a+0 :~> a + +go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2] + checkConfluence [r1,r2,r3] -} diff --git a/src/Common/Rewriting/Difference.hs b/src/Common/Rewriting/Difference.hs --- a/src/Common/Rewriting/Difference.hs +++ b/src/Common/Rewriting/Difference.hs @@ -1,91 +1,86 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Compute the difference of two terms generically, taking associativity --- into account. --- ------------------------------------------------------------------------------ -module Common.Rewriting.Difference - ( difference, differenceEqual, differenceMode - ) where - -import Common.Rewriting.Group -import Common.Rewriting.Term -import Common.Rewriting.RewriteRule -import Common.View -import Common.Utils (safeHead) -import Control.Monad -import Common.Uniplate -import Data.Maybe - -differenceMode :: (Rewrite a, Uniplate a) - => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a) -differenceMode eq b = - if b then differenceEqual eq else difference - --- | This function returns the difference, except that the --- returned terms should be logically equivalent. Nothing can signal that --- there is no difference, or that the terms to start with are not equivalent. -differenceEqual :: (Rewrite a, Uniplate a) - => (a -> a -> Bool) -> a -> a -> Maybe (a, a) -differenceEqual eq p q = do - guard (eq p q) - diff eq p q - -difference :: (Rewrite a, Uniplate a) => a -> a -> Maybe (a, a) -difference = diff (\_ _ -> True) - -shallowEq :: IsTerm a => a -> a -> Bool -shallowEq a b = - let f = liftM fst . getFunction - ta = toTerm a - tb = toTerm b - in fromMaybe (ta == tb) $ liftM2 (==) (f ta) (f tb) - -findOperator :: [Magma a] -> a -> Maybe (Magma a) -findOperator ops a = safeHead $ filter (`isOperator` a) ops - where isOperator op = isJust . match (magmaView op) - --- local implementation function -diff :: (Rewrite a, Uniplate a) => (a -> a -> Bool) -> a -> a -> Maybe (a, a) -diff eq = rec - where - rec p q - | shallowEq p q = - case findOperator operators p of - Just op | isAssociative op && not (isCommutative op) -> do - ps <- match (magmaListView op) p - qs <- match (magmaListView op) q - diffA op ps qs - _ -> diffList (children p) (children q) - | otherwise = Just (p, q) - - diffList xs ys - | length xs /= length ys = Nothing - | otherwise = - case catMaybes (zipWith rec xs ys) of - [p] -> Just p - _ -> Nothing - - diffA op = curry (make . uncurry rev . f . uncurry rev . f) - where - f (p:ps, q:qs) | not (null ps || null qs) && - isNothing (rec p q) && - equal ps qs = - f (ps, qs) - f pair = pair - - equal ps qs = builder ps `eq` builder qs - rev ps qs = (reverse ps, reverse qs) - builder = build (magmaListView op) - make pair = - case pair of - ([p], [q]) -> rec p q +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Compute the difference of two terms generically, taking associativity +-- into account. +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Difference + ( difference, differenceEqual + , differenceWith, differenceEqualWith + ) where + +import Common.Rewriting.Term +import Common.View +import Control.Monad +import Data.Function +import Data.Maybe + +differenceWith :: View Term a -> a -> a -> Maybe (a, a) +differenceWith = diff (\_ _ -> True) + +differenceEqualWith :: View Term a -> (a -> a -> Bool) -> a -> a -> Maybe (a, a) +differenceEqualWith v eq p q = guard (eq p q) >> diff eq v p q + +difference :: IsTerm a => a -> a -> Maybe (a, a) +difference = diff (\_ _ -> True) termView + +-- | This function returns the difference, except that the +-- returned terms should be logically equivalent. Nothing can signal that +-- there is no difference, or that the terms to start with are not equivalent. +differenceEqual :: IsTerm a => (a -> a -> Bool) -> a -> a -> Maybe (a, a) +differenceEqual eq p q = do + guard (eq p q) + diff eq termView p q + +collectSym :: Symbol -> Term -> [Term] +collectSym s a = maybe [a] (uncurry ((++) `on` collectSym s)) (isBinary s a) + +-- local implementation function +diff :: (a -> a -> Bool) -> View Term a -> a -> a -> Maybe (a, a) +diff eq v a b = do + let eqT x y = fromMaybe False $ liftM2 eq (match v x) (match v y) + (t1, t2) <- diffTerm eqT (build v a) (build v b) + liftM2 (,) (match v t1) (match v t2) + +diffTerm :: (Term -> Term -> Bool) -> Term -> Term -> Maybe (Term, Term) +diffTerm eq = rec + where + rec p q = + case (getFunction p, getFunction q) of + (Just (s1, ps), Just (s2, qs)) + | s1 /= s2 -> Just (p, q) + | isAssociative s1 -> (diffA s1 `on` collectSym s1) p q + | otherwise -> diffList ps qs + _ | p == q -> Nothing + | otherwise -> Just (p, q) + + diffList xs ys + | length xs /= length ys = Nothing + | otherwise = + case catMaybes (zipWith rec xs ys) of + [p] -> Just p + _ -> Nothing + + diffA s = curry (make . rev . f . rev . f) + where + f (p:ps, q:qs) | not (null ps || null qs) && + isNothing (rec p q) && + equal ps qs = + f (ps, qs) + f pair = pair + + equal = eq `on` builder + rev = reverse *** reverse + builder = foldr1 (binary s) + make pair = + case pair of + ([p], [q]) -> rec p q (ps, qs) -> Just (builder ps, builder qs) diff --git a/src/Common/Rewriting/Group.hs b/src/Common/Rewriting/Group.hs deleted file mode 100644 --- a/src/Common/Rewriting/Group.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A hierarchy of magma's (binary operators) and groups, up to Abelian groups. --- ------------------------------------------------------------------------------ -module Common.Rewriting.Group - ( -- Magma - IsMagma(..), Magma, magma, magmaView, magmaListView - , withMatch, findMagma - , isAssociative, isCommutative, isIdempotent - , makeAssociative, makeCommutative, makeIdempotent - -- Semigroup - , IsSemiGroup(..), SemiGroup, semiGroup - , leftIsPreferred, rightIsPreferred - , preferLeft, preferRight - -- Monoid - , IsMonoid(..), Monoid, monoid - -- Group - , IsGroup(..), Group, group - -- Abelian group - , IsAbelianGroup(..), AbelianGroup, abelianGroup - ) where - -import Control.Arrow -import Common.Id -import Common.View hiding (identity) -import Common.Rewriting.Operator - -------------------------------------------------------------------- --- * Magma - -class IsMagma f where - operation :: f a -> a -> a -> a - hasMagma :: f a -> (Magma a, Magma a -> f a) - toMagma :: f a -> Magma a - changeMagma :: (Magma a -> Magma a) -> f a -> f a - -- default definitions - operation = binary . magmaBinaryOp . toMagma - toMagma = fst . hasMagma - changeMagma f = uncurry (flip ($)) . first f . hasMagma - -data Magma a = Magma - { magmaBinaryOp :: BinaryOp a - , magmaProperties :: [MagmaProperty] - } - -data MagmaProperty = Associative | Commutative | Idempotent | PreferLeft - deriving Eq - -instance Show (Magma a) where - show m = "Magma " ++ showId m - -instance HasId (Magma a) where - getId = getId . magmaBinaryOp - changeId f m = m {magmaBinaryOp = changeId f (magmaBinaryOp m)} - -instance IsMagma Magma where - hasMagma a = (a, id) - -magma :: BinaryOp a -> Magma a -magma op = Magma op [] - -magmaView :: IsMagma m => m a -> View a (a, a) -magmaView = binaryView . magmaBinaryOp . toMagma - --- The list can (and should) only contain more than two elements if the magma --- is associative -magmaListView :: IsMagma m => m a -> View a [a] -magmaListView m = makeView (Just . toList) fromList - where - toList = if isAssociative m then ($ []) . rec else f - - f a = maybe [a] (\(x, y) -> [x, y]) (match (magmaView m) a) - - rec a = case match (magmaView m) a of - Just (b, c) -> rec b . rec c - Nothing -> (a:) - - fromList xs - | null xs = - error "semiGroupView.build: empty list" - | n>2 && not (isAssociative m) = - error $ "semiGroupView.build: not associativity for " - ++ showId (toMagma m) - | otherwise = fold (operation m) xs - where - n = length xs - fold = if hasProperty PreferLeft m then foldl1 else foldr1 - -withMatch :: IsMagma m => (a -> Maybe (a, a)) -> m a -> m a -withMatch f = changeMagma $ \m -> m {magmaBinaryOp = g (magmaBinaryOp m)} - where - g op = makeBinary (getId op) (binary op) f - -isAssociative, isCommutative, isIdempotent :: IsMagma m => m a -> Bool -isAssociative = hasProperty Associative -isCommutative = hasProperty Commutative -isIdempotent = hasProperty Idempotent - -makeAssociative, makeCommutative, makeIdempotent :: IsMagma m => m a -> m a -makeAssociative = giveProperty Associative -makeCommutative = giveProperty Commutative -makeIdempotent = giveProperty Idempotent - -findMagma :: IsMagma m => (m a -> b) -> m a -> (Magma a, Magma a -> b) -findMagma f = second (f .) . hasMagma - --- helper functions -hasProperty :: IsMagma m => MagmaProperty -> m a -> Bool -hasProperty p = elem p . magmaProperties . toMagma - -giveProperty :: IsMagma m => MagmaProperty -> m a -> m a -giveProperty p = changeMagma $ \m -> - m {magmaProperties = p:magmaProperties m} - -removeProperty :: IsMagma m => MagmaProperty -> m a -> m a -removeProperty p = changeMagma $ \m -> - m {magmaProperties = filter (/=p) (magmaProperties m)} - -------------------------------------------------------------------- --- * SemiGroup - -class IsMagma f => IsSemiGroup f where - toSemiGroup :: f a -> SemiGroup a - -- default definition - toSemiGroup m = SemiGroup (rightIsPreferred m) (toMagma m) - -data SemiGroup a = SemiGroup Bool (Magma a) - -instance Show (SemiGroup a) where - show m = "Semigroup " ++ showId m - -instance HasId (SemiGroup a) where - getId = getId . toMagma - changeId = changeMagma . changeId - -instance IsMagma SemiGroup where - hasMagma (SemiGroup b m) = findMagma (SemiGroup b) m - -instance IsSemiGroup SemiGroup where - toSemiGroup = id - -semiGroup :: BinaryOp a -> SemiGroup a -semiGroup op = makeAssociative $ SemiGroup True (magma op) - -leftIsPreferred, rightIsPreferred :: IsSemiGroup m => m a -> Bool -leftIsPreferred = hasProperty PreferLeft -rightIsPreferred = not . leftIsPreferred - -preferLeft, preferRight :: IsSemiGroup m => m a -> m a -preferLeft = giveProperty PreferLeft -preferRight = removeProperty PreferLeft - -------------------------------------------------------------------- --- * Monoid - -class IsSemiGroup f => IsMonoid f where - identity :: f a -> a - identityCon :: f a -> Constant a - toMonoid :: f a -> Monoid a - -- default definition - identity = constant . identityCon - toMonoid m = Monoid (identityCon m) (toSemiGroup m) - -data Monoid a = Monoid (Constant a) (SemiGroup a) - -instance Show (Monoid a) where - show m = "Monoid " ++ showId m - -instance HasId (Monoid a) where - getId = getId . toMagma - changeId = changeMagma . changeId - -instance IsMagma Monoid where - hasMagma (Monoid e g) = findMagma (Monoid e) g - -instance IsSemiGroup Monoid - -instance IsMonoid Monoid where - identityCon (Monoid e _) = e - toMonoid = id - -monoid :: BinaryOp a -> Constant a -> Monoid a -monoid op e = Monoid e (semiGroup op) - -------------------------------------------------------------------- --- * Group - -class IsMonoid f => IsGroup f where - inverse :: f a -> a -> a - inverseOp :: f a -> UnaryOp a - toGroup :: f a -> Group a - -- default definition - inverse = unary . inverseOp - toGroup g = Group (inverseOp g) (toMonoid g) - -data Group a = Group (UnaryOp a) (Monoid a) - -instance Show (Group a) where - show m = "Group " ++ showId m - -instance HasId (Group a) where - getId = getId . toMagma - changeId = changeMagma . changeId - -instance IsMagma Group where - hasMagma (Group inv m) = findMagma (Group inv) m - -instance IsSemiGroup Group - -instance IsMonoid Group where - identityCon (Group _ m) = identityCon m - -instance IsGroup Group where - inverseOp (Group inv _) = inv - toGroup = id - -group :: BinaryOp a -> Constant a -> UnaryOp a -> Group a -group op e inv = Group inv (monoid op e) - -------------------------------------------------------------------- --- * Abelian Group - -class IsGroup f => IsAbelianGroup f where - toAbelianGroup :: f a -> AbelianGroup a - -- default definition - toAbelianGroup = AbelianGroup . toGroup - -newtype AbelianGroup a = AbelianGroup (Group a) - deriving (HasId, IsMagma, IsSemiGroup, IsMonoid, IsGroup) - -abelianGroup :: BinaryOp a -> Constant a -> UnaryOp a -> AbelianGroup a -abelianGroup op e inv = makeCommutative $ AbelianGroup (group op e inv) - -instance Show (AbelianGroup a) where - show m = "Abelian group " ++ showId m - -instance IsAbelianGroup AbelianGroup diff --git a/src/Common/Rewriting/Operator.hs b/src/Common/Rewriting/Operator.hs deleted file mode 100644 --- a/src/Common/Rewriting/Operator.hs +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.Operator - ( -- * Constants - Constant, makeConstant, simpleConstant - , constant, isConstant, constantView - -- * Unary operators - , UnaryOp, makeUnary, simpleUnary - , unary, isUnary, unaryMatch, unaryView - -- * Binary operators - , BinaryOp, makeBinary, simpleBinary - , binary, isBinary, binaryMatch, binaryView - ) where - -import Common.Id -import Common.Uniplate -import Common.View -import Data.Maybe -import Control.Monad - ----------------------------------------------------------------------- --- Constants - -data Constant a = C - { constantId :: Id - , constant :: a - , isConstant :: a -> Bool - } - -instance Show (Constant a) where - show = showId - -instance HasId (Constant a) where - getId = constantId - changeId f op = op {constantId = f (constantId op)} - -makeConstant :: IsId n => n -> a -> (a -> Bool) -> Constant a -makeConstant = C . newId - -simpleConstant :: (IsId n, Eq a) => n -> a -> Constant a -simpleConstant n a = makeConstant n a (==a) - -constantView :: Constant a -> View a () -constantView (C i a p) = newView i (guard . p) (const a) - ----------------------------------------------------------------------- --- Unary operators - -data UnaryOp a = U - { unaryId :: Id - , unary :: a -> a - , unaryMatch :: a -> Maybe a - } - -instance Show (UnaryOp a) where - show = showId - -instance HasId (UnaryOp a) where - getId = unaryId - changeId f op = op {unaryId = f (unaryId op)} - -makeUnary :: IsId n => n -> (a -> a) -> (a -> Maybe a) -> UnaryOp a -makeUnary = U . newId - -simpleUnary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a) -> UnaryOp a -simpleUnary n op = makeUnary n op f - where - f a = case children a of - [x] | op x == a -> Just x - _ -> Nothing - -isUnary :: UnaryOp a -> a -> Bool -isUnary op = isJust . unaryMatch op - -unaryView :: UnaryOp a -> View a a -unaryView (U i op m) = newView i m op - ----------------------------------------------------------------------- --- Binary operators - -data BinaryOp a = B - { binaryId :: Id - , binary :: a -> a -> a - , binaryMatch :: a -> Maybe (a, a) - } - -instance Show (BinaryOp a) where - show = showId - -instance HasId (BinaryOp a) where - getId = binaryId - changeId f op = op {binaryId = f (binaryId op)} - -makeBinary :: IsId n => n -> (a -> a -> a) -> (a -> Maybe (a, a)) -> BinaryOp a -makeBinary = B . newId - -simpleBinary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a -> a) -> BinaryOp a -simpleBinary n op = makeBinary n op f - where - f a = case children a of - [x, y] | op x y == a -> Just (x, y) - _ -> Nothing - -isBinary :: BinaryOp a -> a -> Bool -isBinary op = isJust . binaryMatch op - -binaryView :: BinaryOp a -> View a (a, a) -binaryView (B n op m) = newView n m (uncurry op) 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,196 +1,155 @@ -{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, - FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.RewriteRule - ( -- * Supporting type classes - Rewrite(..), Different(..) - -- * Rewrite rules and specs - , RewriteRule, ruleSpecTerm, RuleSpec(..) - -- * Compiling rewrite rules - , rewriteRule, RuleBuilder - -- * Using rewrite rules - , rewrite, rewriteM, showRewriteRule, smartGenerator - , metaInRewriteRule, renumberRewriteRule, inverseRule - , useOperators - ) where - -import Common.Classes -import Common.Id -import Common.View hiding (match) -import Common.Rewriting.Substitution -import Common.Rewriting.Term -import Common.Rewriting.Group -import Common.Rewriting.Unification hiding (match) -import Common.Uniplate (descend, leafs) -import Control.Monad -import Data.Maybe -import Test.QuickCheck -import qualified Common.Rewriting.Unification as Unification -import qualified Data.IntSet as IS - ------------------------------------------------------- --- Supporting type classes - --- The arbitrary type class is a quick solution to have smart generators --- (in combination with lifting rules). The function in the RewriteRule module --- cannot have a type class for this reason --- The show type class is added for pretty-printing rules -class (IsTerm a, Arbitrary a, Show a) => Rewrite a where - operators :: [Magma a] - -- default definition: no special operators - operators = [] - ------------------------------------------------------- --- Rewrite rules and specs - -infixl 1 :~> - -data RuleSpec a = a :~> a deriving Show - -instance Functor RuleSpec where - fmap f (a :~> b) = f a :~> f b - -instance Crush RuleSpec where - crush (a :~> b) = [a, b] - -instance Zip RuleSpec where - fzipWith f (a :~> b) (c :~> d) = f a c :~> f b d - -data RewriteRule a = R - { ruleId :: Id - , ruleSpecTerm :: RuleSpec Term - , ruleOperators :: [Magma a] - , ruleShow :: a -> String - , ruleTermView :: View Term a - , ruleGenerator :: Gen a - } - -instance Show (RewriteRule a) where - show = showId - -instance HasId (RewriteRule a) where - getId = ruleId - changeId f r = r {ruleId = f (ruleId r)} - ------------------------------------------------------- --- Compiling a rewrite rule - -class Different a where - different :: (a, a) - -class RuleBuilder t a | t -> a where - buildRuleSpec :: t -> Int -> RuleSpec Term - -instance IsTerm a => RuleBuilder (RuleSpec a) a where - buildRuleSpec = const . fmap toTerm - -instance (Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where - buildRuleSpec f i = buildFunction i (\a -> buildRuleSpec (f a) (i+1)) - -buildFunction :: (Zip f, Different a) => Int -> (a -> f Term) -> f Term -buildFunction n f = fzipWith (fill n) (f a) (f b) - where (a, b) = different - -fill :: Int -> Term -> Term -> Term -fill i = rec - where - rec (Apply f a) (Apply g b) = Apply (rec f g) (rec a b) - rec a b - | a == b = a - | otherwise = Meta i - -buildSpec :: [Symbol] -> RuleSpec Term -> Term -> [Term] -buildSpec ops (lhs :~> rhs) a = do - s <- Unification.match ops lhs a - let (b1, b2) = (specialLeft `elem` dom s, specialRight `elem` dom s) - sym = maybe (error "buildSpec") fst (getFunction lhs) - extLeft x = if b1 then binary sym (Meta specialLeft) x else x - extRight x = if b2 then binary sym x (Meta specialRight) else x - return (s |-> extLeft (extRight rhs)) - -rewriteRule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> RewriteRule a -rewriteRule s f = R (newId s) (buildRuleSpec f 0) operators show termView arbitrary - ------------------------------------------------------- --- Using a rewrite rule - -instance Apply RewriteRule where - applyAll = rewrite - -rewrite :: RewriteRule a -> a -> [a] -rewrite r a = - let term = toTermRR r a - syms = mapMaybe (operatorSymbol r a) (ruleOperators r) - in concatMap (fromTermRR r) (buildSpec syms (ruleSpecTerm r) term) - -operatorSymbol :: IsMagma m => RewriteRule a -> a -> m a -> Maybe Symbol -operatorSymbol r a op = - case getFunction (toTermRR r (operation op a a)) of - Just (s, [_, _]) -> Just s - _ -> Nothing - -rewriteM :: MonadPlus m => RewriteRule a -> a -> m a -rewriteM r = msum . map return . rewrite r - ------------------------------------------------------------ --- Pretty-print a rewriteRule - -showRewriteRule :: Bool -> RewriteRule a -> Maybe String -showRewriteRule sound r = do - x <- fromTermRR r (sub |-> a) - y <- fromTermRR r (sub |-> b) - let op = if sound then "~>" else "/~>" - return (ruleShow r x ++ " " ++ op ++ " " ++ ruleShow r y) - where - a :~> b = ruleSpecTerm r - vs = IS.toList (metaVarSet a `IS.union` metaVarSet b) - sub = listToSubst $ zip vs [ Var [c] | c <- ['a' ..] ] - ------------------------------------------------------------ --- Smart generator that creates instantiations of the left-hand side - -smartGenerator :: RewriteRule a -> Gen a -smartGenerator r = do - let a :~> _ = ruleSpecTerm r - let vs = IS.toList (metaVarSet a) - list <- replicateM (length vs) (ruleGenerator r) - let sub = listToSubst (zip vs (map (toTermRR r) list)) - case fromTermRR r (sub |-> a) of - Just x -> return x - Nothing -> ruleGenerator r - ------------------------------------------------------- - -inverseRule :: RewriteRule a -> RewriteRule a -inverseRule r = r {ruleSpecTerm = b :~> a} - where a :~> b = ruleSpecTerm r - -useOperators :: [Magma a] -> RewriteRule a -> RewriteRule a -useOperators xs r = r {ruleOperators = xs ++ ruleOperators r} - --- some helpers -metaInRewriteRule :: RewriteRule a -> [Int] -metaInRewriteRule r = - [ n | a <- crush (ruleSpecTerm r), Meta n <- leafs a ] - -renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a -renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)} - where - f (Meta i) = Meta (i+n) - f term = descend f term - -toTermRR :: RewriteRule a -> a -> Term -toTermRR = build . ruleTermView - -fromTermRR :: Monad m => RewriteRule a -> Term -> m a +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, + FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.RewriteRule + ( -- * Supporting type class + Different(..) + -- * Rewrite rules and specs + , RewriteRule, ruleSpecTerm, RuleSpec(..) + -- * Compiling rewrite rules + , rewriteRule, RuleBuilder(..) + -- * Using rewrite rules + , rewrite, rewriteM, showRewriteRule, smartGenerator + , metaInRewriteRule, renumberRewriteRule + ) where + +import Common.Classes +import Common.Id +import Common.Rewriting.Substitution +import Common.Rewriting.Term +import Common.Rewriting.Unification +import Common.Utils.Uniplate (descend) +import Common.View hiding (match) +import Control.Monad +import Test.QuickCheck +import qualified Data.IntSet as IS + +------------------------------------------------------ +-- Rewrite rules and specs + +infixl 1 :~> + +data RuleSpec a = a :~> a deriving Show + +instance Functor RuleSpec where + fmap f (a :~> b) = f a :~> f b + +data RewriteRule a = R + { ruleId :: Id + , ruleSpecTerm :: RuleSpec Term + , ruleShow :: a -> String + , ruleTermView :: View Term a + , smartGenerator :: Gen a + } + +instance Show (RewriteRule a) where + show = showId + +instance HasId (RewriteRule a) where + getId = ruleId + changeId f r = r {ruleId = f (ruleId r)} + +------------------------------------------------------ +-- Compiling a rewrite rule + +class Different a where + different :: (a, a) + +instance Different a => Different [a] where + different = ([], [fst different]) + +instance Different Char where + different = ('a', 'b') + +class (IsTerm a, Show a) => RuleBuilder t a | t -> a where + buildRuleSpec :: Int -> t -> RuleSpec Term + buildGenerator :: t -> Gen a + +instance (IsTerm a, Show a) => RuleBuilder (RuleSpec a) a where + buildRuleSpec = const $ fmap toTerm + buildGenerator (a :~> _) = return a + +instance (Arbitrary a, Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where + buildRuleSpec i f = buildFunction i (buildRuleSpec (i+1) . f) + buildGenerator f = liftM f arbitrary >>= buildGenerator + +buildFunction :: Different a => Int -> (a -> RuleSpec Term) -> RuleSpec Term +buildFunction n f = fzip (fill n) ((f *** f) different) + where + fzip g (a :~> b, c :~> d) = g a c :~> g b d + +fill :: Int -> Term -> Term -> Term +fill i = rec + where + rec (TApp f a) (TApp g b) = TApp (rec f g) (rec a b) + rec a b + | a == b = a + | otherwise = TMeta i + +buildSpec :: RuleSpec Term -> Term -> [Term] +buildSpec (lhs :~> rhs) a = do + s <- matchA lhs a + let (b1, b2) = (specialLeft `IS.member` dom s, specialRight `IS.member` dom s) + sym = maybe (error "buildSpec") fst (getFunction lhs) + extLeft x = if b1 then binary sym (TMeta specialLeft) x else x + extRight x = if b2 then binary sym x (TMeta specialRight) else x + return (s |-> extLeft (extRight rhs)) + +rewriteRule :: (IsId n, RuleBuilder f a) => n -> f -> RewriteRule a +rewriteRule s f = R (newId s) (buildRuleSpec 0 f) show termView (buildGenerator f) + +------------------------------------------------------ +-- Using a rewrite rule + +instance Apply RewriteRule where + applyAll = rewrite + +rewrite :: RewriteRule a -> a -> [a] +rewrite r a = + concatMap (fromTermRR r) $ buildSpec (ruleSpecTerm r) $ toTermRR r a + +rewriteM :: MonadPlus m => RewriteRule a -> a -> m a +rewriteM r = msum . map return . rewrite r + +----------------------------------------------------------- +-- Pretty-print a rewriteRule + +showRewriteRule :: Bool -> RewriteRule a -> Maybe String +showRewriteRule sound r = do + x <- fromTermRR r (sub |-> a) + y <- fromTermRR r (sub |-> b) + let op = if sound then "~>" else "/~>" + return (ruleShow r x ++ " " ++ op ++ " " ++ ruleShow r y) + where + a :~> b = ruleSpecTerm r + vs = IS.toList (metaVarSet a `IS.union` metaVarSet b) + sub = listToSubst $ zip vs [ TVar [c] | c <- ['a' ..] ] + +------------------------------------------------------ + +-- some helpers +metaInRewriteRule :: RewriteRule a -> [Int] +metaInRewriteRule r = metaVars a ++ metaVars b + where a :~> b = ruleSpecTerm r + +renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a +renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)} + where + f (TMeta i) = TMeta (i+n) + f term = descend f term + +toTermRR :: RewriteRule a -> a -> Term +toTermRR = build . ruleTermView + +fromTermRR :: Monad m => RewriteRule a -> Term -> m a fromTermRR = matchM . ruleTermView diff --git a/src/Common/Rewriting/Substitution.hs b/src/Common/Rewriting/Substitution.hs --- a/src/Common/Rewriting/Substitution.hs +++ b/src/Common/Rewriting/Substitution.hs @@ -1,73 +1,116 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Substitutions on terms --- ------------------------------------------------------------------------------ -module Common.Rewriting.Substitution - ( Substitution, emptySubst, singletonSubst, dom - , (@@), (@@@), (|->), listToSubst - ) where - -import Common.Uniplate -import Common.Rewriting.Term -import qualified Data.IntMap as IM -import Data.Maybe - ------------------------------------------------------------ ---- Substitution - --- | Abstract data type for substitutions -newtype Substitution = S { unS :: IM.IntMap Term } - -infixr 4 |-> -infixr 5 @@, @@@ - -instance Show Substitution where - show = show . unS - --- | Returns the empty substitution -emptySubst :: Substitution -emptySubst = S IM.empty - --- | Returns a singleton substitution -singletonSubst :: Int -> Term -> Substitution -singletonSubst i a = S (IM.singleton i a) - --- | Turns a list into a substitution -listToSubst :: [(Int, Term)] -> Substitution -listToSubst = S . IM.fromListWith (error "Substitution: keys are not unique") - --- | Combines two substitutions. The left-hand side substitution is first applied to --- the co-domain of the right-hand side substitution -(@@) :: Substitution -> Substitution -> Substitution -S a @@ S b = S $ a `IM.union` IM.map (S a |->) b - --- | Combines two substitutions with disjoint domains. If the domains are not disjoint, --- an error is reported -(@@@) :: Substitution -> Substitution -> Substitution -S a @@@ S b = S (IM.unionWith err a b) - where err _ _ = error "Unification.(@@@): domains of substitutions are not disjoint" - --- | Lookups a variable in a substitution. Nothing indicates that the variable is --- not in the domain of the substitution -lookupVar :: Int -> Substitution -> Maybe Term -lookupVar s = IM.lookup s . unS - --- | Returns the domain of a substitution (as a list) -dom :: Substitution -> [Int] -dom = IM.keys . unS - --- | Apply the substitution -(|->) :: Substitution -> Term -> Term -s |-> term = - case term of - Meta i -> fromMaybe term (lookupVar i s) - _ -> descend (s |->) term +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Substitutions on terms. Substitutions are idempotent, and non-cyclic. +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Substitution + ( Substitution, emptySubst, singletonSubst, dom + , (@@), (|->), listToSubst, composable + , tests + ) where + +import Common.Rewriting.Term +import Common.Utils.TestSuite +import Common.Utils.Uniplate +import Data.List +import Data.Maybe +import Data.Monoid +import Test.QuickCheck +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +----------------------------------------------------------- +--- * Substitution + +-- | Abstract data type for substitutions +newtype Substitution = S { unS :: IM.IntMap Term } + deriving Eq + +instance Monoid Substitution where + mempty = emptySubst + mappend = (@@) + +infixr 5 |-> +infixr 6 @@ + +instance Show Substitution where + show = show . unS + +-- | Returns the empty substitution +emptySubst :: Substitution +emptySubst = S IM.empty + +-- | Returns a singleton substitution +singletonSubst :: Int -> Term -> Substitution +singletonSubst i a + | a == TMeta i = emptySubst + | i `elem` metaVars a = error "Substitution: cyclic" + | otherwise = S (IM.singleton i a) + +-- | Turns a list into a substitution +listToSubst :: [(Int, Term)] -> Substitution +listToSubst = mconcat . map (uncurry singletonSubst) + +-- | Combines two substitutions. The left-hand side substitution is first applied to +-- the co-domain of the right-hand side substitution +(@@) :: Substitution -> Substitution -> Substitution +s1 @@ s2 + | composable s1 s2 = S $ IM.map (s1 |->) (unS s2) `IM.union` unS s1 + | otherwise = error "Substitution: cyclic" + +composable :: Substitution -> Substitution -> Bool +composable s1 s2 = + let f = IS.unions . map metaVarSet . IM.elems . unS + in IS.null (IS.intersection (f s1) (dom s2)) + +-- | Lookups a variable in a substitution. Nothing indicates that the variable is +-- not in the domain of the substitution +lookupVar :: Int -> Substitution -> Maybe Term +lookupVar s = IM.lookup s . unS + +-- | Returns the domain of a substitution (as a set) +dom :: Substitution -> IS.IntSet +dom = IM.keysSet . unS + +-- | Apply the substitution +(|->) :: Substitution -> Term -> Term +s |-> term = + case term of + TMeta i -> fromMaybe term (lookupVar i s) + _ -> descend (s |->) term + +----------------------------------------------------------- +--- * Test substitution properties + +instance Arbitrary Substitution where + arbitrary = do + n <- choose (1, 10) + ts <- vector n + let is = [0..] \\ concatMap metaVars ts + return (listToSubst (zip is ts)) + +tests :: TestSuite +tests = suite "Substitution" $ do + addProperty "left unit" $ \s -> + mempty @@ s == s + addProperty "right unit" $ \s -> + s @@ mempty == s + addProperty "associative" $ \s1 s2 s3 -> + composable s1 s2 && composable (s1 @@ s2) s3 + && composable s2 s3 && composable s1 (s2 @@ s3) + ==> (s1 @@ s2) @@ s3 == s1 @@ (s2 @@ s3) + addProperty "idempotence" $ \s -> + s @@ s == s + addProperty "idempotence/application" $ \s a -> + s |-> a == s |-> (s |-> a) + addProperty "composition" $ \s1 s2 a -> + composable s1 s2 + ==> s1 |-> (s2 |-> a) == (s1 @@ s2) |-> a 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,223 +1,267 @@ -{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A simple data type for term rewriting --- ------------------------------------------------------------------------------ -module Common.Rewriting.Term - ( Term(..), IsTerm(..) - , Symbol, newSymbol - , fromTermM, fromTermWith - , getSpine, makeTerm - -- * Functions and symbols - , WithFunctions(..), isSymbol, isFunction - , unary, binary, isUnary, isBinary - -- * Variables - , WithVars(..), isVariable - , vars, varSet, hasVar, withoutVar, hasSomeVar, hasNoVar - -- * Meta variables - , WithMetaVars(..), isMetaVar - , metaVars, metaVarSet, hasMetaVar - ) where - -import Common.Id -import Common.Utils (ShowString(..)) -import Common.Uniplate -import Common.View -import Control.Monad -import Data.Maybe -import Data.Typeable -import qualified Data.IntSet as IS -import qualified Data.Set as S - ------------------------------------------------------------ --- * Data type for terms - -data Term = Var String - | Con Symbol - | Apply Term Term - | Num Integer - | Float Double - | Meta Int - deriving (Show, Eq, Ord, Typeable) - -instance Uniplate Term where - uniplate (Apply f a) = ([f, a], \[g, b] -> Apply g b) - uniplate term = ([], \_ -> term) - -newtype Symbol = S Id - deriving (Eq, Ord) - -instance Show Symbol where - show = showId - -instance HasId Symbol where - getId (S a) = a - changeId f (S a) = S (f a) - -newSymbol :: IsId a => a -> Symbol -newSymbol = S . newId - ------------------------------------------------------------ --- * Type class for conversion to/from terms - -class IsTerm a where - toTerm :: a -> Term - fromTerm :: MonadPlus m => Term -> m a - termView :: View Term a - -- default definitions - toTerm = build termView - fromTerm = matchM termView - termView = makeView fromTerm toTerm - -instance IsTerm Term where - toTerm = id - fromTerm = return - -instance IsTerm ShowString where - toTerm = Var . fromShowString - fromTerm (Var s) = return (ShowString s) - fromTerm _ = fail "fromTerm" - -instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where - toTerm = either toTerm toTerm - fromTerm expr = - liftM Left (fromTerm expr) `mplus` - liftM Right (fromTerm expr) - -fromTermM :: (Monad m, IsTerm a) => Term -> m a -fromTermM = maybe (fail "fromTermM") return . fromTerm - -fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a -fromTermWith f a = do - (s, xs) <- getFunction a - ys <- mapM fromTermM xs - f s ys - ------------------------------------------------------------ --- * Functions and symbols - -class WithFunctions a where - -- constructing - symbol :: Symbol -> a - function :: Symbol -> [a] -> a - -- matching - getSymbol :: Monad m => a -> m Symbol - getFunction :: Monad m => a -> m (Symbol, [a]) - -- default definition - symbol s = function s [] - getSymbol a = - case getFunction a of - Just (t, []) -> return t - _ -> fail "Common.Term.getSymbol" - -instance WithFunctions Term where - function = makeTerm . Con - getFunction a = - case getSpine a of - (Con s, xs) -> return (s, xs) - _ -> fail "Common.Rewriting.getFunction" - -isSymbol :: WithFunctions a => Symbol -> a -> Bool -isSymbol s = maybe False (==s) . getSymbol - -isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a] -isFunction s a = - case getFunction a of - Just (t, as) | s == t -> return as - _ -> fail "Common.Term.isFunction" - -unary :: WithFunctions a => Symbol -> a -> a -unary s a = function s [a] - -binary :: WithFunctions a => Symbol -> a -> a -> a -binary s a b = function s [a, b] - -isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a -isUnary s a = - case isFunction s a of - Just [x] -> return x - _ -> fail "Common.Term.isUnary" - -isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) -isBinary s a = - case isFunction s a of - Just [x, y] -> return (x, y) - _ -> fail "Common.Term.isBinary" - ------------------------------------------------------------ --- * Variables - -class WithVars a where - variable :: String -> a - getVariable :: Monad m => a -> m String - -instance WithVars Term where - variable = Var - getVariable (Var s) = return s - getVariable _ = fail "Common.Rewriting.getVariable" - -isVariable :: WithVars a => a -> Bool -isVariable = isJust . getVariable - -vars :: (Uniplate a, WithVars a) => a -> [String] -vars = concatMap getVariable . leafs - -varSet :: (Uniplate a, WithVars a) => a -> S.Set String -varSet = S.fromList . vars - -hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool -hasVar i = (i `elem`) . vars - -withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool -withoutVar i = not . hasVar i - -hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool -hasSomeVar = not . hasNoVar - -hasNoVar :: (Uniplate a, WithVars a) => a -> Bool -hasNoVar = null . vars - ------------------------------------------------------------ --- * Meta variables - -class WithMetaVars a where - metaVar :: Int -> a - getMetaVar :: Monad m => a -> m Int - -instance WithMetaVars Term where - metaVar = Meta - getMetaVar (Meta i) = return i - getMetaVar _ = fail "Common.Rewriting.getMetaVar" - -isMetaVar :: WithMetaVars a => a -> Bool -isMetaVar = isJust . getMetaVar - -metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int] -metaVars = concatMap getMetaVar . leafs - -metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet -metaVarSet = IS.fromList . metaVars - -hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool -hasMetaVar i = (i `elem`) . metaVars - ------------------------------------------------------------ --- * Utility functions - -getSpine :: Term -> (Term, [Term]) -getSpine = rec [] - where - rec xs (Apply f a) = rec (a:xs) f - rec xs a = (a, xs) - -makeTerm :: Term -> [Term] -> Term -makeTerm = foldl Apply +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A simple data type for term rewriting +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Term + ( -- * Symbols + Symbol, newSymbol + , isAssociative, makeAssociative + -- * Terms + , Term(..), IsTerm(..), termView + , fromTermM, fromTermWith + , getSpine, makeTerm + -- * Functions and symbols + , WithFunctions(..), isSymbol, isFunction + , unary, binary, isUnary, isBinary + -- * Variables + , WithVars(..), isVariable + , vars, varSet, hasVar, withoutVar + , hasSomeVar, hasNoVar, variableView + -- * Meta variables + , WithMetaVars(..), isMetaVar + , metaVars, metaVarSet, hasMetaVar + ) where + +import Common.Id +import Common.Utils (ShowString(..)) +import Common.Utils.QuickCheck +import Common.Utils.Uniplate +import Common.View +import Control.Monad +import Data.Function +import Data.Maybe +import Data.Typeable +import qualified Data.IntSet as IS +import qualified Data.Set as S + +----------------------------------------------------------- +-- Symbols + +data Symbol = S { isAssociative :: Bool, symbolId :: Id } + +instance Eq Symbol where + (==) = (==) `on` getId -- without associativity property + +instance Ord Symbol where + compare = compareId -- without associativity property + +instance Show Symbol where + show = showId + +instance HasId Symbol where + getId = symbolId + changeId f (S b a) = S b (f a) + +newSymbol :: IsId a => a -> Symbol +newSymbol = S False . newId + +makeAssociative :: Symbol -> Symbol +makeAssociative (S _ a) = S True a + +----------------------------------------------------------- +-- * Data type for terms + +data Term = TVar String + | TCon Symbol + | TApp Term Term + | TNum Integer + | TFloat Double + | TMeta Int + deriving (Show, Eq, Ord, Typeable) + +instance Uniplate Term where + uniplate (TApp f a) = plate TApp |* f |* a + uniplate term = plate term + +----------------------------------------------------------- +-- * Type class for conversion to/from terms + +class IsTerm a where + toTerm :: a -> Term + fromTerm :: MonadPlus m => Term -> m a + +termView :: IsTerm a => View Term a +termView = makeView fromTerm toTerm + +instance IsTerm Term where + toTerm = id + fromTerm = return + +instance IsTerm ShowString where + toTerm = TVar . fromShowString + fromTerm (TVar s) = return (ShowString s) + fromTerm _ = fail "fromTerm" + +instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where + toTerm = either toTerm toTerm + fromTerm expr = + liftM Left (fromTerm expr) `mplus` + liftM Right (fromTerm expr) + +instance IsTerm Int where + toTerm = TNum . fromIntegral + fromTerm = liftM fromInteger . fromTerm + +instance IsTerm Integer where + toTerm = TNum + fromTerm (TNum a) = return a + fromTerm _ = fail "fromTerm" + +instance IsTerm Double where + toTerm = TFloat + fromTerm (TFloat a) = return a + fromTerm _ = fail "fromTerm" + +fromTermM :: (Monad m, IsTerm a) => Term -> m a +fromTermM = maybe (fail "fromTermM") return . fromTerm + +fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a +fromTermWith f a = do + (s, xs) <- getFunction a + ys <- mapM fromTermM xs + f s ys + +----------------------------------------------------------- +-- * Functions and symbols + +class WithFunctions a where + -- constructing + symbol :: Symbol -> a + function :: Symbol -> [a] -> a + -- matching + getSymbol :: Monad m => a -> m Symbol + getFunction :: Monad m => a -> m (Symbol, [a]) + -- default definition + symbol s = function s [] + getSymbol a = + case getFunction a of + Just (t, []) -> return t + _ -> fail "Common.Term.getSymbol" + +instance WithFunctions Term where + function = makeTerm . TCon + getFunction a = + case getSpine a of + (TCon s, xs) -> return (s, xs) + _ -> fail "Common.Rewriting.getFunction" + +isSymbol :: WithFunctions a => Symbol -> a -> Bool +isSymbol s = maybe False (==s) . getSymbol + +isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a] +isFunction s a = + case getFunction a of + Just (t, as) | s == t -> return as + _ -> fail "Common.Term.isFunction" + +unary :: WithFunctions a => Symbol -> a -> a +unary s a = function s [a] + +binary :: WithFunctions a => Symbol -> a -> a -> a +binary s a b = function s [a, b] + +isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a +isUnary s a = + case isFunction s a of + Just [x] -> return x + _ -> fail "Common.Term.isUnary" + +isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) +isBinary s a = + case isFunction s a of + Just [x, y] -> return (x, y) + _ -> fail "Common.Term.isBinary" + +----------------------------------------------------------- +-- * Variables + +class WithVars a where + variable :: String -> a + getVariable :: Monad m => a -> m String + +instance WithVars Term where + variable = TVar + getVariable (TVar s) = return s + getVariable _ = fail "Common.Rewriting.getVariable" + +isVariable :: WithVars a => a -> Bool +isVariable = isJust . getVariable + +vars :: (Uniplate a, WithVars a) => a -> [String] +vars = concatMap getVariable . universe + +varSet :: (Uniplate a, WithVars a) => a -> S.Set String +varSet = S.fromList . vars + +hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool +hasVar i = (i `elem`) . vars + +withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool +withoutVar i = not . hasVar i + +hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool +hasSomeVar = not . hasNoVar + +hasNoVar :: (Uniplate a, WithVars a) => a -> Bool +hasNoVar = null . vars + +variableView :: WithVars a => View a String +variableView = makeView getVariable variable + +----------------------------------------------------------- +-- * Meta variables + +class WithMetaVars a where + metaVar :: Int -> a + getMetaVar :: Monad m => a -> m Int + +instance WithMetaVars Term where + metaVar = TMeta + getMetaVar (TMeta i) = return i + getMetaVar _ = fail "Common.Rewriting.getMetaVar" + +isMetaVar :: WithMetaVars a => a -> Bool +isMetaVar = isJust . getMetaVar + +metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int] +metaVars = concatMap getMetaVar . universe + +metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet +metaVarSet = IS.fromList . metaVars + +hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool +hasMetaVar i = (i `elem`) . metaVars + +----------------------------------------------------------- +-- * Utility functions + +getSpine :: Term -> (Term, [Term]) +getSpine = rec [] + where + rec xs (TApp f a) = rec (a:xs) f + rec xs a = (a, xs) + +makeTerm :: Term -> [Term] -> Term +makeTerm = foldl TApp + +----------------------------------------------------------- +-- * Arbitrary term generator + +instance Arbitrary Term where + arbitrary = generators + [ constGens $ map TVar ["x", "y", "z"] + , arbGen TNum, arbGen TFloat, arbGen TMeta + , constGens $ map (TCon . newSymbol) ["a", "b"] + , unaryGens $ map (unary . newSymbol) ["h", "k"] + , binaryGens $ map (binary . newSymbol) ["f", "g"] + ] diff --git a/src/Common/Rewriting/Unification.hs b/src/Common/Rewriting/Unification.hs --- a/src/Common/Rewriting/Unification.hs +++ b/src/Common/Rewriting/Unification.hs @@ -1,138 +1,141 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Rewriting.Unification - ( match, unifyM, specialLeft, specialRight - ) where - -import Common.Rewriting.Term -import Common.Rewriting.AC -import Common.Rewriting.Substitution -import Control.Monad - ------------------------------------------------------------ --- Unification (in both ways) - -unifyM :: Monad m => Term -> Term -> m Substitution -unifyM term1 term2 = - case (term1, term2) of - (Meta i, Meta j) | i == j -> - return emptySubst - (Meta i, _) | not (i `hasMetaVar` term2) -> - return (singletonSubst i term2) - (_, Meta j) | not (j `hasMetaVar` term1) -> - return (singletonSubst j term1) - (Apply f a, Apply g b) -> do - s1 <- unifyM f g - s2 <- unifyM (s1 |-> a) (s1 |-> b) - return (s1 @@ s2) - _ | term1 == term2 -> - return emptySubst - _ -> fail "unifyM: no unifier" - -{- -class ShallowEq a where - shallowEq :: a -> a -> Bool - --- The arbitrary type class is a quick solution to have smart generators --- (in combination with lifting rules). The function in the RewriteRule module --- cannot have a type class for this reason --- The show type class is added for pretty-printing rules -class (MetaVar a, Uniplate a, ShallowEq a, Arbitrary a, Show a) => Rewrite a where - operators :: [Operator a] - -- default definition: no associative/commutative operators - operators = [] - -unify :: Rewrite a => a -> a -> [Substitution a] -unify = unifyWith operators - -unifyM :: (MonadPlus m, Rewrite a) => a -> a -> m (Substitution a) -unifyM x y = msum $ map return $ unify x y - -unifyWith :: Rewrite a => [Operator a] -> a -> a -> [Substitution a] -unifyWith ops = rec - where - rec x y = - case (isMetaVar x, isMetaVar y) of - (Just i, Just j) | i==j -> return emptySubst - (Just i, _) | not (hasMetaVar i y) -> return $ singletonSubst i y - (_, Just j) | not (hasMetaVar j x) -> return $ singletonSubst j x - _ -> do - guard (shallowEq x y) - case findOperator ops x of - Just op -> - concatMap (uncurry recList . unzip) (pairings op x y) - Nothing -> - recList (children x) (children y) - - recList [] [] = return emptySubst - recList (x:xs) (y:ys) = do - s1 <- rec x y - s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) - return (s2 @@ s1) - recList _ _ = [] --} ------------------------------------------------------------ --- Matching (or: one-way unification) - --- second term should not have meta variables - -match :: [Symbol] -> Term -> Term -> [Substitution] -match assocSymbols = rec True - where - rec _ (Meta i) y = - return (singletonSubst i y) - - rec isTop x y = - case getSpine x of - (Con s, [a1, a2]) | s `elem` assocSymbols -> - concatMap (uncurry recList . unzip) (associativeMatch isTop s a1 a2 y) - (a, as) -> do - let (b, bs) = getSpine y - guard (a == b) - recList as bs - - recList [] [] = return emptySubst - recList (x:xs) (y:ys) = do - s1 <- rec False x y - s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) - return (s2 @@@ s1) - recList _ _ = [] - -associativeMatch :: Bool -> Symbol -> Term -> Term -> Term -> [[(Term, Term)]] -associativeMatch isTop s1 a1 a2 (Apply (Apply (Con s2) b1) b2) - | s1==s2 = map (map make) result - where - as = collect a1 . collect a2 $ [] - bs = collect b1 . collect b2 $ [] - list | isTop = map ($ as) [id, extLeft, extRight, extBoth] - | otherwise = [as] - - extLeft = (Meta specialLeft:) - extRight = (++[Meta specialRight]) - extBoth = extLeft . extRight - - result = concatMap (\zs -> pairingsA True zs bs) list - make (a, b) = (construct a, construct b) - - collect term = - case getFunction term of - Just (t, [a, b]) | s1==t -> collect a . collect b - _ -> (term:) - - construct xs - | null xs = error "associativeMatcher: empty list" - | otherwise = foldr1 (binary s1) xs -associativeMatch _ _ _ _ _ = [] - -specialLeft, specialRight :: Int -- special meta variables for context extension -specialLeft = maxBound -specialRight = pred specialLeft +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Unification + ( unify, match, matchA, specialLeft, specialRight + , unificationTests + ) where + +import Common.Rewriting.AC (pairingsA) +import Common.Rewriting.Substitution +import Common.Rewriting.Term +import Common.Utils.TestSuite +import Control.Arrow +import Control.Monad + +----------------------------------------------------------- +-- Unification (in both ways) + +unify :: Term -> Term -> Maybe Substitution +unify term1 term2 = + case (term1, term2) of + (TMeta i, TMeta j) | i == j -> + return emptySubst + (TMeta i, _) | not (i `hasMetaVar` term2) -> + return (singletonSubst i term2) + (_, TMeta j) | not (j `hasMetaVar` term1) -> + return (singletonSubst j term1) + (TApp f a, TApp g b) -> do + s1 <- unify f g + s2 <- unify (s1 |-> a) (s1 |-> b) + return (s2 @@ s1) + _ | term1 == term2 -> + return emptySubst + _ -> Nothing + +match :: MonadPlus m => Term -> Term -> m Substitution +match term1 term2 = + case (term1, term2) of + (TMeta i, TMeta j) | i == j -> + return emptySubst + (TMeta i, _) | not (i `hasMetaVar` term2) -> + return (singletonSubst i term2) + (_, TMeta _) -> + fail "unifyM: no unifier" + (TApp f a, TApp g b) -> do + s1 <- match f g + s2 <- match (s1 |-> a) b + guard (composable s1 s2) + return (s1 @@ s2) + _ | term1 == term2 -> + return emptySubst + _ -> fail "unifyM: no unifier" + +----------------------------------------------------------- +-- Matching (or: one-way unification) + +-- second term should not have meta variables + +matchA :: Term -> Term -> [Substitution] +matchA = rec True + where + rec _ (TMeta i) y = + return (singletonSubst i y) + + rec isTop x y = + case getSpine x of + (TCon s, [a1, a2]) | isAssociative s -> + concatMap (uncurry recList . unzip) (associativeMatch isTop s a1 a2 y) + (a, as) -> do + let (b, bs) = getSpine y + guard (a == b) + recList as bs + + recList [] [] = return emptySubst + recList (x:xs) (y:ys) = do + s1 <- rec False x y + s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) + return (s2 @@ s1) + recList _ _ = [] + +associativeMatch :: Bool -> Symbol -> Term -> Term -> Term -> [[(Term, Term)]] +associativeMatch isTop s1 a1 a2 (TApp (TApp (TCon s2) b1) b2) + | s1==s2 = map (map make) result + where + as = collect a1 . collect a2 $ [] + bs = collect b1 . collect b2 $ [] + list | isTop = map ($ as) [id, extLeft, extRight, extBoth] + | otherwise = [as] + + extLeft = (TMeta specialLeft:) + extRight = (++[TMeta specialRight]) + extBoth = extLeft . extRight + + result = concatMap (\zs -> pairingsA True zs bs) list + make = construct *** construct + + collect term = + case getFunction term of + Just (t, [a, b]) | s1==t -> collect a . collect b + _ -> (term:) + + construct xs + | null xs = error "associativeMatcher: empty list" + | otherwise = foldr1 (binary s1) xs +associativeMatch _ _ _ _ _ = [] + +specialLeft, specialRight :: Int -- special meta variables for context extension +specialLeft = maxBound +specialRight = pred specialLeft + +----------------------------------------------------------- +--- * Test unification properties + +unificationTests :: TestSuite +unificationTests = suite "Unification" $ do + addProperty "unify" $ \a b -> + case unify a b of + Just s -> (s |-> a) == (s |-> b) + Nothing -> True + addProperty "unify-succeed" $ \a s -> + let b = s |-> a in + case unify a b of + Just s2 -> (s2 |-> a) == (s2 |-> b) + Nothing -> False + addProperty "match" $ \a b -> + case match a b of + Just s -> (s |-> a) == b + Nothing -> True + addProperty "match-succeed" $ \a s -> + let b = s |-> a in + case match a (s |-> a) of + Just s2 -> (s2 |-> a) == b + Nothing -> True diff --git a/src/Common/Strategy.hs b/src/Common/Strategy.hs --- a/src/Common/Strategy.hs +++ b/src/Common/Strategy.hs @@ -1,52 +1,54 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A strategy is a context-free grammar with rules as symbols. Strategies can be --- labeled with strings. A type class is introduced to lift all the combinators --- that work on strategies, only to prevent that you have to insert these lifting --- functions yourself. --- ------------------------------------------------------------------------------ -module Common.Strategy - ( -- * Data types and type classes - Strategy, LabeledStrategy - , IsStrategy(..) - -- * Running strategies - , fullDerivationTree, derivationTree - -- * Strategy combinators - -- ** Basic combinators - , (<*>), (<|>), succeed, fail, label, sequence, alternatives - -- ** EBNF combinators - , many, many1, replicate, option - -- ** Negation and greedy combinators - , check, not, repeat, repeat1, try, (|>), exhaustive - , while, until, multi - -- ** Traversal combinators - , fix, once, somewhere, topDown, bottomUp - , onceWith, somewhereWith - -- * Configuration combinators - , module Common.Strategy.Configuration - -- * Strategy locations - , strategyLocations, subStrategy - , subTaskLocation, nextTaskLocation - -- * Prefixes - , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..) - , prefixToSteps, stepsToRules, lastStepInPrefix - -- * Misc - , cleanUpStrategy, rulesInStrategy, mapRules, mapRulesS - ) where - -import Common.Strategy.Abstract -import Common.Strategy.Combinators -import Common.Strategy.Prefix -import Common.Strategy.Location -import Common.Strategy.Configuration -import Common.Strategy.Parsing +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A strategy is a context-free grammar with rules as symbols. Strategies can be +-- labeled with strings. A type class is introduced to lift all the combinators +-- that work on strategies, only to prevent that you have to insert these lifting +-- functions yourself. +-- +----------------------------------------------------------------------------- +module Common.Strategy + ( -- * Data types and type classes + Strategy, LabeledStrategy + , IsStrategy(..) + -- * Running strategies + , fullDerivationTree, derivationTree + -- * Strategy combinators + -- ** Basic combinators + , (<*>), (<|>), (<%>), succeed, fail, atomic, label + , sequence, alternatives, interleave, permute + -- ** EBNF combinators + , many, many1, replicate, option + -- ** Negation and greedy combinators + , check, not, repeat, repeat1, try, (|>), exhaustive + , while, until, multi + -- ** Traversal combinators + , fix, once, somewhere, topDown, bottomUp + , onceWith, somewhereWith + -- * Configuration combinators + , module Common.Strategy.Configuration + -- * Strategy locations + , strategyLocations, subStrategy + , subTaskLocation, nextTaskLocation + -- * Prefixes + , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..) + , prefixToSteps, stepsToRules, lastStepInPrefix + -- * Misc + , cleanUpStrategy, cleanUpStrategyAfter + , rulesInStrategy, mapRules, mapRulesS + ) where + +import Common.Strategy.Abstract +import Common.Strategy.Combinators +import Common.Strategy.Configuration +import Common.Strategy.Location +import Common.Strategy.Parsing +import Common.Strategy.Prefix import Prelude () 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,214 +1,236 @@ -{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Strategy.Abstract - ( Strategy, IsStrategy(..) - , LabeledStrategy, label, unlabel - , fullDerivationTree, derivationTree, rulesInStrategy - , mapRules, mapRulesS, cleanUpStrategy - -- Accessors to the underlying representation - , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy - , toLabeledStrategy - , LabelInfo, processLabelInfo, changeInfo, makeInfo - , removed, collapsed, hidden, IsLabeled(..) - ) where - -import Common.Id -import Common.Utils (commaList) -import Common.Strategy.Core -import Common.Classes -import Common.Rewriting (RewriteRule) -import Common.Transformation -import Common.Derivation -import Common.Uniplate hiding (rewriteM) -import Common.Strategy.Parsing - ------------------------------------------------------------ ---- Strategy data-type - --- | Abstract data type for strategies -newtype Strategy a = S { toCore :: Core LabelInfo a } - -instance Show (Strategy a) where - show = show . toCore - -instance Apply Strategy where - applyAll = runCore . toCore - ------------------------------------------------------------ ---- The information used as label in a strategy - -data LabelInfo = Info - { labelId :: Id - , removed :: Bool - , collapsed :: Bool - , hidden :: Bool - } - -instance Show LabelInfo where - show info = - let ps = ["removed" | removed info] ++ - ["collapsed" | collapsed info] ++ - ["hidden" | hidden info] - extra = " (" ++ commaList ps ++ ")" - in showId info ++ if null ps then "" else extra - -instance HasId LabelInfo where - getId = labelId - changeId f info = info { labelId = f (labelId info) } - -makeInfo :: IsId a => a -> LabelInfo -makeInfo s = Info (newId s) False False False - ------------------------------------------------------------ ---- Type class - --- | Type class to turn values into strategies -class IsStrategy f where - toStrategy :: f a -> Strategy a - -instance IsStrategy (Core LabelInfo) where - toStrategy = S - -instance IsStrategy Strategy where - toStrategy = id - -instance IsStrategy (LabeledStrategy) where - toStrategy (LS info (S core)) = S (Label info core) - -instance IsStrategy Rule where - toStrategy r - | isMajorRule r = toStrategy (toLabeled r) - | otherwise = S (Rule r) - -instance IsStrategy RewriteRule where - toStrategy r = - toStrategy (makeRule (getId r) (makeRewriteTrans r)) - ------------------------------------------------------------ ---- Labeled Strategy data-type - --- | A strategy which is labeled with a string -data LabeledStrategy a = LS - { labelInfo :: LabelInfo -- ^ Returns information associated with this label - , unlabel :: Strategy a -- ^ Removes the label from a strategy - } - -makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a -makeLabeledStrategy info = LS info . toStrategy - -toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a) -toLabeledStrategy s = - case toCore s of - Label l c -> return (makeLabeledStrategy l (fromCore c)) - _ -> fail "Strategy without label" - -instance Show (LabeledStrategy a) where - show s = show (labelInfo s) ++ ": " ++ show (unlabel s) - -instance Apply LabeledStrategy where - applyAll = applyAll . toStrategy - -instance HasId (LabeledStrategy a) where - getId = getId . labelInfo - changeId = changeInfo . changeId - -class IsLabeled f where - toLabeled :: f a -> LabeledStrategy a - -instance IsLabeled LabeledStrategy where - toLabeled = id - -instance IsLabeled Rule where - toLabeled r = LS (makeInfo (showId r)) (S (Rule r)) - -instance IsLabeled RewriteRule where - toLabeled r = toLabeled (makeRule (showId r) (makeRewriteTrans r)) - --- | Labels a strategy with a string -label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a -label l = LS (makeInfo l) . toStrategy - -changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a -changeInfo f a = LS (f info) s - where LS info s = toLabeled a - ------------------------------------------------------------ ---- Process Label Information - -processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a -processLabelInfo getInfo = rec emptyCoreEnv - where - rec env core = - case core of - Rec n a -> Rec n (rec (insertCoreEnv n core env) a) - Label l a -> forLabel env l (rec env a) - _ -> descend (rec env) core - - forLabel env l c - | removed info = Fail - | collapsed info = Label l (Rule asRule) -- !! - | otherwise = new - where - new | hidden info = mapRule minorRule (Label l c) - | otherwise = Label l c - info = getInfo l - asRule = makeSimpleRuleList (showId info{- ++ " (collapsed)"-}) - (runCoreWith env new) - ------------------------------------------------------------ ---- Remaining functions - --- | Returns the derivation tree for a strategy and a term, including all --- minor rules -fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a -fullDerivationTree = make . processLabelInfo id . toCore . toStrategy - where - make core = fmap value . parseDerivationTree . makeState core - --- | Returns the derivation tree for a strategy and a term with only major rules -derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a -derivationTree s = mergeMaybeSteps . mapSteps f . fullDerivationTree s - where - f (RuleStep r) | isMajorRule r = Just r - f _ = Nothing - --- | Returns a list of all major rules that are part of a labeled strategy -rulesInStrategy :: IsStrategy f => f a -> [Rule a] -rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajorRule r ] - --- | Apply a function to all the rules that make up a labeled strategy -mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b -mapRules f (LS n s) = LS n (mapRulesS f s) - -mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b -mapRulesS f = S . mapRule f . toCore - --- | Use a function as do-after hook for all rules in a labeled strategy -cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a -cleanUpStrategy f (LS n s) = mapRules g (LS n (S core)) - where - core = Rule (doAfter f idRule) :*: toCore s - g r | isMajorRule r = doAfter f r - | otherwise = r - ------------------------------------------------------------ ---- Functions to lift the core combinators - -fromCore :: Core LabelInfo a -> Strategy a -fromCore = toStrategy - -liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a -liftCore f = fromCore . f . toCore . toStrategy - -liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Strategy.Abstract + ( Strategy, IsStrategy(..) + , LabeledStrategy, label, unlabel + , fullDerivationTree, derivationTree, rulesInStrategy + , mapRules, mapRulesS, mapRulesM, cleanUpStrategy, cleanUpStrategyAfter + -- Accessors to the underlying representation + , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy + , toLabeledStrategy + , LabelInfo, processLabelInfo, changeInfo, makeInfo + , removed, collapsed, hidden, IsLabeled(..), noInterleaving + ) where + +import Common.Classes +import Common.DerivationTree +import Common.Id +import Common.Rewriting (RewriteRule) +import Common.Strategy.Core +import Common.Strategy.Parsing +import Common.Transformation +import Common.Utils (commaList) +import Common.Utils.Uniplate hiding (rewriteM) +import Control.Monad +import Test.QuickCheck hiding (label) +import qualified Data.Traversable as T + +----------------------------------------------------------- +--- Strategy data-type + +-- | Abstract data type for strategies +newtype Strategy a = S { toCore :: Core LabelInfo a } + +instance Show (Strategy a) where + show = show . toCore + +instance Apply Strategy where + applyAll = runCore . toCore + +instance (Arbitrary a, CoArbitrary a) => Arbitrary (Strategy a) where + arbitrary = liftM fromCore arbitrary + +----------------------------------------------------------- +--- The information used as label in a strategy + +data LabelInfo = Info + { labelId :: Id + , removed :: Bool + , collapsed :: Bool + , hidden :: Bool + } + deriving (Eq, Ord) + +instance Show LabelInfo where + show info = + let ps = ["removed" | removed info] ++ + ["collapsed" | collapsed info] ++ + ["hidden" | hidden info] + extra = " (" ++ commaList ps ++ ")" + in showId info ++ if null ps then "" else extra + +instance HasId LabelInfo where + getId = labelId + changeId f info = info { labelId = f (labelId info) } + +instance Arbitrary LabelInfo where + arbitrary = liftM (makeInfo :: Id -> LabelInfo) arbitrary + +makeInfo :: IsId a => a -> LabelInfo +makeInfo s = Info (newId s) False False False + +----------------------------------------------------------- +--- Type class + +-- | Type class to turn values into strategies +class IsStrategy f where + toStrategy :: f a -> Strategy a + +instance IsStrategy Strategy where + toStrategy = id + +instance IsStrategy (LabeledStrategy) where + toStrategy (LS info (S core)) = S (Label info core) + +instance IsStrategy Rule where + toStrategy r + | isMajorRule r = toStrategy (toLabeled r) + | otherwise = S (Rule r) + +instance IsStrategy RewriteRule where + toStrategy r = + toStrategy (makeRule (getId r) (makeRewriteTrans r)) + +----------------------------------------------------------- +--- Labeled Strategy data-type + +-- | A strategy which is labeled with a string +data LabeledStrategy a = LS + { labelInfo :: LabelInfo -- ^ Returns information associated with this label + , unlabel :: Strategy a -- ^ Removes the label from a strategy + } + +makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a +makeLabeledStrategy info = LS info . toStrategy + +toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a) +toLabeledStrategy s = + case toCore s of + Label l c -> return (makeLabeledStrategy l (fromCore c)) + _ -> fail "Strategy without label" + +instance Show (LabeledStrategy a) where + show s = show (labelInfo s) ++ ": " ++ show (unlabel s) + +instance Apply LabeledStrategy where + applyAll = applyAll . toStrategy + +instance HasId (LabeledStrategy a) where + getId = getId . labelInfo + changeId = changeInfo . changeId + +class IsLabeled f where + toLabeled :: f a -> LabeledStrategy a + +instance IsLabeled LabeledStrategy where + toLabeled = id + +instance IsLabeled Rule where + toLabeled r = LS (makeInfo (getId r)) (S (Rule r)) + +instance IsLabeled RewriteRule where + toLabeled r = toLabeled (makeRule (getId r) (makeRewriteTrans r)) + +-- | Labels a strategy with a string +label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a +label l = LS (makeInfo l) . toStrategy + +changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a +changeInfo f a = LS (f info) s + where LS info s = toLabeled a + +----------------------------------------------------------- +--- Process Label Information + +processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a +processLabelInfo getInfo = rec [] + where + rec env core = + case core of + Rec n a -> Rec n (rec ((n, core):env) a) + Label l a -> forLabel env l (rec env a) + _ -> descend (rec env) core + + forLabel env l c + | removed info = Fail + | collapsed info = Label l (Rule asRule) -- !! + | otherwise = new + where + new | hidden info = fmap minorRule (Label l c) + | otherwise = Label l c + info = getInfo l + asRule = makeSimpleRuleList (getId info) (runCore (subst new)) + subst = flip (foldl (flip (uncurry substCoreVar))) env + +----------------------------------------------------------- +--- Remaining functions + +-- | Returns the derivation tree for a strategy and a term, including all +-- minor rules +fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a +fullDerivationTree = make . processLabelInfo id . toCore . toStrategy + where + make core = fmap value . parseDerivationTree . makeState core + +-- | Returns the derivation tree for a strategy and a term with only major rules +derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a +derivationTree s = mergeMaybeSteps . mapFirst f . fullDerivationTree s + where + f (RuleStep r) | isMajorRule r = Just r + f _ = Nothing + +-- | Returns a list of all major rules that are part of a labeled strategy +rulesInStrategy :: IsStrategy f => f a -> [Rule a] +rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajorRule r ] + +-- | Apply a function to all the rules that make up a labeled strategy +mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b +mapRules f (LS n s) = LS n (mapRulesS f s) + +mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b +mapRulesS f = S . fmap f . toCore + +mapRulesM :: Monad m => (Rule a -> m (Rule a)) -> Strategy a -> m (Strategy a) +mapRulesM f = liftM S . T.mapM f . toCore + +-- | Use a function as do-after hook for all rules in a labeled strategy, but +-- also use the function beforehand +cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a +cleanUpStrategy f (LS n s) = cleanUpStrategyAfter f (LS n (make s)) + where + make = liftCore2 (.*.) (doAfter f idRule) + +-- | Use a function as do-after hook for all rules in a labeled strategy +cleanUpStrategyAfter :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a +cleanUpStrategyAfter f = mapRules $ \r -> + if isMajorRule r then doAfter f r else r + +noInterleaving :: IsStrategy f => f a -> Strategy a +noInterleaving = liftCore $ transform f + where + f (a :%: b) = a :*: b + f (a :!%: b) = a :*: b + f (Atomic a) = a + f s = s + +----------------------------------------------------------- +--- Functions to lift the core combinators + +fromCore :: Core LabelInfo a -> Strategy a +fromCore = S + +liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a +liftCore f = fromCore . f . toCore . toStrategy + +liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a liftCore2 f = liftCore . f . toCore . toStrategy 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 @@ -1,176 +1,183 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A collection of strategy combinators: all lifted to work on different --- data types --- ------------------------------------------------------------------------------ -module Common.Strategy.Combinators where - -import qualified Prelude -import Prelude hiding (not, repeat, fail, sequence) -import Common.Id -import Common.Context -import Common.Navigator -import Common.Transformation -import Common.Strategy.Core -import Common.Strategy.Abstract -import Common.Strategy.Configuration -import Data.Maybe - ------------------------------------------------------------ ---- Strategy combinators - --- Basic combinators -------------------------------------- - -infixr 3 <|> -infixr 4 |> -infixr 5 <*> - --- | Put two strategies in sequence (first do this, then do that) -(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<*>) = liftCore2 $ \x y -> - case (x, y) of - (Succeed, _) -> y - (_, Succeed) -> x - (Fail, _) -> Fail - (_, Fail) -> Fail - _ -> x :*: y - --- | Choose between the two strategies (either do this or do that) -(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<|>) = liftCore2 $ \x y -> - case (x, y) of - (Fail, _) -> y - (_, Fail) -> x - _ -> x :|: y - --- | The strategy that always succeeds (without doing anything) -succeed :: Strategy a -succeed = fromCore Succeed - --- | The strategy that always fails -fail :: Strategy a -fail = fromCore Fail - --- | Puts a list of strategies into a sequence -sequence :: IsStrategy f => [f a] -> Strategy a -sequence = foldr ((<*>) . toStrategy) succeed - --- | Combines a list of alternative strategies -alternatives :: IsStrategy f => [f a] -> Strategy a -alternatives = foldr ((<|>) . toStrategy) fail - --- EBNF combinators -------------------------------------- - --- | Repeat a strategy zero or more times (non-greedy) -many :: IsStrategy f => f a -> Strategy a -many = liftCore Many - --- | Apply a certain strategy at least once (non-greedy) -many1 :: IsStrategy f => f a -> Strategy a -many1 s = s <*> many s - --- | Apply a strategy a certain number of times -replicate :: IsStrategy f => Int -> f a -> Strategy a -replicate n = sequence . Prelude.replicate n - --- | Apply a certain strategy or do nothing (non-greedy) -option :: IsStrategy f => f a -> Strategy a -option s = s <|> succeed - --- Negation and greedy combinators ---------------------- - --- | Checks whether a predicate holds for the current term. The --- check is considered to be a minor step. -check :: (a -> Bool) -> Strategy a -check p = toStrategy (checkRule p) - --- | Check whether or not the argument strategy cannot be applied: the result --- strategy only succeeds if this is not the case (otherwise it fails). -not :: IsStrategy f => f a -> Strategy a -not = liftCore (Not . noLabels) - --- | Repeat a strategy zero or more times (greedy version of 'many') -repeat :: IsStrategy f => f a -> Strategy a -repeat = liftCore Repeat - --- | Apply a certain strategy at least once (greedy version of 'many1') -repeat1 :: IsStrategy f => f a -> Strategy a -repeat1 s = s <*> repeat s - --- | Apply a certain strategy if this is possible (greedy version of 'option') -try :: IsStrategy f => f a -> Strategy a -try s = s |> succeed - --- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise, --- try the right-operand strategy -(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(|>) = liftCore2 (:|>:) - --- | Repeat the strategy as long as the predicate holds -while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a -while p s = repeat (check p <*> s) - --- | Repeat the strategy until the predicate holds -until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a -until p = while (Prelude.not . p) - --- | Apply a strategy at least once, but collapse into a single step -multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a -multi s = collapse . label s . repeat1 - --- | Apply the strategies from the list exhaustively (until this is no longer possible) -exhaustive :: IsStrategy f => [f a] -> Strategy a -exhaustive = repeat . alternatives - --- Traversal combinators -------------------------------------------- - --- | A fix-point combinator on strategies (to model recursion). Powerful --- (but dangerous) combinator -fix :: (Strategy a -> Strategy a) -> Strategy a -fix f = fromCore (coreFix (toCore . f . fromCore)) - --- | Apply a strategy on (exactly) one of the term's direct children. The --- function selects which children are visited. -onceWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a) -onceWith n f s = ruleMoveDown <*> s <*> ruleMoveUp - where - ruleMoveDown = minorRule $ makeSimpleRuleList ("navigation.down." ++ n) $ \a -> - concatMap (`down` a) (f a) - ruleMoveUp = minorRule $ makeSimpleRule "navigation.up" $ \a -> - Just (fromMaybe a (up a)) - --- | Apply a strategy somewhere in the term. The function selects which --- children are visited -somewhereWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a) -somewhereWith n f s = fix $ \this -> s <|> onceWith n f this - --- | Apply a strategy on (exactly) one of the term's direct children -once :: IsStrategy f => f (Context a) -> Strategy (Context a) -once = onceWith "all" visitAll - --- | Apply a strategy somewhere in the term -somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a) -somewhere = somewhereWith "all" visitAll - --- local helper -visitAll :: Context a -> [Int] -visitAll a = [ 0 .. arity a-1 ] - --- | Search for a suitable location in the term to apply the strategy using a --- top-down approach -topDown :: IsStrategy f => f (Context a) -> Strategy (Context a) -topDown s = fix $ \this -> s |> once this - --- | Search for a suitable location in the term to apply the strategy using a --- bottom-up approach -bottomUp :: IsStrategy f => f (Context a) -> Strategy (Context a) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A collection of strategy combinators: all lifted to work on different +-- data types +-- +----------------------------------------------------------------------------- +module Common.Strategy.Combinators where + +import Common.Context +import Common.Id +import Common.Navigator +import Common.Strategy.Abstract +import Common.Strategy.Configuration +import Common.Strategy.Core +import Common.Transformation +import Data.Maybe +import Prelude hiding (not, repeat, fail, sequence) +import qualified Prelude + +----------------------------------------------------------- +--- Strategy combinators + +-- Basic combinators -------------------------------------- + +infixr 2 <%> +infixr 3 <|> +infixr 4 |> +infixr 5 <*> + +-- | Put two strategies in sequence (first do this, then do that) +(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(<*>) = liftCore2 (.*.) + +-- | Choose between the two strategies (either do this or do that) +(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(<|>) = liftCore2 (.|.) + +-- | Interleave two strategies +(<%>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(<%>) = liftCore2 (.%.) + +-- | The strategy that always succeeds (without doing anything) +succeed :: Strategy a +succeed = fromCore Succeed + +-- | The strategy that always fails +fail :: Strategy a +fail = fromCore Fail + +-- | Makes a strategy atomic (w.r.t. parallel composition) +atomic :: IsStrategy f => f a -> Strategy a +atomic = liftCore Atomic + +-- | Puts a list of strategies into a sequence +sequence :: IsStrategy f => [f a] -> Strategy a +sequence = foldr ((<*>) . toStrategy) succeed + +-- | Combines a list of alternative strategies +alternatives :: IsStrategy f => [f a] -> Strategy a +alternatives = foldr ((<|>) . toStrategy) fail + +-- | Merges a list of strategies (in parallel) +interleave :: IsStrategy f => [f a] -> Strategy a +interleave = foldr ((<%>) . toStrategy) succeed + +-- | Allows all permutations of the list +permute :: IsStrategy f => [f a] -> Strategy a +permute = foldr ((<%>) . atomic) succeed + +-- EBNF combinators -------------------------------------- + +-- | Repeat a strategy zero or more times (non-greedy) +many :: IsStrategy f => f a -> Strategy a +many = liftCore Many + +-- | Apply a certain strategy at least once (non-greedy) +many1 :: IsStrategy f => f a -> Strategy a +many1 s = s <*> many s + +-- | Apply a strategy a certain number of times +replicate :: IsStrategy f => Int -> f a -> Strategy a +replicate n = sequence . Prelude.replicate n + +-- | Apply a certain strategy or do nothing (non-greedy) +option :: IsStrategy f => f a -> Strategy a +option s = s <|> succeed + +-- Negation and greedy combinators ---------------------- + +-- | Checks whether a predicate holds for the current term. The +-- check is considered to be a minor step. +check :: (a -> Bool) -> Strategy a +check p = toStrategy (checkRule p) + +-- | Check whether or not the argument strategy cannot be applied: the result +-- strategy only succeeds if this is not the case (otherwise it fails). +not :: IsStrategy f => f a -> Strategy a +not = liftCore (Not . noLabels) + +-- | Repeat a strategy zero or more times (greedy version of 'many') +repeat :: IsStrategy f => f a -> Strategy a +repeat = liftCore Repeat + +-- | Apply a certain strategy at least once (greedy version of 'many1') +repeat1 :: IsStrategy f => f a -> Strategy a +repeat1 s = s <*> repeat s + +-- | Apply a certain strategy if this is possible (greedy version of 'option') +try :: IsStrategy f => f a -> Strategy a +try s = s |> succeed + +-- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise, +-- try the right-operand strategy +(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(|>) = liftCore2 (:|>:) + +-- | Repeat the strategy as long as the predicate holds +while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a +while p s = repeat (check p <*> s) + +-- | Repeat the strategy until the predicate holds +until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a +until p = while (Prelude.not . p) + +-- | Apply a strategy at least once, but collapse into a single step +multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a +multi s = collapse . label s . repeat1 + +-- | Apply the strategies from the list exhaustively (until this is no longer possible) +exhaustive :: IsStrategy f => [f a] -> Strategy a +exhaustive = repeat . alternatives + +-- Traversal combinators -------------------------------------------- + +-- | A fix-point combinator on strategies (to model recursion). Powerful +-- (but dangerous) combinator +fix :: (Strategy a -> Strategy a) -> Strategy a +fix f = fromCore (coreFix (toCore . f . fromCore)) + +-- | Apply a strategy on (exactly) one of the term's direct children. The +-- function selects which children are visited. +onceWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a) +onceWith n f s = ruleMoveDown <*> s <*> ruleMoveUp + where + ruleMoveDown = minorRule $ makeSimpleRuleList ("navigation.down." ++ n) $ \a -> + concatMap (`down` a) (f a) + ruleMoveUp = minorRule $ makeSimpleRule "navigation.up" $ \a -> + Just (fromMaybe a (up a)) + +-- | Apply a strategy somewhere in the term. The function selects which +-- children are visited +somewhereWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a) +somewhereWith n f s = fix $ \this -> s <|> onceWith n f this + +-- | Apply a strategy on (exactly) one of the term's direct children +once :: IsStrategy f => f (Context a) -> Strategy (Context a) +once = onceWith "all" visitAll + +-- | Apply a strategy somewhere in the term +somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a) +somewhere = somewhereWith "all" visitAll + +-- local helper +visitAll :: Context a -> [Int] +visitAll a = [ 0 .. arity a-1 ] + +-- | Search for a suitable location in the term to apply the strategy using a +-- top-down approach +topDown :: IsStrategy f => f (Context a) -> Strategy (Context a) +topDown s = fix $ \this -> s |> once this + +-- | Search for a suitable location in the term to apply the strategy using a +-- bottom-up approach +bottomUp :: IsStrategy f => f (Context a) -> Strategy (Context a) bottomUp s = fix $ \this -> once this |> s 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 @@ -1,108 +1,109 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Common.Strategy.Configuration - ( -- Types and constructors - StrategyConfiguration, ConfigItem - , ConfigLocation, byName, byGroup - , ConfigAction(..), configActions - -- Configure - , configure, configureNow - -- Combinators - , remove, reinsert, collapse, expand, hide, reveal - ) where - -import Common.Id -import Common.Strategy.Abstract -import Common.Strategy.Core -import Data.Maybe - ---------------------------------------------------------------------- --- Types and constructors - -type StrategyConfiguration = [ConfigItem] -type ConfigItem = (ConfigLocation, ConfigAction) - -data ConfigLocation - = ByName Id - | ByGroup Id - deriving Show - -data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal - deriving (Show, Enum) - -configActions :: [ConfigAction] -configActions = [Remove .. ] - -byName :: HasId a => a -> ConfigLocation -byName = ByName . getId - -byGroup :: HasId a => a -> ConfigLocation -byGroup = ByGroup . getId - ---------------------------------------------------------------------- --- Configure - -configureNow :: LabeledStrategy a -> LabeledStrategy a -configureNow = - let lsToCore = toCore . toStrategy - coreToLS = fromMaybe err . toLabeledStrategy . toStrategy - err = error "configureNow: label disappeared" - in coreToLS . processLabelInfo id . lsToCore - -configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a -configure cfg ls = - label (showId ls) (configureCore cfg (toCore (unlabel ls))) - -configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a -configureCore cfg = mapLabel (change []) - where - change groups info = - let actions = getActions info groups cfg - in foldr doAction info actions - -getActions :: LabelInfo -> [String] - -> StrategyConfiguration -> [ConfigAction] -getActions info groups = map snd . filter (select . fst) - where - select (ByName a) = getId info == a - select (ByGroup s) = showId s `elem` groups - -doAction :: ConfigAction -> LabelInfo -> LabelInfo -doAction action = - case action of - Remove -> setRemoved True - Reinsert -> setRemoved False - Collapse -> setCollapsed True - Expand -> setCollapsed False - Hide -> setHidden True - Reveal -> setHidden False - ---------------------------------------------------------------------- --- Configuration combinators - -remove, reinsert :: IsLabeled f => f a -> LabeledStrategy a -remove = changeInfo (doAction Remove) -reinsert = changeInfo (doAction Reinsert) - -collapse, expand :: IsLabeled f => f a -> LabeledStrategy a -collapse = changeInfo (doAction Collapse) -expand = changeInfo (doAction Expand) - -hide, reveal :: IsLabeled f => f a -> LabeledStrategy a -hide = changeInfo (doAction Hide) -reveal = changeInfo (doAction Reveal) - --- helpers -setRemoved, setCollapsed, setHidden :: Bool -> LabelInfo -> LabelInfo -setRemoved b info = info {removed = b} -setCollapsed b info = info {collapsed = b} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Strategy.Configuration + ( -- Types and constructors + StrategyConfiguration, ConfigItem + , ConfigLocation, byName, byGroup + , ConfigAction(..), configActions + -- Configure + , configure, configureNow + -- Combinators + , remove, reinsert, collapse, expand, hide, reveal + ) where + +import Common.Classes +import Common.Id +import Common.Strategy.Abstract +import Common.Strategy.Core +import Data.Maybe + +--------------------------------------------------------------------- +-- Types and constructors + +type StrategyConfiguration = [ConfigItem] +type ConfigItem = (ConfigLocation, ConfigAction) + +data ConfigLocation + = ByName Id + | ByGroup Id + deriving Show + +data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal + deriving (Show, Enum) + +configActions :: [ConfigAction] +configActions = [Remove .. ] + +byName :: HasId a => a -> ConfigLocation +byName = ByName . getId + +byGroup :: HasId a => a -> ConfigLocation +byGroup = ByGroup . getId + +--------------------------------------------------------------------- +-- Configure + +configureNow :: LabeledStrategy a -> LabeledStrategy a +configureNow = + let lsToCore = toCore . toStrategy + coreToLS = fromMaybe err . toLabeledStrategy . fromCore + err = error "configureNow: label disappeared" + in coreToLS . processLabelInfo id . lsToCore + +configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a +configure cfg ls = + label (getId ls) (fromCore (configureCore cfg (toCore (unlabel ls)))) + +configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a +configureCore cfg = mapFirst (change []) + where + change groups info = + let actions = getActions info groups cfg + in foldr doAction info actions + +getActions :: LabelInfo -> [String] + -> StrategyConfiguration -> [ConfigAction] +getActions info groups = map snd . filter (select . fst) + where + select (ByName a) = getId info == a + select (ByGroup s) = showId s `elem` groups + +doAction :: ConfigAction -> LabelInfo -> LabelInfo +doAction action = + case action of + Remove -> setRemoved True + Reinsert -> setRemoved False + Collapse -> setCollapsed True + Expand -> setCollapsed False + Hide -> setHidden True + Reveal -> setHidden False + +--------------------------------------------------------------------- +-- Configuration combinators + +remove, reinsert :: IsLabeled f => f a -> LabeledStrategy a +remove = changeInfo (doAction Remove) +reinsert = changeInfo (doAction Reinsert) + +collapse, expand :: IsLabeled f => f a -> LabeledStrategy a +collapse = changeInfo (doAction Collapse) +expand = changeInfo (doAction Expand) + +hide, reveal :: IsLabeled f => f a -> LabeledStrategy a +hide = changeInfo (doAction Hide) +reveal = changeInfo (doAction Reveal) + +-- helpers +setRemoved, setCollapsed, setHidden :: Bool -> LabelInfo -> LabelInfo +setRemoved b info = info {removed = b} +setCollapsed b info = info {collapsed = b} setHidden b info = info {hidden = b} 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 @@ -1,151 +1,199 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- The core strategy combinators. This module defines the interal data --- structure of a strategy, and some utility functions that operate --- directly on it. --- ------------------------------------------------------------------------------ -module Common.Strategy.Core - ( Core(..) - , mapRule, mapLabel, noLabels - , coreMany, coreRepeat, coreOrElse, coreFix - , CoreEnv, emptyCoreEnv, insertCoreEnv, lookupCoreEnv, substCoreEnv - ) where - -import Common.Transformation -import Common.Uniplate -import Data.Maybe -import qualified Data.IntMap as IM - ------------------------------------------------------------------ --- Strategy (internal) data structure, containing a selection --- of combinators - -infixr 3 :|:, :|>: -infixr 5 :*: - --- Some rules receive label (but not all) -data Core l a - = Core l a :*: Core l a - | Core l a :|: Core l a - | Core l a :|>: Core l a - | Many (Core l a) - | Repeat (Core l a) - | Not (Core l a) - | Label l (Core l a) - | Succeed - | Fail - | Rule (Rule a) - | Var Int - | Rec Int (Core l a) - deriving Show - ------------------------------------------------------------------ --- Useful instances - -instance Uniplate (Core l a) where - uniplate core = - case core of - a :*: b -> ([a,b], \[x,y] -> x :*: y) - a :|: b -> ([a,b], \[x,y] -> x :|: y) - a :|>: b -> ([a,b], \[x,y] -> x :|>: y) - Many a -> ([a], \[x] -> Many x) - Repeat a -> ([a], \[x] -> Repeat x) - Label l a -> ([a], \[x] -> Label l x) - Rec n a -> ([a], \[x] -> Rec n x) - Not a -> ([a], \[x] -> Not x) - _ -> ([], \_ -> core) - ------------------------------------------------------------------ --- Core environment - -newtype CoreEnv l a = CE (IM.IntMap (Core l a)) - -emptyCoreEnv :: CoreEnv l a -emptyCoreEnv = CE IM.empty - -insertCoreEnv :: Int -> Core l a -> CoreEnv l a -> CoreEnv l a -insertCoreEnv n a (CE m) = CE (IM.insert n a m) - -deleteCoreEnv :: Int -> CoreEnv l a -> CoreEnv l a -deleteCoreEnv n (CE m) = CE (IM.delete n m) - -lookupCoreEnv :: Int -> CoreEnv l a -> Maybe (Core l a) -lookupCoreEnv n (CE m) = IM.lookup n m - -substCoreEnv :: CoreEnv l a -> Core l a -> Core l a -substCoreEnv env core = - case core of - Var i -> fromMaybe core (lookupCoreEnv i env) - Rec i a -> Rec i (substCoreEnv (deleteCoreEnv i env) a) - _ -> descend (substCoreEnv env) core - ------------------------------------------------------------------ --- Definitions - -coreMany :: Core l a -> Core l a -coreMany a = Rec n (Succeed :|: (a :*: Var n)) - where n = nextVar a - -coreRepeat :: Core l a -> Core l a -coreRepeat a = Many a :*: Not a - -coreOrElse :: Core l a -> Core l a -> Core l a -coreOrElse a b = a :|: (Not a :*: b) - -coreFix :: (Core l a -> Core l a) -> Core l a -coreFix f = -- disadvantage: function f is applied twice - let i = nextVar (f (Var (-1))) - in Rec i (f (Var i)) - -nextVar :: Core l a -> Int -nextVar p - | null xs = 0 - | otherwise = maximum xs + 1 - where xs = coreVars p - -coreVars :: Core l a -> [Int] -coreVars core = - case core of - Var n -> [n] - Rec n a -> n : coreVars a - _ -> concatMap coreVars (children core) - ------------------------------------------------------------------ --- Utility functions - -mapLabel :: (l -> m) -> Core l a -> Core m a -mapLabel f = mapCore (Label . f) Rule - -mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b -mapRule f = mapCore Label (Rule . f) - -noLabels :: Core l a -> Core m a -noLabels = mapCore (const id) Rule - -mapCore :: (l -> Core m b -> Core m b) -> (Rule a -> Core m b) - -> Core l a -> Core m b -mapCore f g = rec - where - rec core = - case core of - a :*: b -> rec a :*: rec b - a :|: b -> rec a :|: rec b - a :|>: b -> rec a :|>: rec b - Many a -> Many (rec a) - Repeat a -> Repeat (rec a) - Succeed -> Succeed - Fail -> Fail - Label l a -> f l (rec a) - Rule r -> g r - Var n -> Var n - Rec n a -> Rec n (rec a) - Not a -> Not (rec a) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- The core strategy combinators. This module defines the interal data +-- structure of a strategy, and some utility functions that operate +-- directly on it. +-- +----------------------------------------------------------------------------- +module Common.Strategy.Core + ( GCore(..), Core + , (.|.), (.*.), (.%.) + , coreMany, coreRepeat, coreOrElse, coreFix + , noLabels, substCoreVar + ) where + +import Common.Classes +import Common.Transformation +import Common.Utils.QuickCheck +import Common.Utils.Uniplate +import Control.Applicative +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +----------------------------------------------------------------- +-- Strategy (internal) data structure, containing a selection +-- of combinators + +infixr 2 :%:, :!%:, .%. +infixr 3 :|:, :|>:, .|. +infixr 5 :*:, .*. + +-- | Core expression, with rules +type Core l a = GCore l (Rule a) + +-- | A generalized Core expression, not restricted to rules. This makes GCore +-- a (traversable and foldable) functor. +data GCore l a + = GCore l a :*: GCore l a + | GCore l a :|: GCore l a + | GCore l a :|>: GCore l a + | GCore l a :%: GCore l a -- interleave + | GCore l a :!%: GCore l a -- interleave-first-from-left + | Many (GCore l a) + | Repeat (GCore l a) + | Not (GCore l a) + | Label l (GCore l a) + | Atomic (GCore l a) + | Succeed + | Fail + | Rule a -- ^ Generalized constructor (not restricted to rules) + | Var Int + | Rec Int (GCore l a) + deriving Show + +----------------------------------------------------------------- +-- Useful instances + +instance Functor (GCore l) where + fmap = mapSecond + +instance Uniplate (GCore l a) where + uniplate core = + case core of + a :*: b -> plate (:*:) |* a |* b + a :|: b -> plate (:|:) |* a |* b + a :|>: b -> plate (:|>:) |* a |* b + a :%: b -> plate (:%:) |* a |* b + a :!%: b -> plate (:!%:) |* a |* b + Many a -> plate Many |* a + Repeat a -> plate Repeat |* a + Label l a -> plate Label |- l |* a + Atomic a -> plate Atomic |* a + Rec n a -> plate Rec |- n |* a + Not a -> plate Not |* a + _ -> plate core + +instance BiFunctor GCore where + biMap f g = rec + where + rec core = + case core of + a :*: b -> rec a :*: rec b + a :|: b -> rec a :|: rec b + a :|>: b -> rec a :|>: rec b + a :%: b -> rec a :%: rec b + a :!%: b -> rec a :!%: rec b + Many a -> Many (rec a) + Repeat a -> Repeat (rec a) + Not a -> Not (rec a) + Atomic a -> Atomic (rec a) + Rec n a -> Rec n (rec a) + Label l a -> Label (f l) (rec a) + Rule a -> Rule (g a) + Var n -> Var n + Succeed -> Succeed + Fail -> Fail + +instance T.Traversable (GCore l) where + traverse f core = + case core of + a :*: b -> (:*:) <$> T.traverse f a <*> T.traverse f b + a :|: b -> (:|:) <$> T.traverse f a <*> T.traverse f b + a :|>: b -> (:|>:) <$> T.traverse f a <*> T.traverse f b + a :%: b -> (:%:) <$> T.traverse f a <*> T.traverse f b + a :!%: b -> (:!%:) <$> T.traverse f a <*> T.traverse f b + Many a -> Many <$> T.traverse f a + Repeat a -> Repeat <$> T.traverse f a + Label l a -> Label l <$> T.traverse f a + Atomic a -> Atomic <$> T.traverse f a + Rec n a -> Rec n <$> T.traverse f a + Not a -> Not <$> T.traverse f a + Rule r -> Rule <$> f r + Succeed -> pure Succeed + Fail -> pure Fail + Var n -> pure $ Var n + +instance F.Foldable (GCore l) where + foldMap = T.foldMapDefault + +instance (Arbitrary l, Arbitrary a) => Arbitrary (GCore l a) where + arbitrary = generators + [ constGens [Succeed, Fail] + , unaryGen Atomic, arbGen Rule, unaryArbGen Label + , binaryGens [(:*:), (:|:), (:%:)] + ] + +----------------------------------------------------------------- +-- Smart constructors + +(.|.) :: GCore l a -> GCore l a -> GCore l a +Fail .|. b = b +a .|. Fail = a +a .|. b = a :|: b + +(.*.) :: GCore l a -> GCore l a -> GCore l a +Fail .*. _ = Fail +Succeed .*. b = b +_ .*. Fail = Fail +a .*. Succeed = a +a .*. b = a :*: b + +(.%.) :: GCore l a -> GCore l a -> GCore l a +Fail .%. _ = Fail +Succeed .%. b = b +_ .%. Fail = Fail +a .%. Succeed = a +a .%. b = a :%: b + +----------------------------------------------------------------- +-- Definitions + +coreMany :: GCore l a -> GCore l a +coreMany a = Rec n (Succeed :|: (a :*: Var n)) + where n = nextVar a + +coreRepeat :: GCore l a -> GCore l a +coreRepeat a = Many a :*: Not a + +coreOrElse :: GCore l a -> GCore l a -> GCore l a +coreOrElse a b = a :|: (Not a :*: b) + +coreFix :: (GCore l a -> GCore l a) -> GCore l a +coreFix f = -- disadvantage: function f is applied twice + let i = nextVar (f (Var (-1))) + in Rec i (f (Var i)) + +----------------------------------------------------------------- +-- Utility functions + +substCoreVar :: Int -> GCore l a -> GCore l a -> GCore l a +substCoreVar i a core = + case core of + Var j | i==j -> a + Rec j _ | i==j -> core + _ -> descend (substCoreVar i a) core + +nextVar :: GCore l a -> Int +nextVar p + | null xs = 0 + | otherwise = maximum xs + 1 + where xs = coreVars p + +coreVars :: GCore l a -> [Int] +coreVars core = + case core of + Var n -> [n] + Rec n a -> n : coreVars a + _ -> concatMap coreVars (children core) + +noLabels :: GCore l a -> GCore l a +noLabels (Label _ a) = noLabels a +noLabels core = descend noLabels core 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 @@ -1,80 +1,80 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Locations in a strategy --- ------------------------------------------------------------------------------ -module Common.Strategy.Location - ( subTaskLocation, nextTaskLocation - , strategyLocations, subStrategy - ) where - -import Common.Id -import Common.Strategy.Abstract -import Common.Strategy.Core -import Common.Uniplate -import Common.Utils (safeHead) -import Data.Maybe - ------------------------------------------------------------ ---- Strategy locations - --- old (current) and actual (next major rule) location -subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id -subTaskLocation s xs ys = g (rec (f xs) (f ys)) - where - f = fromMaybe [] . toLoc s - g = fromMaybe (getId s) . fromLoc s - rec (i:is) (j:js) - | i == j = i : rec is js - | otherwise = [] - rec _ (j:_) = [j] - rec _ _ = [] - --- old (current) and actual (next major rule) location -nextTaskLocation :: LabeledStrategy a -> Id -> Id -> Id -nextTaskLocation s xs ys = g (rec (f xs) (f ys)) - where - f = fromMaybe [] . toLoc s - g = fromMaybe (getId s) . fromLoc s - rec (i:is) (j:js) - | i == j = i : rec is js - | otherwise = [j] - rec _ _ = [] - --- | Returns a list of all strategy locations, paired with the labeled --- substrategy at that location -strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)] -strategyLocations s = ([], s) : rec [] (toCore (unlabel s)) - where - rec is = concat . zipWith make (map (:is) [0..]) . collect - - make is (l, core) = - let ls = makeLabeledStrategy l (toStrategy core) - in (is, ls) : rec is core - - collect core = - case core of - Label l t -> [(l, t)] - Not _ -> [] - _ -> concatMap collect (children core) - --- | Returns the substrategy or rule at a strategy location. Nothing --- indicates that the location is invalid -subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a) -subStrategy loc = - fmap snd . safeHead . filter ((==loc) . getId . snd) . strategyLocations - -fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id -fromLoc s loc = fmap getId (lookup loc (strategyLocations s)) - -toLoc :: LabeledStrategy a -> Id -> Maybe [Int] -toLoc s i = +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Locations in a strategy +-- +----------------------------------------------------------------------------- +module Common.Strategy.Location + ( subTaskLocation, nextTaskLocation + , strategyLocations, subStrategy + ) where + +import Common.Id +import Common.Strategy.Abstract +import Common.Strategy.Core +import Common.Utils (safeHead) +import Common.Utils.Uniplate +import Data.Maybe + +----------------------------------------------------------- +--- Strategy locations + +-- old (current) and actual (next major rule) location +subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id +subTaskLocation s xs ys = g (rec (f xs) (f ys)) + where + f = fromMaybe [] . toLoc s + g = fromMaybe (getId s) . fromLoc s + rec (i:is) (j:js) + | i == j = i : rec is js + | otherwise = [] + rec _ (j:_) = [j] + rec _ _ = [] + +-- old (current) and actual (next major rule) location +nextTaskLocation :: LabeledStrategy a -> Id -> Id -> Id +nextTaskLocation s xs ys = g (rec (f xs) (f ys)) + where + f = fromMaybe [] . toLoc s + g = fromMaybe (getId s) . fromLoc s + rec (i:is) (j:js) + | i == j = i : rec is js + | otherwise = [j] + rec _ _ = [] + +-- | Returns a list of all strategy locations, paired with the labeled +-- substrategy at that location +strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)] +strategyLocations s = ([], s) : rec [] (toCore (unlabel s)) + where + rec is = concat . zipWith make (map (:is) [0..]) . collect + + make is (l, core) = + let ls = makeLabeledStrategy l (fromCore core) + in (is, ls) : rec is core + + collect core = + case core of + Label l t -> [(l, t)] + Not _ -> [] + _ -> concatMap collect (children core) + +-- | Returns the substrategy or rule at a strategy location. Nothing +-- indicates that the location is invalid +subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a) +subStrategy loc = + fmap snd . safeHead . filter ((==loc) . getId . snd) . strategyLocations + +fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id +fromLoc s loc = fmap getId (lookup loc (strategyLocations s)) + +toLoc :: LabeledStrategy a -> Id -> Maybe [Int] +toLoc s i = fmap fst (safeHead (filter ((==i) . getId . snd) (strategyLocations s))) diff --git a/src/Common/Strategy/Parsing.hs b/src/Common/Strategy/Parsing.hs --- a/src/Common/Strategy/Parsing.hs +++ b/src/Common/Strategy/Parsing.hs @@ -1,191 +1,281 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Basic machinery for executing a core strategy expression. --- ------------------------------------------------------------------------------ -module Common.Strategy.Parsing - ( Step(..) - , State, makeState, stack, choices, trace, value - , parseDerivationTree, replay, runCore, runCoreWith - ) where - -import Common.Classes -import Common.Derivation -import Common.Strategy.Core -import Common.Transformation -import Control.Monad - ----------------------------------------------------------------------- --- Step data type - -data Step l a = Enter l | Exit l | RuleStep (Rule a) - deriving Show - -instance Apply (Step l) where - applyAll (RuleStep r) = applyAll r - applyAll _ = return - ----------------------------------------------------------------------- --- State data type - -data State l a = S - { stack :: [Either l (Core l a)] - , choices :: [Bool] - , trace :: [Step l a] - , value :: a - } - -makeState :: Core l a -> a -> State l a -makeState core a = push core (S [] [] [] a) - ----------------------------------------------------------------------- --- Parse derivation tree - -parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a) -parseDerivationTree state = addBranches list node - where - xs = firsts state - empty = not (null [ () | (Ready, _) <- xs ]) - node = singleNode state empty - list = [ (step, parseDerivationTree s) | (Result step, s) <- xs ] - -firsts :: State l a -> [(Result (Step l a), State l a)] -firsts st = - case pop st of - Nothing -> [(Ready, st)] - Just (Left l, s) -> [(Result (Exit l), traceExit l s)] - Just (Right core, s) -> firstsStep core s - where - firstsStep core state = - case core of - a :*: b -> firstsStep a (push b state) - a :|: b -> chooseFor True a ++ chooseFor False b - Rec i a -> firstsStep (substCoreVar i core a) state - Var _ -> freeCoreVar "firsts" - Rule r -> hasStep (RuleStep r) (useRule r state) - Label l a -> hasStep (Enter l) [push a (pushExit l state)] - Not a -> guard (checkNot a state) >> firsts state - a :|>: b -> firstsStep (coreOrElse a b) state - Many a -> firstsStep (coreMany a) state - Repeat a -> firstsStep (coreRepeat a) state - Fail -> [] - Succeed -> firsts state - where - chooseFor b = flip firstsStep (makeChoice b state) - hasStep step xs = [ (Result step, traceStep step s) | s <- xs ] - --- helper datatype -data Result a = Result a | Ready - ----------------------------------------------------------------------- --- Running the parser - -runCore :: Core l a -> a -> [a] -runCore core = runState . makeState core - -runCoreWith :: CoreEnv l a -> Core l a -> a -> [a] -runCoreWith env = runCore . substCoreEnv env - -runState :: State l a -> [a] -runState st = - case pop st of - Nothing -> [value st] - Just (Left _, s) -> runState s - Just (Right core, s) -> runStep core s - where - runStep core state = - case core of - a :*: b -> runStep a (push b state) - a :|: b -> runStep a state ++ runStep b state - Rec i a -> runStep (substCoreVar i core a) state - Var _ -> freeCoreVar "runState" - Rule r -> concatMap runState (useRule r state) - Label _ a -> runStep a state - Not a -> guard (checkNot a state) >> runState state - a :|>: b -> let xs = runStep a state - in if null xs then runStep b state else xs - Many a -> runStep (coreMany a) state - Repeat a -> runStep (coreRepeat a) state - Fail -> [] - Succeed -> runState state - ----------------------------------------------------------------------- --- Replay a parse run - -replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a) -replay n0 bs0 = replayState n0 bs0 . flip makeState noValue - where - noValue = error "no value in replay" - - replayState n bs state = - case pop state of - _ | n==0 -> return state - Nothing -> return state - Just (Left l, s) -> replayState (n-1) bs (traceExit l s) - Just (Right core, s) -> replayStep n bs core s - - replayStep n bs core state = - case core of - _ | n==0 -> return state - a :*: b -> replayStep n bs a (push b state) - a :|: b -> case bs of - [] -> fail "replay failed" - x:xs -> let new = if x then a else b - in replayStep n xs new (makeChoice x state) - Rec i a -> replayStep n bs (substCoreVar i core a) state - Var _ -> freeCoreVar "replay" - Rule r -> replayState (n-1) bs (traceRule r state) - Label l a -> replayStep (n-1) bs a (pushExit l (traceEnter l state)) - Not _ -> replayState n bs state - a :|>: b -> replayStep n bs (coreOrElse a b) state - Many a -> replayStep n bs (coreMany a) state - Repeat a -> replayStep n bs (coreRepeat a) state - Fail -> fail "replay failed" - Succeed -> replayState n bs state - ----------------------------------------------------------------------- --- Local helper functions and instances - -push :: Core l a -> State l a -> State l a -push core s = s {stack = Right core : stack s} - -pushExit :: l -> State l a -> State l a -pushExit l s = s {stack = Left l : stack s} - -pop :: State l a -> Maybe (Either l (Core l a), State l a) -pop s = case stack s of - [] -> Nothing - x:xs -> Just (x, s {stack = xs}) - -makeChoice :: Bool -> State l a -> State l a -makeChoice b s = s {choices = b : choices s} - -checkNot :: Core l a -> State l a -> Bool -checkNot core = null . runCore core . value - -useRule :: Rule a -> State l a -> [State l a] -useRule r state = [ state {value = b} | b <- applyAll r (value state) ] - -traceEnter, traceExit :: l -> State l a -> State l a -traceEnter = traceStep . Enter -traceExit = traceStep . Exit - -traceRule :: Rule a -> State l a -> State l a -traceRule = traceStep . RuleStep - -traceStep :: Step l a -> State l a -> State l a -traceStep step s = s {trace = step : trace s} - -substCoreVar :: Int -> Core l a -> Core l a -> Core l a -substCoreVar i a = substCoreEnv (insertCoreEnv i a emptyCoreEnv) - -freeCoreVar :: String -> a -freeCoreVar caller = error $ "Free var in core expression: " ++ caller +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Basic machinery for executing a core strategy expression. +-- +----------------------------------------------------------------------------- +module Common.Strategy.Parsing + ( Step(..) + , State, makeState, stack, choices, trace, value + , parseDerivationTree, replay, runCore + , firsts, Result(..), isReady + ) where + +import Common.Classes +import Common.DerivationTree +import Common.Strategy.Core +import Common.Transformation +import Common.Utils.Uniplate +import Control.Arrow +import Control.Monad + +---------------------------------------------------------------------- +-- Step data type + +data Step l a = Enter l | Exit l | RuleStep (Rule a) + deriving (Show, Eq, Ord) + +-- A core expression where the symbols are steps instead of "only" rules +type StepCore l a = GCore l (Step l a) + +instance Apply (Step l) where + applyAll (RuleStep r) = applyAll r + applyAll _ = return + +---------------------------------------------------------------------- +-- State data type + +data State l a = S + { stack :: Stack l a + , choices :: [Bool] + , trace :: [Step l a] + , timeout :: !Int + , value :: a + } deriving Show + +data Stack l a = Stack + { active :: [StepCore l a] -- the active items, performed in sequence + , suspended :: [StepCore l a] -- suspended items, performed after a step from active + , remainder :: [StepCore l a] -- remaining items: must be empty if there are no suspended items + } deriving Show + +makeState :: Core l a -> a -> State l a +makeState = newState . fmap RuleStep + +newState :: StepCore l a -> a -> State l a +newState core a = push core (S emptyStack [] [] 0 a) + +---------------------------------------------------------------------- +-- Parse derivation tree + +parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a) +parseDerivationTree = makeTree $ \state -> + let xs = firsts state + in ( any (isReady . fst) xs + , [ (step, s) | (Result step, s) <- xs ] + ) + +firsts :: State l a -> [(Result (Step l a), State l a)] +firsts st = + case pop st of + Nothing -> [(Ready, st)] + Just (core, s) -> firstsStep core s + where + firstsStep core state = + case core of + a :*: b -> firstsStep a (push b state) + a :|: b -> chooseFor True a ++ chooseFor False b + a :%: b -> firstsStep (coreInterleave a b) state + a :!%: b -> firstsStep a (suspend b state) + Rec i a -> incrTimer state >>= firstsStep (substCoreVar i core a) + Var _ -> freeCoreVar "firsts" + Rule r -> hasStep r + Label l a -> firstsStep (coreLabel l a) state + Atomic a -> firstsStep a (useAtomic state) + Not a -> guard (checkNot a state) >> firsts state + a :|>: b -> firstsStep (coreOrElse a b) state + Many a -> firstsStep (coreMany a) state + Repeat a -> firstsStep (coreRepeat a) state + Fail -> [] + Succeed -> firsts state + where + chooseFor b = flip firstsStep (makeChoice b state) + hasStep step = [ (Result step, s) | s <- useRule step (traceStep step state) ] + +-- helper datatype +data Result a = Result a | Ready deriving Show + +instance Functor Result where + fmap f (Result a) = Result (f a) + fmap _ Ready = Ready + +isReady :: Result a -> Bool +isReady Ready = True +isReady _ = False + +---------------------------------------------------------------------- +-- Running the parser + +runCore :: Core l a -> a -> [a] +runCore core = runState . makeState core + +runState :: State l a -> [a] +runState st = + case pop st of + Nothing -> [value st] + Just (core, s) -> runStep core s + where + runStep core state = + case core of + a :*: b -> runStep a (push b state) + a :|: b -> runStep a state ++ runStep b state + a :%: b -> runStep (coreInterleave a b) state + a :!%: b -> runStep a (suspend b state) + Rec i a -> incrTimer state >>= runStep (substCoreVar i core a) + Var _ -> freeCoreVar "runState" + Rule r -> concatMap runState (useRule r (interleave r state)) + Label _ a -> runStep a state + Atomic a -> runStep a (useAtomic state) + Not a -> guard (checkNot a state) >> runState state + a :|>: b -> let xs = runStep a state + in if null xs then runStep b state else xs + Many a -> runStep (coreMany a) state + Repeat a -> runStep (coreRepeat a) state + Fail -> [] + Succeed -> runState state + +---------------------------------------------------------------------- +-- Replay a parse run + +replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a) +replay n0 bs0 = replayState n0 bs0 . flip makeState noValue + where + noValue = error "no value in replay" + + replayState n bs state = + case pop state of + _ | n==0 -> return state + Nothing -> return state + Just (core, s) -> replayStep n bs core s + + replayStep n bs core state = + case core of + _ | n==0 -> return state + a :*: b -> replayStep n bs a (push b state) + a :|: b -> case bs of + [] -> fail "replay failed" + x:xs -> let new = if x then a else b + in replayStep n xs new (makeChoice x state) + a :%: b -> replayStep n bs (coreInterleave a b) state + a :!%: b -> replayStep n bs a (suspend b state) + Rec i a -> replayStep n bs (substCoreVar i core a) state + Var _ -> freeCoreVar "replay" + Rule r -> replayState (n-1) bs (traceStep r state) + Label l a -> replayStep n bs (coreLabel l a) state + Atomic a -> replayStep n bs a (useAtomic state) + Not _ -> replayState n bs state + a :|>: b -> replayStep n bs (coreOrElse a b) state + Many a -> replayStep n bs (coreMany a) state + Repeat a -> replayStep n bs (coreRepeat a) state + Fail -> fail "replay failed" + Succeed -> replayState n bs state + +---------------------------------------------------------------------- +-- Core translations + +coreLabel :: l -> StepCore l a -> StepCore l a +coreLabel l a = Rule (Enter l) :*: a :*: Rule (Exit l) + +coreInterleave :: StepCore l a -> StepCore l a -> StepCore l a +coreInterleave a b = (a :!%: b) :|: (b :!%: a) :|: emptyOnly (a :*: b) + where + emptyOnly core = + case core of + Rule step | interleaveAfter step -> Fail + Not _ -> core + x :|>: y -> emptyOnly x .|. (Not x :*: emptyOnly y) + Repeat x -> emptyOnly (coreRepeat x) + x :|: y -> emptyOnly x .|. emptyOnly y + x :*: y -> emptyOnly x .*. emptyOnly y + x :%: y -> emptyOnly x .*. emptyOnly y -- no more interleaving + x :!%: y -> emptyOnly x .*. emptyOnly y -- no more interleaving + _ -> descend emptyOnly core + +---------------------------------------------------------------------- +-- State functions + +push :: StepCore l a -> State l a -> State l a +push = changeStack . pushStack + +suspend :: StepCore l a -> State l a -> State l a +suspend = changeStack . suspendStack + +useAtomic :: State l a -> State l a +useAtomic = changeStack interleaveStack + +pop :: State l a -> Maybe (StepCore l a, State l a) +pop s = fmap (second f) (popStack (stack s)) + where f new = s {stack = new} + +makeChoice :: Bool -> State l a -> State l a +makeChoice b s = s {choices = b : choices s} + +checkNot :: StepCore l a -> State l a -> Bool +checkNot core = null . runState . newState core . value + +useRule :: Step l a -> State l a -> [State l a] +useRule step state = + [ resetTimer state {value = b} | b <- applyAll step (value state) ] + +traceStep :: Step l a -> State l a -> State l a +traceStep step s = interleave step s {trace = step : trace s} + +freeCoreVar :: String -> a +freeCoreVar caller = error $ "Free var in core expression: " ++ caller + +incrTimer :: Monad m => State l a -> m (State l a) +incrTimer s + | timeout s >= 20 = fail "timeout after 20 fixpoints" + | otherwise = return (s {timeout = timeout s + 1}) + +resetTimer :: State l a -> State l a +resetTimer s = s {timeout = 0} + +interleaveAfter :: Step l a -> Bool +interleaveAfter (RuleStep _) = True +interleaveAfter _ = False + +interleave :: Step l a -> State l a -> State l a +interleave step = if interleaveAfter step then useAtomic else id + +changeStack :: (Stack l a -> Stack l a) -> State l a -> State l a +changeStack f s = s {stack = f (stack s)} + +---------------------------------------------------------------------- +-- Stack functions + +emptyStack :: Stack l a +emptyStack = Stack [] [] [] + +pushStack :: StepCore l a -> Stack l a -> Stack l a +pushStack core s = s {active = core : active s} + +suspendStack :: StepCore l a -> Stack l a -> Stack l a +suspendStack core s + | null (active s) = s {suspended = core : suspended s} + | otherwise = emptyStack {suspended = [core], remainder = combineStack s} + +popStack :: Stack l a -> Maybe (StepCore l a, Stack l a) +popStack s = + case active s of + x:xs -> Just (x, s {active = xs}) + [] | null (suspended s) -> Nothing + | otherwise -> Just (Fail, s) + +interleaveStack :: Stack l a -> Stack l a +interleaveStack s = emptyStack {active = combineStack s} + +combineStack :: Stack l a -> [StepCore l a] +combineStack s + | null (suspended s) = active s + | otherwise = front : remainder s + where + actives = foldr (.*.) Succeed (active s) + front = foldr (.%.) Succeed (actives:suspended s) 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 @@ -1,82 +1,78 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A prefix encodes a sequence of steps already performed (a so-called trace), --- and allows to continue the derivation at that particular point. --- ------------------------------------------------------------------------------ -module Common.Strategy.Prefix - ( Prefix, emptyPrefix, makePrefix - , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix - ) where - -import Common.Utils -import Common.Strategy.Abstract -import Common.Strategy.Parsing -import Common.Transformation -import Common.Derivation -import Data.Maybe -import Control.Monad - ------------------------------------------------------------ ---- Prefixes - --- | Abstract data type for a (labeled) strategy with a prefix (a sequence of --- executed rules). A prefix is still "aware" of the labels that appear in the --- strategy. A prefix is encoded as a list of integers (and can be reconstructed --- from such a list: see @makePrefix@). The list is stored in reversed order. -data Prefix a = P (State LabelInfo a) - -prefixPair :: Prefix a -> (Int, [Bool]) -prefixPair (P s) = (length (trace s), reverse (choices s)) - -prefixIntList :: Prefix a -> [Int] -prefixIntList = f . prefixPair - where - f (0, []) = [] - f (n, bs) = n : map (\b -> if b then 0 else 1) bs - -instance Show (Prefix a) where - show = show . prefixIntList - -instance Eq (Prefix a) where - a == b = prefixPair a == prefixPair b - --- | Construct the empty prefix for a labeled strategy -emptyPrefix :: LabeledStrategy a -> Prefix a -emptyPrefix = fromMaybe (error "emptyPrefix") . makePrefix [] - --- | Construct a prefix for a given list of integers and a labeled strategy. -makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a) -makePrefix [] ls = makePrefix [0] ls -makePrefix (i:is) ls = liftM P $ - replay i (map (==0) is) (mkCore ls) - where - mkCore = processLabelInfo id . toCore . toStrategy - --- | Create a derivation tree with a "prefix" as annotation. -prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a -prefixTree (P s) a = f (parseDerivationTree s {value = a}) - where - f t = addBranches list (singleNode (value $ root t) (endpoint t)) - where - list = map g (branches t) - g (_, st) = (P (root st), f st) - -prefixToSteps :: Prefix a -> [Step LabelInfo a] -prefixToSteps (P t) = reverse (trace t) - --- | Retrieves the rules from a list of steps -stepsToRules :: [Step l a] -> [Rule a] -stepsToRules xs = [ r | RuleStep r <- xs ] - --- | Returns the last rule of a prefix (if such a rule exists) -lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A prefix encodes a sequence of steps already performed (a so-called trace), +-- and allows to continue the derivation at that particular point. +-- +----------------------------------------------------------------------------- +module Common.Strategy.Prefix + ( Prefix, emptyPrefix, makePrefix + , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix + ) where + +import Common.DerivationTree +import Common.Strategy.Abstract +import Common.Strategy.Parsing +import Common.Transformation +import Common.Utils +import Control.Monad +import Data.Maybe + +----------------------------------------------------------- +--- Prefixes + +-- | Abstract data type for a (labeled) strategy with a prefix (a sequence of +-- executed rules). A prefix is still "aware" of the labels that appear in the +-- strategy. A prefix is encoded as a list of integers (and can be reconstructed +-- from such a list: see @makePrefix@). The list is stored in reversed order. +data Prefix a = P (State LabelInfo a) + +prefixPair :: Prefix a -> (Int, [Bool]) +prefixPair (P s) = (length (trace s), reverse (choices s)) + +prefixIntList :: Prefix a -> [Int] +prefixIntList = f . prefixPair + where + f (0, []) = [] + f (n, bs) = n : map (\b -> if b then 0 else 1) bs + +instance Show (Prefix a) where + show = show . prefixIntList + +instance Eq (Prefix a) where + a == b = prefixPair a == prefixPair b + +-- | Construct the empty prefix for a labeled strategy +emptyPrefix :: LabeledStrategy a -> Prefix a +emptyPrefix = fromMaybe (error "emptyPrefix") . makePrefix [] + +-- | Construct a prefix for a given list of integers and a labeled strategy. +makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a) +makePrefix [] ls = makePrefix [0] ls +makePrefix (i:is) ls = liftM P $ + replay i (map (==0) is) (mkCore ls) + where + mkCore = processLabelInfo id . toCore . toStrategy + +-- | Create a derivation tree with a "prefix" as annotation. +prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a +prefixTree (P s) a = fmap value $ updateAnnotations (\_ _ -> P) $ + parseDerivationTree s {value = a} + +prefixToSteps :: Prefix a -> [Step LabelInfo a] +prefixToSteps (P t) = reverse (trace t) + +-- | Retrieves the rules from a list of steps +stepsToRules :: [Step l a] -> [Rule a] +stepsToRules xs = [ r | RuleStep r <- xs ] + +-- | Returns the last rule of a prefix (if such a rule exists) +lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a) lastStepInPrefix (P t) = safeHead (trace t) diff --git a/src/Common/Strategy/Tests.hs b/src/Common/Strategy/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy/Tests.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Testing strategy combinator properties +-- +----------------------------------------------------------------------------- +module Common.Strategy.Tests (tests) where + +import Common.Algebra.Group +import Common.Algebra.Law +import Common.Classes +import Common.Id +import Common.Strategy +import Common.Strategy.Abstract +import Common.Strategy.Parsing +import Common.Utils.QuickCheck hiding (label, Result) +import Common.Utils.TestSuite +import Data.Function +import Data.List +import Data.Ord +import Prelude hiding (fail) +import qualified Common.Algebra.Field as F + +--------------------------------------------------------- +-- Properties + +tests :: TestSuite +tests = suite "Strategy combinator properties" $ do + -- monoids and semi-rings + fs (commutative : idempotent : monoidLaws :: [Law Choice]) + fs (monoidZeroLaws :: [Law Sequence]) + fs (commutative : monoidZeroLaws :: [Law Interleave]) + fs (F.distributiveLaws :: [Law Sequence]) + fs (F.distributiveLaws :: [Law Interleave]) + + -- properties of atomic + addProperty "atomic-twice" $ \a -> + atomic (atomic a) === atomic (idS a) + assertTrue "atomic-succeed" $ + atomic succeed === succeed + assertTrue "atomic-fail" $ + atomic fail === fail + addProperty "atomic-choice" $ \a b -> + atomic (idS a <|> idS b) === atomic a <|> atomic b + + -- splits theorm parallel/atomic + addProperty "atomic-split" $ \x y a b -> + (atomic x <*> a) <%> (atomic y <*> b) + === + (idS x <*> (a <%> (atomic y <*> b))) + <|> + (idS y <*> ((atomic x <*> idS a) <%> idS b)) + where + fs :: (Arbitrary a, Show a, Eq a) => [Law a] -> TestSuite + fs = mapM_ (\p -> addProperty (show p) p) + +--------------------------------------------------------- +-- Algebraic instances + +newtype Choice = Choice (Strategy Int) deriving (Show, Arbitrary) +newtype Sequence = Sequence (Strategy Int) deriving (Show, Arbitrary) +newtype Interleave = Interleave (Strategy Int) deriving (Show, Arbitrary) + +instance Eq Choice where Choice a == Choice b = a === b +instance Eq Sequence where Sequence a == Sequence b = a === b +instance Eq Interleave where Interleave a == Interleave b = a === b + +instance Monoid Choice where + mempty = Choice fail + mappend (Choice a) (Choice b) = Choice (a <|> b) + +instance Monoid Sequence where + mempty = Sequence succeed + mappend (Sequence a) (Sequence b) = Sequence (a <*> b) + +instance MonoidZero Sequence where + mzero = Sequence fail + +instance Monoid Interleave where + mempty = Interleave succeed + mappend (Interleave a) (Interleave b) = Interleave (a <%> b) + +instance MonoidZero Interleave where + mzero = Interleave fail + +instance F.SemiRing Sequence where + Sequence a <+> Sequence b = Sequence (a <|> b) + zero = Sequence fail + (<*>) = mappend + one = mempty + +instance F.SemiRing Interleave where + Interleave a <+> Interleave b = Interleave (a <|> b) + zero = Interleave fail + (<*>) = mappend + one = mempty + +--------------------------------------------------------- +-- Helper functions for equality + +idS :: Strategy Int -> Strategy Int +idS = id + +infix 1 === + +(===) :: Strategy Int -> Strategy Int -> Bool +s1 === s2 = rec 100 [(start s1, start s2)] + where + start = return . flip makeState 0 . toCore + + rec :: Int -> [([State LabelInfo Int], [State LabelInfo Int])] -> Bool + rec _ [] = True + rec n (pair:rest) + | n == 0 = True + | otherwise = testReady xs ys + && testValue xs ys + && testFirsts gxs gys + && rec (n-1) (rest ++ new) + + where + p@(xs, ys) = mapBoth (concatMap myFirsts) pair + gp@(gxs, gys) = mapBoth f p + new = uncurry zip (mapBoth (map snd) gp) + + testReady = (==) `on` any (isReady . fst) + testValue = (==) `on` (nub . sort . map (value . snd)) + testFirsts = (==) `on` map fst + + f = map merge . groupBy eqFst . sortBy cmpFst . results + merge as = (fst (head as), map snd as) + results as = [ (a, b) | (Result a, b) <- as ] + + cmpFst (x, _) (y, _) = x `compare` y + eqFst (x, _) (y, _) = x == y + +myFirsts :: State l a -> [(Result (Step l a), State l a)] +myFirsts = concatMap f . firsts + where + f pair@(result, a) = + case result of + Result (Enter _) -> myFirsts a + Result (Exit _) -> myFirsts a + _ -> [pair] + +{- +debug :: Show a => Strategy a -> a -> IO () +debug s = rec . makeState (toCore s) + where + rec st = do + print st + putStrLn $ "\nReady: " ++ show (any (isReady . fst) xs) + putStrLn $ unlines $ + zipWith (\i y -> show i ++ ". " ++ show (fst y)) [1::Int ..] ys + if (null xs) then print "(no choices)" else do + n <- ask + rec (snd (ys !! n)) + where + xs = firsts st + ys = [ (a, b) | (Result a, b) <- xs ] + + ask = do + putStr "? " + input <- getLine + case readInt input of + Just n | n > 0 && n <= length ys -> + return (n-1) + _ -> if input == "q" then error "QUIT" else ask -} diff --git a/src/Common/StringRef.hs b/src/Common/StringRef.hs deleted file mode 100644 --- a/src/Common/StringRef.hs +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- References to Strings, proving a fast comparison implementation (Eq and --- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy --- Virutal Machine (LVM) identifiers. --- ------------------------------------------------------------------------------ -module Common.StringRef (StringRef, stringRef, toString) where - -import Data.Bits -import Data.IORef -import Data.List -import System.IO.Unsafe -import qualified Data.IntMap as IM - ----------------------------------------------------------------- --- StringRef datatype and instance declarations - -data StringRef = S !Int - deriving (Eq, Ord) - -instance Show StringRef where - show s@(S i) = '#' : show i ++ toString s - ----------------------------------------------------------------- --- Hash table - -type HashTable = IM.IntMap [String] - -tableRef :: IORef HashTable -tableRef = unsafePerformIO (newIORef IM.empty) - ----------------------------------------------------------------- --- Conversion to and from strings - -stringRef :: String -> StringRef -stringRef s = unsafePerformIO $ do - let hash = hashString s - m <- readIORef tableRef - case IM.insertLookupWithKey (\_ -> combine) hash [s] m of - (Nothing, new) -> do - writeIORef tableRef new - return (S (encodeIndexZero hash)) - (Just old, new) -> - case findIndex (==s) old of - Just index -> - return (S (encode hash index)) - Nothing -> do - let index = length old - writeIORef tableRef new - return (S (encode hash index)) - -toString :: StringRef -> String -toString (S i) = unsafePerformIO $ do - m <- readIORef tableRef - case IM.lookup (extractHash i) m of - Just xs -> return (atIndex (extractIndex i) xs) - Nothing -> intErr "id not found" - ----------------------------------------------------------------- --- Bit encoding - -encode :: Int -> Int -> Int -encode hash index = hash + index `shiftL` 12 - -encodeIndexZero :: Int -> Int -encodeIndexZero hash = hash - -extractHash :: Int -> Int -extractHash i = i `mod` 4096 - -extractIndex :: Int -> Int -extractIndex i = i `shiftR` 12 - ----------------------------------------------------------------- --- Hash function - --- simple hash function that performs quite good in practice -hashString :: String -> Int -hashString s = (f s `mod` prime) `mod` maxHash - where - f = foldl' next 0 -- ' strict fold - next n c = n*65599 + fromEnum c - prime = 32537 --65599 -- require: prime < maxHash - -maxHash :: Int -maxHash = 0xFFF -- 12 bits - ----------------------------------------------------------------- --- Utility functions - -atIndex :: Int -> [a] -> a -atIndex 0 (x:_) = x -atIndex i (_:xs) = atIndex (i-1) xs -atIndex _ _ = intErr "corrupt symbol table" - -combine :: Eq a => [a] -> [a] -> [a] -combine [a] = rec - where - rec [] = [a] - rec this@(x:xs) - | a == x = this - | otherwise = x:rec xs -combine _ = intErr "combine" - -intErr :: String -> a -intErr s = error ("Internal error in Common.StringRef: " ++ s) - ----------------------------------------------------------------- --- Testing and debugging - -{- -printTable :: IO () -printTable = readIORef tableRef >>= print - -test1 _ = toString (stringRef "bas") == "bas" -test2 _ = stringRef "bas" == stringRef "bas" -test3 _ = stringRef "bas" /= stringRef "je" -test4 _ = stringRef "arith1.unary_minus" /= stringRef "distribute power" --} diff --git a/src/Common/TestSuite.hs b/src/Common/TestSuite.hs deleted file mode 100644 --- a/src/Common/TestSuite.hs +++ /dev/null @@ -1,385 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A lightweight wrapper around the QuickCheck library. It introduces the --- notion of a test suite, and it stores the test results for later inspection --- (e.g., for the generation of a test report). A test suite has a monadic --- interface. --- ------------------------------------------------------------------------------ -module Common.TestSuite - ( -- * Test Suite Monad - TestSuite, MonadIO(..) - -- * Test suite constructors - , suite, addProperty, addPropertyWith - , assertTrue, assertTrueMsg, assertNull, assertEquals - , assertIO, warn - -- * Running a test suite - , runTestSuite, runTestSuiteResult - -- * Test Suite Result - , TestSuiteResult, subResults - , makeSummary, printSummary - , makeTestLog, makeTestLogWith, printTestLog - -- * Formatting - , FormatLog(..), formatLog, formatTimeDiff - ) where - -import Control.Arrow -import Data.List -import Data.Monoid -import qualified Data.Sequence as S -import Data.Foldable (toList) -import Test.QuickCheck -import Control.Monad.State -import System.Time hiding (formatTimeDiff) - ----------------------------------------------------------------- --- Test Suite Monad - --- Integer corresponds to the number of characters on the current line, and --- is used for formatting -newtype TestSuiteM a = TSM { unTSM :: M a } - -type M a = StateT (Int, ResultTree) IO a -type TestSuite = TestSuiteM () - -instance Monad TestSuiteM where - return = TSM . return - m >>= f = TSM (unTSM m >>= unTSM . f) - fail s = do assertTrueMsg "" s False - return (error "TestSuite.fail: do not bind result") - -instance MonadIO TestSuiteM where - liftIO = TSM . liftIO - -instance Monoid a => Monoid (TestSuiteM a) where - mempty = return mempty - mappend = (>>) - ----------------------------------------------------------------- --- Test suite constructors - --- | Construct a (named) test suite containing tests and other suites -suite :: String -> TestSuite -> TestSuite -suite s m = TSM $ do - newline - liftIO $ putStrLn s - reset - (t, td) <- getDiff (withEmptyTree (unTSM m)) - addTree (labeled (s, td) t) - --- | Add a QuickCheck property to the test suite. The first argument is --- a label for the property -addProperty :: Testable prop => String -> prop -> TestSuite -addProperty = flip addPropertyWith stdArgs - --- | Add a QuickCheck property to the test suite, also providing a test --- configuration (Args) -addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite -addPropertyWith s args p = TSM $ do - newlineIndent - r <- liftIO $ quickCheckWithResult args p - reset - addResult s (toTestResult (maxSuccess args) r) - -assertTrue :: String -> Bool -> TestSuite -assertTrue msg = assertIO msg . return - -assertTrueMsg :: String -> String -> Bool -> TestSuite -assertTrueMsg s msg = addAssertion (Error msg) s . return - -assertNull :: Show a => String -> [a] -> TestSuite -assertNull s xs = addAssertion (f xs) s (return (null xs)) - where f = Error . concat . intersperse "\n" . map show - -assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite -assertEquals s x y = addAssertion msg s (return (x==y)) - where msg = Error ("Not equal: " ++ show x ++ " and " ++ show y) - -assertIO :: String -> IO Bool -> TestSuite -assertIO = addAssertion (Error "Assertion failed") - -warn :: String -> TestSuite -warn msg = addAssertion (Warning msg) "" (return False) - --- local helpers -addAssertion :: TestResult -> String -> IO Bool -> TestSuite -addAssertion msg s io = TSM $ do - b <- liftIO (io `catch` \_ -> return False) - if b then do - dot - addResult s (Ok 1) - else do - newlineIndent - liftIO $ putStrLn (s ++ ": " ++ show msg) - reset - addResult s msg - -addResult :: String -> TestResult -> M () -addResult s r = addTree (single (s, r)) - -addTree :: ResultTree -> M () -addTree t = modify (second (`mappend` t)) - -withEmptyTree :: M () -> M ResultTree -withEmptyTree m = do - t0 <- gets snd - modify (second (const mempty)) - m - tr <- gets snd - modify (second (const t0)) - return tr - --- formatting helpers -newline :: M () -newline = do - i <- gets fst - when (i>0) (liftIO $ putChar '\n') - reset - -newlineIndent :: M () -newlineIndent = do - newline - liftIO $ putStr " " - modify (first (const 3)) - -dot :: M () -dot = do - i <- gets fst - unless (i>0 && i<60) newlineIndent - liftIO $ putChar '.' - modify (first (+1)) - -reset :: M () -reset = modify (first (const 0)) - ----------------------------------------------------------------- --- Running a test suite - -runTestSuite :: TestSuite -> IO () -runTestSuite s = runTestSuiteResult s >> return () - -runTestSuiteResult :: TestSuite -> IO TestSuiteResult -runTestSuiteResult s = liftM TSR $ getDiff $ liftM snd $ - execStateT (unTSM s >> newline) (0, mempty) - ----------------------------------------------------------------- --- Test Suite Result - -newtype TestSuiteResult = TSR (ResultTree, TimeDiff) - -type ResultTree = Tree (String, TimeDiff) (String, TestResult) - -data TestResult = Ok !Int | Error String | Warning String - -instance Show TestResult where - show (Ok _) = "Ok" - show (Error msg) = "Error: " ++ msg - show (Warning msg) = "Warning: " ++ msg - --- one-line summary -instance Show TestSuiteResult where - show (TSR (tree, diff)) = - let (n, nf, nw) = collectInfo tree - in "(tests: " ++ show n ++ ", failures: " ++ show nf ++ - ", warnings: " ++ show nw ++ ", " ++ formatTimeDiff diff ++ ")" - -subResults :: TestSuiteResult -> [(String, TestSuiteResult)] -subResults (TSR (tree, _)) = - let f ((s, diff), t) = (s, TSR (t, diff)) - in map f (subtrees tree) - -printSummary :: TestSuiteResult -> IO () -printSummary = putStrLn . makeSummary - -makeSummary :: TestSuiteResult -> String -makeSummary result@(TSR (tree, diff)) = unlines $ - [ line - , "Tests : " ++ show n - , "Failures : " ++ show nf - , "Warnings : " ++ show nw - , "\nTime : " ++ formatTimeDiff diff - , "\nSuites: " - ] ++ map f (subResults result) - ++ [line] - where - line = replicate 75 '-' - (n, nf, nw) = collectInfo tree - f (name, r) = " " ++ name ++ " " ++ show r - -printTestLog :: TestSuiteResult -> IO () -printTestLog = putStrLn . makeTestLog - -makeTestLog :: TestSuiteResult -> String -makeTestLog = unlines . makeTestLogWith formatLog - -makeTestLogWith :: Monoid a => FormatLog a -> TestSuiteResult -> a -makeTestLogWith fm (TSR (tree, diff)) = formatRoot fm diff (make [] tree) - where - make loc = mconcat . map (either forTests forSuite) . treeToList - where - treeToList = - let op (i, ys) y = - case y of - Left b -> (i, Left b:ys) - Right p -> (i+1, Right (loc ++ [i], p):ys) - in reverse . snd . foldl op (1, []) . collectLevel - - forSuite (nl, ((s, d), t)) = - formatSuite fm nl s (collectInfo t) d (make nl t) - - forTests [] = mempty - forTests list@((s, result) : rest) = - case result of - Warning msg -> next (formatWarning fm s msg) - Error msg -> next (formatFailure fm s msg) - Ok _ -> - let (ys, zs) = span (isOk . snd) list - sucs = [ (x, n) | (x, Ok n) <- ys ] - in formatSuccesses fm sucs `mappend` forTests zs - where - next a = a `mappend` forTests rest - -data FormatLog a = FormatLog - { formatRoot :: TimeDiff -> a -> a - , formatSuite :: [Int] -> String -> (Int, Int, Int) -> TimeDiff -> a -> a - , formatSuccesses :: [(String, Int)] -> a - , formatFailure :: String -> String -> a - , formatWarning :: String -> String -> a - } - -formatLog :: FormatLog [String] -formatLog = FormatLog - { formatRoot = \td a -> - a ++ ["\n(Total time: " ++ formatTimeDiff td ++ ")"] - , formatSuite = \loc s _ td a -> - [showLoc loc ++ ". " ++ s] ++ a ++ - [" (" ++ formatTimeDiff td ++ " for " ++ s ++ ")"] - , formatSuccesses = \xs -> - let f (_, n) = if n==1 then "." else "(" ++ show n ++ " tests)" - in [" " ++ concatMap f xs] - , formatFailure = \s msg -> - [" " ++ putLabel s ++ "Error: " ++ msg] - , formatWarning = \s msg -> - [" " ++ putLabel s ++ "Warning: " ++ msg] - } - where - putLabel s = if null s then "" else s ++ ": " - -formatTimeDiff :: TimeDiff -> String -formatTimeDiff d@(TimeDiff z1 z2 z3 h m s p) - | any (/=0) [z1,z2,z3] = timeDiffToString d - | s >= 60 = formatTimeDiff (timeDiff ((h*60+m)*60+s) p) - | h==0 && m==0 = show inSec ++ " secs" - | otherwise = show (60*h+m) ++ ":" ++ digSec ++ " mins" - where - milSec = 1000*toInteger s + p `div` 1000000000 - inSec = fromIntegral milSec / 1000 :: Double - digSec = (if s < 10 then ('0' :) else id) (show s) - timeDiff n pc = - let (rest, sn) = n `divMod` 60 - (hr, mr) = rest `divMod` 60 - in TimeDiff 0 0 0 hr mr sn pc - ------------------------------------------------------ --- Utility functions - --- A sequence of leafs (Left) or labeled items (Right) -newtype Tree a b = T { unT :: S.Seq (Either b (a, Tree a b)) } - -instance Monoid (Tree a b) where - mempty = T mempty - mappend (T a) (T b) = T (mappend a b) - -single :: b -> Tree a b -single = T . S.singleton . Left - -labeled :: a -> Tree a b -> Tree a b -labeled a t = T (S.singleton (Right (a, t))) - -toTestResult :: Int -> Result -> TestResult -toTestResult n result = - case result of - Success _ -> Ok n - Failure _ _ msg _ -> Error msg - NoExpectedFailure _ -> Error "no expected failure" - GaveUp i _ -> Warning ("passed only " ++ show i ++ " tests") - -showLoc :: [Int] -> String -showLoc = concat . intersperse "." . map show - -collectInfo :: Tree a (String, TestResult) -> (Int, Int, Int) -collectInfo tree = (length tests, length failures, length warnings) - where - tests = flatten tree - failures = [ msg | (_, Error msg) <- tests ] - warnings = [ msg | (_, Warning msg) <- tests ] - -isOk :: TestResult -> Bool -isOk (Ok _) = True -isOk _ = False - -subtrees :: Tree a b -> [(a, Tree a b)] -subtrees t = [ p | Right p <- collectLevel t ] - -flatten :: Tree a b -> [b] -flatten t = [ b | x <- collectLevel t, b <- either id (flatten . snd) x ] - -collectLevel :: Tree a b -> [Either [b] (a, Tree a b)] -collectLevel = combine [] . toList . unT - where - combine acc [] = f acc - combine acc (Left a:rest) = combine (a:acc) rest - combine acc (Right b:rest) = f acc ++ (Right b : combine [] rest) - - f acc = [ Left (reverse acc) | not (null acc) ] - -getDiff :: MonadIO m => m a -> m (a, TimeDiff) -getDiff action = do - t0 <- liftIO getClockTime - a <- action - t1 <- liftIO getClockTime - return (a, diffClockTimes t1 t0) - --- Example -{- -main :: IO () -main = do - r <- runTestSuiteResult $ do - suite "A" $ do - addProperty "p1" p1 - addProperty "p1" p1 - suite "A1" $ addProperty "p2" p2 - suite "A2" $ return () - addProperty "p3" p3 - suite "B" $ do - addProperty "p4" p4 - addProperty "W" (\xs -> length (xs::[Int]) > 100 ==> True) - suite "C" $ do - addProperty "p5" p5 - assertTrue "sorted" (sort [3,2,1] == [1,2,3]) - fail "This is a failure" - warn "This is a warning" - assertEquals "eq" (sort [1,2,2]) (nub [1,2,2]) - assertTrue "yes" True - - printSummary r - printTestLog r - --print r - --print (subResults r) - where - p1 xs = sort (xs::[Int]) == sort (sort xs) - p2 xs = reverse (reverse xs) == (xs::[Int]) - p3 xs = head (sort xs) == minimum (xs::[Int]) - p4 xs = sort (nub xs) == nub (sort (xs::[Int])) - p5 xs = reverse (sort xs) == sort (reverse (xs :: [Int])) - -main = runTestSuite $ suite "A" $ assertIO "B" (return True) >> - assertIO "D" (fail "boe") >> assertIO "C" (return True) -} diff --git a/src/Common/Transformation.hs b/src/Common/Transformation.hs --- a/src/Common/Transformation.hs +++ b/src/Common/Transformation.hs @@ -1,471 +1,433 @@ -{-# LANGUAGE ExistentialQuantification #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines transformations. Given a term, a transformation returns a list of --- results (often a singleton list or the empty list). A transformation can be parameterized --- with one or more arguments. A rule is in essence just a transformation with a name (which --- should be unique). Both transformations and rules can be lifted to work on more complex domains. --- ------------------------------------------------------------------------------ -module Common.Transformation - ( -- * Transformations - Transformation, makeTrans, makeTransList, makeRewriteTrans - -- * Arguments - , ArgDescr(..), defaultArgDescr, Argument(..) - , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1 - , hasArguments, expectedArguments, getDescriptors, useArguments - -- * Rules - , Rule, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule - , ruleGroups, ruleSiblings, addRuleToGroup - , rule, ruleList - , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList - , idRule, checkRule, emptyRule, minorRule, buggyRule, doBefore, doAfter - , siblingOf, transformations, getRewriteRules, doBeforeTrans - , ruleRecognizer, useRecognizer - -- * Lifting - , liftRule, liftTrans, liftRuleIn, liftTransIn - -- * QuickCheck - , testRule, propRuleSmart - ) where - -import Common.Rewriting -import Common.Classes -import Common.Utils -import Common.View -import Control.Monad -import Data.Char -import Data.Maybe -import Data.Ratio -import Test.QuickCheck -import Common.Id - ------------------------------------------------------------ ---- Transformations - --- | Abstract data type for representing transformations -data Transformation a - = Function (a -> [a]) - | RewriteRule (RewriteRule a) (a -> [a]) - | Transformation a :*: Transformation a -- sequence - | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a) - | forall b c . LiftView (ViewList a (b, c)) (Transformation b) - | Recognizer (a -> a -> Bool) (Transformation a) - -instance Apply Transformation where - applyAll (Function f) = f - applyAll (RewriteRule _ f) = f - applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a) - applyAll (LiftView v t) = \a -> [ build v (b, c) | (b0, c) <- match v a, b <- applyAll t b0 ] - applyAll (s :*: t) = \a -> applyAll s a >>= applyAll t - applyAll (Recognizer _ t) = applyAll t - --- | Turn a function (which returns its result in the Maybe monad) into a transformation -makeTrans :: (a -> Maybe a) -> Transformation a -makeTrans f = makeTransList (maybe [] return . f) - --- | Turn a function (which returns a list of results) into a transformation -makeTransList :: (a -> [a]) -> Transformation a -makeTransList = Function - --- | Turn a rewrite rule into a transformation -makeRewriteTrans :: RewriteRule a -> Transformation a -makeRewriteTrans r = RewriteRule r (rewriteM r) - ------------------------------------------------------------ ---- Arguments - --- | A data type for describing an argument of a parameterized transformation -data ArgDescr a = ArgDescr - { labelArgument :: String -- ^ Label that is shown to the user when asked to supply the argument - , defaultArgument :: Maybe a -- ^ Default value that can be used - , parseArgument :: String -> Maybe a -- ^ A parser - , showArgument :: a -> String -- ^ A pretty-printer - , genArgument :: Gen a -- ^ An arbitrary argument generator - } - --- | Constructor function for an argument descriptor that uses the Show and Read type classes -defaultArgDescr :: (Show a, Read a, Arbitrary a) => String -> ArgDescr a -defaultArgDescr descr = ArgDescr descr Nothing readM show arbitrary - --- | A type class for types which have an argument descriptor -class Arbitrary a => Argument a where - makeArgDescr :: String -> ArgDescr a -- ^ The first argument is the label of the argument descriptor - -instance Argument Int where - makeArgDescr = defaultArgDescr - -instance Argument Integer where - makeArgDescr = defaultArgDescr - -instance (Integral a, Arbitrary a) => Argument (Ratio a) where - makeArgDescr = ratioArgDescr - --- | Parameterization with one argument using a default label -supply1 :: Argument x => - (a -> Maybe x) -> (x -> Transformation a) -> Transformation a -supply1 = supplyLabeled1 "argument 1" - --- | Parameterization with two arguments using default labels -supply2 :: (Argument x, Argument y) => - (a -> Maybe (x, y)) -> (x -> y -> Transformation a) -> Transformation a -supply2 = supplyLabeled2 ("argument 1", "argument 2") - --- | Parameterization with three arguments using default labels -supply3 :: (Argument x, Argument y, Argument z) => - (a -> Maybe (x, y, z)) -> (x -> y -> z -> Transformation a) -> Transformation a -supply3 = supplyLabeled3 ("argument 1", "argument 2", "argument 3") - --- | Parameterization with one argument using the provided label -supplyLabeled1 :: Argument x - => String -> (a -> Maybe x) - -> (x -> Transformation a) -> Transformation a -supplyLabeled1 s f t = - let args = cons (makeArgDescr s) nil - nest a = (a, ()) - in Abstraction args (fmap nest . f) (\(a, ()) -> t a) - -supplyWith1 :: ArgDescr x -> (a -> Maybe x) - -> (x -> Transformation a) -> Transformation a -supplyWith1 descr f t = - let args = cons descr nil - nest a = (a, ()) - in Abstraction args (fmap nest . f) (\(a, ()) -> t a) - --- | Parameterization with two arguments using the provided labels -supplyLabeled2 :: (Argument x, Argument y) - => (String, String) -> (a -> Maybe (x, y)) - -> (x -> y -> Transformation a) -> Transformation a -supplyLabeled2 (s1, s2) f t = - let args = cons (makeArgDescr s1) (cons (makeArgDescr s2) nil) - nest (a, b) = (a, (b, ())) - in Abstraction args (fmap nest . f) (\(a, (b, ())) -> t a b) - --- | Parameterization with three arguments using the provided labels -supplyLabeled3 :: (Argument x, Argument y, Argument z) - => (String, String, String) -> (a -> Maybe (x, y, z)) - -> (x -> y -> z -> Transformation a) -> Transformation a -supplyLabeled3 (s1, s2, s3) f t = - let args = cons (makeArgDescr s1) (cons (makeArgDescr s2) (cons (makeArgDescr s3) nil)) - nest (a, b, c) = (a, (b, (c, ()))) - in Abstraction args (fmap nest . f) (\(a, (b, (c, ()))) -> t a b c) - --- | Checks whether a rule is parameterized -hasArguments :: Rule a -> Bool -hasArguments = not . null . getDescriptors - --- | Returns a list of argument descriptors -getDescriptors :: Rule a -> [Some ArgDescr] -getDescriptors r = - case transformations r of - [t] -> rec t - _ -> [] - where - rec :: Transformation a -> [Some ArgDescr] - rec trans = - case trans of - Abstraction args _ _ -> someArguments args - LiftView _ t -> rec t - Recognizer _ t -> rec t - s :*: t -> rec s ++ rec t - _ -> [] - --- | Returns a list of pretty-printed expected arguments. Nothing indicates that there are no such arguments -expectedArguments :: Rule a -> a -> Maybe [String] -expectedArguments r = - case transformations r of - [t] -> rec t - _ -> const Nothing - where - rec :: Transformation a -> a -> Maybe [String] - rec trans a = - case trans of - Abstraction args f _ -> - fmap (showArguments args) (f a) - LiftView v t -> do - (b, _) <- safeHead (match v a) - rec t b - s :*: t -> - rec s a `mplus` rec t a - Recognizer _ t -> - rec t a - _ -> Nothing - --- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are --- invalid (not parsable), or that the wrong number of arguments was supplied -useArguments :: [String] -> Rule a -> Maybe (Rule a) -useArguments list r = - case transformations r of - [t] -> do new <- make t - return r {transformations = [new]} - _ -> Nothing - where - make :: Transformation a -> Maybe (Transformation a) - make trans = - case trans of - Abstraction args _ g -> fmap g (parseArguments args list) - LiftView v t -> fmap (LiftView v) (make t) - Recognizer f t -> fmap (Recognizer f) (make t) - s :*: t -> fmap (:*: t) (make s) `mplus` - fmap (s :*:) (make t) - _ -> Nothing - ------------------------------------------------------------ ---- Internal machinery for arguments - -data ArgumentList a - = Nil a - | forall b c . Cons ((b, c) -> a, a -> (b, c)) (ArgDescr b) (ArgumentList c) - --- smart constructor -nil :: ArgumentList () -nil = Nil () - --- smart constructor (provides the isomorphism proofs) -cons :: ArgDescr a -> ArgumentList b -> ArgumentList (a, b) -cons = Cons (id, id) - -showArguments :: ArgumentList a -> a -> [String] -showArguments (Nil _) _ = [] -showArguments (Cons (_, f) arg list) a = - let (b, c) = f a - in showArgument arg b : showArguments list c - -parseArguments :: ArgumentList a -> [String] -> Maybe a -parseArguments (Nil a) [] = Just a -parseArguments (Cons (f, _) arg list) (x:xs) = do - b <- parseArgument arg x - c <- parseArguments list xs - return $ f (b, c) -parseArguments _ _ = Nothing - -someArguments :: ArgumentList a -> [Some ArgDescr] -someArguments (Nil _) = [] -someArguments (Cons _ arg list) = Some arg : someArguments list - -ratioArgDescr :: (Integral a, Arbitrary a) => String -> ArgDescr (Ratio a) -ratioArgDescr descr = ArgDescr descr Nothing parseRatio showRatio arbitrary - where - showRatio r = show (numerator r) ++ if denominator r == 1 then "" else '/' : show (denominator r) - parseRatio s = - let readDivOp t = - case dropWhile isSpace t of - ('/':rest) -> return rest - [] -> return "1" - _ -> fail "no (/) operator" - in safeHead [ fromInteger x / fromInteger y - | (x, s1) <- reads s - , s2 <- readDivOp s1 - , (y, s3) <- reads s2 - , y /= 0 - , all isSpace s3 - ] - ------------------------------------------------------------ ---- Rules - --- | Abstract data type for representing rules -data Rule a = Rule - { ruleId :: Id -- ^ Unique identifier of the rule - , transformations :: [Transformation a] - , isBuggyRule :: Bool -- ^ Inspect whether or not the rule is buggy (unsound) - , isMinorRule :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system) - , ruleGroups :: [Id] - , ruleSiblings :: [Id] - } - -instance Show (Rule a) where - show = showId - -instance Eq (Rule a) where - r1 == r2 = ruleId r1 == ruleId r2 - -instance Apply Rule where - applyAll r a = do - t <- transformations r - applyAll t a - -instance HasId (Rule a) where - getId = ruleId - changeId f r = r { ruleId = f (ruleId r) } - --- | Returns whether or not the rule is major (i.e., not minor) -isMajorRule :: Rule a -> Bool -isMajorRule = not . isMinorRule - -isRewriteRule :: Rule a -> Bool -isRewriteRule = not . null . getRewriteRules - -siblingOf :: HasId b => b -> Rule a -> Rule a -siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r } - -addRuleToGroup :: HasId b => b -> Rule a -> Rule a -addRuleToGroup g r = r { ruleGroups = getId g : ruleGroups r } - -ruleList :: (IsId n, RuleBuilder f a, Rewrite a) => n -> [f] -> Rule a -ruleList n = makeRuleList a . map (makeRewriteTrans . rewriteRule a) - where a = newId n - -rule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> Rule a -rule n = makeRule a . makeRewriteTrans . rewriteRule a - where a = newId n - --- | Turn a transformation into a rule: the first argument is the rule's name -makeRule :: IsId n => n -> Transformation a -> Rule a -makeRule n = makeRuleList n . return - --- | Turn a list of transformations into a single rule: the first argument is the rule's name -makeRuleList :: IsId n => n -> [Transformation a] -> Rule a -makeRuleList n ts = Rule (newId n) ts False False [] [] - --- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name -makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a -makeSimpleRule n = makeRule n . makeTrans - --- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name -makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a -makeSimpleRuleList n = makeRule n . makeTransList - --- | A special (minor) rule that always returns the identity -idRule :: Rule a -idRule = minorRule $ makeSimpleRule "Identity" return - --- | A special (minor) rule that checks a predicate (and returns the identity --- if the predicate holds) -checkRule :: (a -> Bool) -> Rule a -checkRule p = minorRule $ makeSimpleRule "Check" $ \a -> - if p a then Just a else Nothing - --- | A special (minor) rule that is never applicable (i.e., this rule always fails) -emptyRule :: Rule a -emptyRule = minorRule $ makeSimpleRule "Empty" (const Nothing) - --- | Mark the rule as minor (by default, rules are not minor) -minorRule :: Rule a -> Rule a -minorRule r = r {isMinorRule = True} - --- | Mark the rule as buggy (by default, rules are supposed to be sound) -buggyRule :: Rule a -> Rule a -buggyRule r = r {isBuggyRule = True} - --- | Perform the function before the rule has been fired -doBefore :: (a -> a) -> Rule a -> Rule a -doBefore f = doBeforeTrans (makeTrans (return . f)) - --- | Perform the function before the rule has been fired -doBeforeTrans :: Transformation a -> Rule a -> Rule a -doBeforeTrans t r = r {transformations = map (t :*:) (transformations r)} - --- | Perform the function after the rule has been fired -doAfter :: (a -> a) -> Rule a -> Rule a -doAfter f r = r {transformations = map make (transformations r)} - where make t = t :*: makeTransList (return . f) - -getRewriteRules :: Rule a -> [(Some RewriteRule, Bool)] -getRewriteRules r = concatMap f (transformations r) - where - f :: Transformation a -> [(Some RewriteRule, Bool)] - f trans = - case trans of - RewriteRule rr _ -> [(Some rr, not $ isBuggyRule r)] - LiftView _ t -> f t - s :*: t -> f s ++ f t - _ -> [] - -ruleRecognizer :: (a -> a -> Bool) -> Rule a -> a -> a -> Bool -ruleRecognizer eq r a b = or - [ transRecognizer eq t a b | t <- transformations r ] - -transRecognizer :: (a -> a -> Bool) -> Transformation a -> a -> a -> Bool -transRecognizer eq trans a b = - case trans of - Recognizer f t -> f a b || transRecognizer eq t a b - LiftView v t -> - any (`eq` b) (applyAll trans a) || or -- ?? Quick Fix - [ transRecognizer (\x y -> eq (f x) (f y)) t av bv - | (av, c) <- match v a - , (bv, _) <- match v b - , let f z = build v (z, c) - ] - _ -> any (`eq` b) (applyAll trans a) - -useRecognizer :: (a -> a -> Bool) -> Transformation a -> Transformation a -useRecognizer = Recognizer - ------------------------------------------------------------ ---- Lifting - -liftTrans :: View a b -> Transformation b -> Transformation a -liftTrans v = liftTransIn (v &&& identity) - -liftTransIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Transformation b -> Transformation a -liftTransIn = LiftView . viewList - -liftRule :: View a b -> Rule b -> Rule a -liftRule v = liftRuleIn (v &&& identity) - -liftRuleIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Rule b -> Rule a -liftRuleIn v r = r - { transformations = map (liftTransIn v) (transformations r) } - ------------------------------------------------------------ ---- QuickCheck - --- | Check the soundness of a rule: the equality function is passed explicitly -testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO () -testRule eq r = - quickCheck (propRule eq r arbitrary) - --- | Check the soundness of a rule and use a "smart generator" for this. The smart generator --- behaves differently on transformations constructed with a (|-), and for these transformations, --- the left-hand side patterns are used (meta variables are instantiated with random terms) -propRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property -propRuleSmart eq r = propRule eq r . smartGen r - -propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property -propRule eq r gen = - forAll gen $ \a -> - forAll (smartApplyRule r a) $ \ma -> - isJust ma ==> (a `eq` fromJust ma) - -smartGen :: Rule a -> Gen a -> Gen a -smartGen r gen = frequency [(2, gen), (1, smart)] - where - smart = gen >>= \a -> - oneof (gen : concatMap (smartGenTrans a) (transformations r)) - -smartGenTrans :: a -> Transformation a -> [Gen a] -smartGenTrans a trans = - case trans of - RewriteRule r _ -> return (smartGenerator r) - LiftView v t -> do - (b, c) <- match v a - gen <- smartGenTrans b t - return $ liftM (\n -> build v (n, c)) gen - s :*: t -> - smartGenTrans a s ++ smartGenTrans a t - _ -> [] - -smartApplyRule :: Rule a -> a -> Gen (Maybe a) -smartApplyRule r a = do - xss <- mapM (`smartApplyTrans` a) (transformations r) - case concat xss of - [] -> return Nothing - xs -> oneof $ map (return . Just) xs - -smartApplyTrans :: Transformation a -> a -> Gen [a] -smartApplyTrans trans a = - case trans of - Abstraction args _ g -> smartArgs args >>= \b -> smartApplyTrans (g b) a - _ -> return (applyAll trans a) - -smartArgs :: ArgumentList a -> Gen a -smartArgs (Nil a) = return a -smartArgs (Cons (f, _) descr xs) = liftM2 (curry f) (genArgument descr) (smartArgs xs) +{-# LANGUAGE GADTs, ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines transformations. Given a term, a transformation returns a list of +-- results (often a singleton list or the empty list). A transformation can be parameterized +-- with one or more arguments. A rule is in essence just a transformation with a name (which +-- should be unique). Both transformations and rules can be lifted to work on more complex domains. +-- +----------------------------------------------------------------------------- +module Common.Transformation + ( -- * Transformations + Transformation, makeTrans, makeTransList, makeRewriteTrans + -- * Arguments + , ArgDescr(..), defaultArgDescr, Argument(..), ArgValue(..), ArgValues + , supply1, supply2, supply3 + , hasArguments, expectedArguments, getDescriptors, useArguments + -- * Rules + , Rule, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule + , finalRule, isFinalRule, ruleSiblings, rule, ruleList + , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList + , idRule, checkRule, emptyRule, minorRule, buggyRule, doAfter + , siblingOf, transformations, getRewriteRules + , ruleRecognizer, useRecognizer, useSimpleRecognizer + -- * Lifting + , liftRule, liftTrans, liftRuleIn, liftTransIn + -- * QuickCheck + , testRule, propRuleSmart + ) where + +import Common.Classes +import Common.Id +import Common.Rewriting +import Common.Utils +import Common.View +import Control.Monad +import Data.Function +import Data.Maybe +import Test.QuickCheck + +----------------------------------------------------------- +--- Transformations + +-- | Abstract data type for representing transformations +data Transformation a + = Function (a -> [a]) + | RewriteRule (RewriteRule a) (a -> [a]) + | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a) + | forall b c . LiftView (View a (b, c)) (Transformation b) + | Recognizer (a -> a -> Maybe ArgValues) (Transformation a) + +instance Apply Transformation where + applyAll (Function f) = f + applyAll (RewriteRule _ f) = f + applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a) + applyAll (LiftView v t) = \a -> [ build v (b, c) | (b0, c) <- matchM v a, b <- applyAll t b0 ] + applyAll (Recognizer _ t) = applyAll t + +-- | Turn a function (which returns its result in the Maybe monad) into a transformation +makeTrans :: (a -> Maybe a) -> Transformation a +makeTrans f = makeTransList (maybe [] return . f) + +-- | Turn a function (which returns a list of results) into a transformation +makeTransList :: (a -> [a]) -> Transformation a +makeTransList = Function + +-- | Turn a rewrite rule into a transformation +makeRewriteTrans :: RewriteRule a -> Transformation a +makeRewriteTrans r = RewriteRule r (rewriteM r) + +----------------------------------------------------------- +--- Arguments + +-- | A data type for describing an argument of a parameterized transformation +data ArgDescr a = ArgDescr + { labelArgument :: String -- ^ Label that is shown to the user when asked to supply the argument + , defaultArgument :: Maybe a -- ^ Default value that can be used + , parseArgument :: String -> Maybe a -- ^ A parser + , showArgument :: a -> String -- ^ A pretty-printer + , termViewArgument :: View Term a -- ^ Conversion to/from term + , genArgument :: Gen a -- ^ An arbitrary argument generator + } + +-- | An argument descriptor, paired with a value +data ArgValue = forall a . ArgValue (ArgDescr a) a + +-- | List of argument values +type ArgValues = [ArgValue] + +instance Show ArgValue where + show (ArgValue descr a) = showArgument descr a + +instance Eq ArgValue where + ArgValue d1 a1 == ArgValue d2 a2 = + build (termViewArgument d1) a1 == build (termViewArgument d2) a2 + +-- | Constructor function for an argument descriptor that uses the Show and Read type classes +defaultArgDescr :: (Show a, Read a, IsTerm a, Arbitrary a) => String -> ArgDescr a +defaultArgDescr descr = ArgDescr descr Nothing readM show termView arbitrary + +-- | A type class for types which have an argument descriptor +class Arbitrary a => Argument a where + makeArgDescr :: String -> ArgDescr a -- ^ The first argument is the label of the argument descriptor + +instance Argument Int where + makeArgDescr = defaultArgDescr + +-- | Parameterization with one argument using the provided label +supply1 :: Argument x + => String -> (a -> Maybe x) + -> (x -> Transformation a) -> Transformation a +supply1 s f t = + let args = Single (makeArgDescr s) + in Abstraction args f t + +-- | Parameterization with two arguments using the provided labels +supply2 :: (Argument x, Argument y) + => (String, String) -> (a -> Maybe (x, y)) + -> (x -> y -> Transformation a) -> Transformation a +supply2 (s1, s2) f t = + let args = Pair (Single (makeArgDescr s1)) (Single (makeArgDescr s2)) + in Abstraction args f (uncurry t) + +-- | Parameterization with three arguments using the provided labels +supply3 :: (Argument x, Argument y, Argument z) + => (String, String, String) -> (a -> Maybe (x, y, z)) + -> (x -> y -> z -> Transformation a) -> Transformation a +supply3 (s1, s2, s3) f t = + let args = Pair (Single (makeArgDescr s1)) + (Pair (Single (makeArgDescr s2)) (Single (makeArgDescr s3))) + nest (a, b, c) = (a, (b, c)) + in Abstraction args (fmap nest . f) (\(a, (b, c)) -> t a b c) + +-- | Checks whether a rule is parameterized +hasArguments :: Rule a -> Bool +hasArguments = not . null . getDescriptors + +-- | Returns a list of argument descriptors +getDescriptors :: Rule a -> [Some ArgDescr] +getDescriptors r = + case transformations r of + [t] -> rec t + _ -> [] + where + rec :: Transformation a -> [Some ArgDescr] + rec trans = + case trans of + Abstraction args _ _ -> someArguments args + LiftView _ t -> rec t + Recognizer _ t -> rec t + _ -> [] + +-- | Returns a list of pretty-printed expected arguments. +-- Nothing indicates that there are no such arguments (or the arguments +-- are not applicable for the current value) +expectedArguments :: Rule a -> a -> Maybe ArgValues +expectedArguments r = + case transformations r of + [t] -> rec t + _ -> const Nothing + where + rec :: Transformation a -> a -> Maybe ArgValues + rec trans a = + case trans of + Abstraction args f _ -> + fmap (argumentValues args) (f a) + LiftView v t -> do + (b, _) <- match v a + rec t b + Recognizer _ t -> + rec t a + _ -> Nothing + +-- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are +-- invalid (not parsable), or that the wrong number of arguments was supplied +useArguments :: [String] -> Rule a -> Maybe (Rule a) +useArguments list r = + case transformations r of + [t] -> do new <- make t + return r {transformations = [new]} + _ -> Nothing + where + make :: Transformation a -> Maybe (Transformation a) + make trans = + case trans of + Abstraction args _ g -> fmap g (parseArguments args list) + LiftView v t -> fmap (LiftView v) (make t) + Recognizer f t -> fmap (Recognizer f) (make t) + _ -> Nothing + +----------------------------------------------------------- +--- Internal machinery for arguments + +data ArgumentList a where + Single :: ArgDescr a -> ArgumentList a + Pair :: ArgumentList a -> ArgumentList b -> ArgumentList (a, b) + +parseArguments :: ArgumentList a -> [String] -> Maybe a +parseArguments (Single a) [x] = parseArgument a x +parseArguments (Pair a b) xs = + let (ys, zs) = splitAt (numberOfArguments a) xs + in liftM2 (,) (parseArguments a ys) (parseArguments b zs) +parseArguments _ _ = Nothing + +someArguments :: ArgumentList a -> [Some ArgDescr] +someArguments (Single a) = [Some a] +someArguments (Pair a b) = someArguments a ++ someArguments b + +argumentValues :: ArgumentList a -> a -> ArgValues +argumentValues (Single a) x = [ArgValue a x] +argumentValues (Pair a b) (x, y) = argumentValues a x ++ argumentValues b y + +numberOfArguments :: ArgumentList a -> Int +numberOfArguments = length . someArguments + +----------------------------------------------------------- +--- Rules + +-- | Abstract data type for representing rules +data Rule a = Rule + { ruleId :: Id -- ^ Unique identifier of the rule + , transformations :: [Transformation a] + , afterwards :: a -> a + , isBuggyRule :: Bool -- ^ Inspect whether or not the rule is buggy (unsound) + , isMinorRule :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system) + , isFinalRule :: Bool -- ^ Final (clean-up) step in derivation + , ruleSiblings :: [Id] + } + +instance Show (Rule a) where + show = showId + +instance Eq (Rule a) where + r1 == r2 = ruleId r1 == ruleId r2 + +instance Ord (Rule a) where + compare = compareId + +instance Apply Rule where + applyAll r a = do + t <- transformations r + b <- applyAll t a + return (afterwards r b) + +instance HasId (Rule a) where + getId = ruleId + changeId f r = r { ruleId = f (ruleId r) } + +instance (Arbitrary a, CoArbitrary a) => Arbitrary (Rule a) where + arbitrary = liftM3 make arbitrary arbitrary arbitrary + where + make minor n f + | minor = minorRule $ makeSimpleRule n f + | otherwise = makeSimpleRule (n :: Id) f + +-- | Returns whether or not the rule is major (i.e., not minor) +isMajorRule :: Rule a -> Bool +isMajorRule = not . isMinorRule + +isRewriteRule :: Rule a -> Bool +isRewriteRule = not . null . getRewriteRules + +siblingOf :: HasId b => b -> Rule a -> Rule a +siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r } + +ruleList :: (IsId n, RuleBuilder f a) => n -> [f] -> Rule a +ruleList n = makeRuleList a . map (makeRewriteTrans . rewriteRule a) + where a = newId n + +rule :: (IsId n, RuleBuilder f a) => n -> f -> Rule a +rule n = makeRule a . makeRewriteTrans . rewriteRule a + where a = newId n + +-- | Turn a transformation into a rule: the first argument is the rule's name +makeRule :: IsId n => n -> Transformation a -> Rule a +makeRule n = makeRuleList n . return + +-- | Turn a list of transformations into a single rule: the first argument is the rule's name +makeRuleList :: IsId n => n -> [Transformation a] -> Rule a +makeRuleList n ts = Rule (newId n) ts id False False False [] + +-- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name +makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a +makeSimpleRule n = makeRule n . makeTrans + +-- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name +makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a +makeSimpleRuleList n = makeRule n . makeTransList + +-- | A special (minor) rule that always returns the identity +idRule :: Rule a +idRule = minorRule $ makeSimpleRule "Identity" return + +-- | A special (minor) rule that checks a predicate (and returns the identity +-- if the predicate holds) +checkRule :: (a -> Bool) -> Rule a +checkRule p = minorRule $ makeSimpleRule "Check" $ \a -> + if p a then Just a else Nothing + +-- | A special (minor) rule that is never applicable (i.e., this rule always fails) +emptyRule :: Rule a +emptyRule = minorRule $ makeSimpleRule "Empty" (const Nothing) + +-- | Mark the rule as minor (by default, rules are not minor) +minorRule :: Rule a -> Rule a +minorRule r = r {isMinorRule = True} + +-- | Mark the rule as buggy (by default, rules are supposed to be sound) +buggyRule :: Rule a -> Rule a +buggyRule r = r {isBuggyRule = True} + +-- | Mark the rule as final (by default, false). Final rules are used as a +-- final step in the derivation, to get the term in the expected form +finalRule :: Rule a -> Rule a +finalRule r = r {isFinalRule = True} + +-- | Perform the function after the rule has been fired +doAfter :: (a -> a) -> Rule a -> Rule a +doAfter f r = r {afterwards = f . afterwards r} + +getRewriteRules :: Rule a -> [(Some RewriteRule, Bool)] +getRewriteRules r = concatMap f (transformations r) + where + f :: Transformation a -> [(Some RewriteRule, Bool)] + f trans = + case trans of + RewriteRule rr _ -> [(Some rr, not $ isBuggyRule r)] + LiftView _ t -> f t + _ -> [] + +ruleRecognizer :: (a -> a -> Bool) -> Rule a -> a -> a -> Maybe ArgValues +ruleRecognizer eq r a b = msum + [ transRecognizer eq t a b | t <- transformations r ] + +transRecognizer :: (a -> a -> Bool) -> Transformation a -> a -> a -> Maybe ArgValues +transRecognizer eq trans a b = + case trans of + Recognizer f t -> f a b `mplus` transRecognizer eq t a b + LiftView v t -> msum + [ transRecognizer (eq `on` f) t av bv + | (av, c) <- matchM v a + , (bv, _) <- matchM v b + , let f z = build v (z, c) + ] + `mplus` + noArg (any (`eq` b) (applyAll trans a)) -- is this really needed? + _ -> noArg $ any (`eq` b) (applyAll trans a) + where + noArg c = if c then Just [] else Nothing + +useRecognizer :: (a -> a -> Maybe ArgValues) -> Transformation a -> Transformation a +useRecognizer = Recognizer + +useSimpleRecognizer :: (a -> a -> Bool) -> Transformation a -> Transformation a +useSimpleRecognizer p = useRecognizer $ \x y -> guard (p x y) >> return [] + +----------------------------------------------------------- +--- Lifting + +liftTrans :: View a b -> Transformation b -> Transformation a +liftTrans v = liftTransIn (v &&& identity) + +liftTransIn :: View a (b, c) -> Transformation b -> Transformation a +liftTransIn = LiftView + +liftRule :: View a b -> Rule b -> Rule a +liftRule v = liftRuleIn (v &&& identity) + +liftRuleIn :: View a (b, c) -> Rule b -> Rule a +liftRuleIn v r = r + { transformations = map (liftTransIn v) (transformations r) + , afterwards = simplifyWith (mapFirst (afterwards r)) v + } + +----------------------------------------------------------- +--- QuickCheck + +-- | Check the soundness of a rule: the equality function is passed explicitly +testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO () +testRule eq r = + quickCheck (propRule eq r arbitrary) + +-- | Check the soundness of a rule and use a "smart generator" for this. The smart generator +-- behaves differently on transformations constructed with a (|-), and for these transformations, +-- the left-hand side patterns are used (meta variables are instantiated with random terms) +propRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property +propRuleSmart eq r = propRule eq r . smartGen r + +propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property +propRule eq r gen = + forAll gen $ \a -> + forAll (smartApplyRule r a) $ \ma -> + isJust ma ==> (a `eq` fromJust ma) + +smartGen :: Rule a -> Gen a -> Gen a +smartGen r gen = frequency [(2, gen), (1, smart)] + where + smart = gen >>= \a -> + oneof (gen : mapMaybe (smartGenTrans a) (transformations r)) + +smartGenTrans :: a -> Transformation a -> Maybe (Gen a) +smartGenTrans a trans = + case trans of + RewriteRule r _ -> return (smartGenerator r) + LiftView v t -> do + (b, c) <- matchM v a + gen <- smartGenTrans b t + return $ liftM (\n -> build v (n, c)) gen + _ -> Nothing + +smartApplyRule :: Rule a -> a -> Gen (Maybe a) +smartApplyRule r a = do + xss <- mapM (`smartApplyTrans` a) (transformations r) + case concat xss of + [] -> return Nothing + xs -> elements $ map Just xs + +smartApplyTrans :: Transformation a -> a -> Gen [a] +smartApplyTrans trans a = + case trans of + Abstraction args _ g -> smartArgs args >>= \b -> smartApplyTrans (g b) a + _ -> return (applyAll trans a) + +smartArgs :: ArgumentList a -> Gen a +smartArgs (Single a) = genArgument a +smartArgs (Pair a b) = liftM2 (,) (smartArgs a) (smartArgs b) diff --git a/src/Common/Uniplate.hs b/src/Common/Uniplate.hs deleted file mode 100644 --- a/src/Common/Uniplate.hs +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Exports a subset of Data.Generics.Uniplate --- ------------------------------------------------------------------------------ -module Common.Uniplate - ( -- * Uniplate type class and utility functions - Uniplate(..), universe, children, holes - , transform, transformM, descend, descendM, rewrite, rewriteM - -- * Additional functions - , leafs - ) where - -import Data.Generics.Uniplate - -leafs :: Uniplate a => a -> [a] -leafs a = case children a of - [] -> [a] - xs -> concatMap leafs xs - -{- ---------------------------------------------------------- --- Uniplate class for generic traversals - -import Common.Utils (safeHead) -import Control.Monad --- | The Uniplate type class offers some light-weight functions for generic traversals. Only --- a minimal set of operations are supported -class Uniplate a where - uniplate :: a -> ([a], [a] -> a) -- ^ Function for generic traversals - --- | Returns all subterms -universe :: Uniplate a => a -> [a] -universe a = a : [ c | b <- children a, c <- universe b ] - --- | Returns all the immediate children of a term -children :: Uniplate a => a -> [a] -children = fst . uniplate - --- | A bottom-up transformation -transform :: Uniplate a => (a -> a) -> a -> a -transform g a = g $ f $ map (transform g) cs - where - (cs, f) = uniplate a - --- | Monadic variant of transform -transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a -transformM g a = mapM (transformM g) cs >>= (g . f) - where - (cs, f) = uniplate a - --- | Applies a function to its immediate children -descend :: Uniplate a => (a -> a) -> a -> a -descend g a = - let (cs, f) = uniplate a - in f (map g cs) - --- | Applies the function at a position until this is no longer possible -rewrite :: Uniplate a => (a -> Maybe a) -> a -> a -rewrite f = transform g - where g x = maybe x (rewrite f) (f x) - --- | Monadic variant of rewrite -rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a -rewriteM f = transformM g - where g x = f x >>= maybe (return x) (rewriteM f) - ---------------------------------------------------------- --- Additional functions - --- | Like universe, but also returns the location of the subterm -subtermsAt :: Uniplate a => a -> [([Int], a)] -subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ] - --- | Selects a child based on a path. Nothing indicates that the path is invalid -getTermAt :: Uniplate a => [Int] -> a -> Maybe a -getTermAt is a = foldM (flip child) a is - where - child n = safeHead . drop n . children - --- | Apply a function to one immediate child. -applyTo :: Uniplate a => Int -> (a -> a) -> a -> a -applyTo n f a = - let (as, build) = uniplate a - g i = if i==n then f else id - in build (zipWith g [0..] as) - --- | Monadic variant of applyTo -applyToM :: (Monad m, Uniplate a) => Int -> (a -> m a) -> a -> m a -applyToM n f a = - let (as, build) = uniplate a - g (i, b) = if i==n then f b else return b - in liftM build $ mapM g (zip [0..] as) - --- | Apply a function at a given position (based on a path). -applyAt :: Uniplate a => [Int] -> (a -> a) -> a -> a -applyAt is f = foldr applyTo f is - --- | Monadic variant of applyAt -applyAtM :: (Monad m, Uniplate a) => [Int] -> (a -> m a) -> a -> m a -applyAtM is f = foldr applyToM f is - -somewhere :: Uniplate a => (a -> a) -> a -> [a] -somewhere f = somewhereM (return . f) - -somewhereM :: (MonadPlus m, Uniplate a) => (a -> m a) -> a -> m a -somewhereM f a = msum $ f a : map g [0..n-1] - where - n = length (children a) - g i = applyToM i (somewhereM f) a --} diff --git a/src/Common/Utils.hs b/src/Common/Utils.hs --- a/src/Common/Utils.hs +++ b/src/Common/Utils.hs @@ -1,133 +1,104 @@ -{-# LANGUAGE ExistentialQuantification #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A collection of general utility functions --- ------------------------------------------------------------------------------ -module Common.Utils where - -import Control.Monad -import Data.Char -import Data.List -import Data.Ratio -import System.Random -import Test.QuickCheck - -data Some f = forall a . Some (f a) - -data ShowString = ShowString { fromShowString :: String } - deriving (Eq, Ord) - -instance Show ShowString where - show = fromShowString - -readInt :: String -> Maybe Int -readInt xs - | null xs = Nothing - | any (not . isDigit) xs = Nothing - | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' - -readM :: (Monad m, Read a) => String -> m a -readM s = case reads s of - [(a, xs)] | all isSpace xs -> return a - _ -> fail ("no read: " ++ s) - -stringToHex :: String -> Maybe Int -stringToHex = foldl op (Just 0) - where - op (Just i) c = fmap (i*16+) (charToHex c) - op Nothing _ = Nothing - -charToHex :: Char -> Maybe Int -charToHex c - | isDigit c = return (ord c - 48) - | toUpper c `elem` ['A' .. 'F'] = return (ord (toUpper c) - 55) - | otherwise = Nothing - -subsets :: [a] -> [[a]] -subsets = foldr op [[]] - where op a list = list ++ map (a:) list - -isSubsetOf :: Eq a => [a] -> [a] -> Bool -isSubsetOf xs ys = all (`elem` ys) xs - -cartesian :: [a] -> [b] -> [(a, b)] -cartesian as bs = [ (a, b) | a <- as, b <- bs ] - -distinct :: Eq a => [a] -> Bool -distinct [] = True -distinct (x:xs) = all (/=x) xs && distinct xs - -allsame :: Eq a => [a] -> Bool -allsame [] = True -allsame (x:xs) = all (==x) xs - -safeHead :: [a] -> Maybe a -safeHead (x:_) = return x -safeHead _ = Nothing - -fixpoint :: Eq a => (a -> a) -> a -> a -fixpoint f = stop . iterate f - where - stop [] = error "Common.Utils: empty list" - stop (x:xs) - | x == head xs = x - | otherwise = stop xs - -fixpointM :: (Monad m, Eq a) => (a -> m a) -> a -> m a -fixpointM f a = do - b <- f a - if a==b then return a else fixpointM f b - -splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) -splitAtElem c s = - case break (==c) s of - (xs, _:ys) -> Just (xs, ys) - _ -> Nothing - -splitsWithElem :: Eq a => a -> [a] -> [[a]] -splitsWithElem c s = - case splitAtElem c s of - Just (xs, ys) -> xs : splitsWithElem c ys - Nothing -> [s] - -splitAtSequence :: Eq a => [a] -> [a] -> Maybe ([a], [a]) -splitAtSequence cs = f [] - where - f _ [] = Nothing - f acc list@(x:xs) - | cs `isPrefixOf` list = Just (reverse acc, drop (length cs) list) - | otherwise = f (x:acc) xs - --- | Use a fixed standard "random" number generator. This generator is --- accessible by calling System.Random.getStdGen -useFixedStdGen :: IO () -useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} - -fst3 :: (a, b, c) -> a -fst3 (x, _, _) = x - -snd3 :: (a, b, c) -> b -snd3 (_, x, _) = x - -thd3 :: (a, b, c) -> c -thd3 (_, _, x) = x - -commaList :: [String] -> String -commaList = concat . intersperse ", " - --- | Prevents a bias towards small numbers -ratioGen :: Integral a => Int -> Int -> Gen (Ratio a) -ratioGen n m = do - a <- choose (-n, n) - b <- liftM (succ . abs) (choose (-m, m)) - c <- choose (1-b, b-1) - return (fromIntegral a + (fromIntegral c / fromIntegral b)) +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A collection of general utility functions +-- +----------------------------------------------------------------------------- +module Common.Utils + ( Some(..), ShowString(..), readInt, readM + , subsets, isSubsetOf + , cartesian, distinct, allsame + , safeHead, fixpoint + , splitAtElem, splitsWithElem + , useFixedStdGen, fst3, snd3, thd3, commaList + ) where + +import Data.Char +import Data.List +import System.Random + +data Some f = forall a . Some (f a) + +data ShowString = ShowString { fromShowString :: String } + deriving (Eq, Ord) + +instance Show ShowString where + show = fromShowString + +readInt :: String -> Maybe Int +readInt xs + | null xs = Nothing + | any (not . isDigit) xs = Nothing + | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' + +readM :: (Monad m, Read a) => String -> m a +readM s = case reads s of + [(a, xs)] | all isSpace xs -> return a + _ -> fail ("no read: " ++ s) + +subsets :: [a] -> [[a]] +subsets = foldr op [[]] + where op a list = list ++ map (a:) list + +isSubsetOf :: Eq a => [a] -> [a] -> Bool +isSubsetOf xs ys = all (`elem` ys) xs + +cartesian :: [a] -> [b] -> [(a, b)] +cartesian as bs = [ (a, b) | a <- as, b <- bs ] + +distinct :: Eq a => [a] -> Bool +distinct [] = True +distinct (x:xs) = all (/=x) xs && distinct xs + +allsame :: Eq a => [a] -> Bool +allsame [] = True +allsame (x:xs) = all (==x) xs + +safeHead :: [a] -> Maybe a +safeHead (x:_) = return x +safeHead _ = Nothing + +fixpoint :: Eq a => (a -> a) -> a -> a +fixpoint f = stop . iterate f + where + stop [] = error "Common.Utils: empty list" + stop (x:xs) + | x == head xs = x + | otherwise = stop xs + +splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) +splitAtElem c s = + case break (==c) s of + (xs, _:ys) -> Just (xs, ys) + _ -> Nothing + +splitsWithElem :: Eq a => a -> [a] -> [[a]] +splitsWithElem c s = + case splitAtElem c s of + Just (xs, ys) -> xs : splitsWithElem c ys + Nothing -> [s] + +-- | Use a fixed standard "random" number generator. This generator is +-- accessible by calling System.Random.getStdGen +useFixedStdGen :: IO () +useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} + +fst3 :: (a, b, c) -> a +fst3 (x, _, _) = x + +snd3 :: (a, b, c) -> b +snd3 (_, x, _) = x + +thd3 :: (a, b, c) -> c +thd3 (_, _, x) = x + +commaList :: [String] -> String +commaList = intercalate ", " diff --git a/src/Common/Utils/QuickCheck.hs b/src/Common/Utils/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Common/Utils/QuickCheck.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Extensions to the QuickCheck library +-- +----------------------------------------------------------------------------- +module Common.Utils.QuickCheck + ( module Test.QuickCheck + -- * Data type + , ArbGen, generator, generators + -- * Constructors + , arbGen, constGen, constGens, unaryGen, unaryGens + , unaryArbGen, binaryGen, binaryGens, toArbGen + -- * Frequency combinators + , common, uncommon, rare, changeFrequency + ) where + +import Control.Arrow +import Control.Monad +import Data.Monoid +import Data.Ratio +import Test.QuickCheck + +--------------------------------------------------------- +-- @ArbGen@ datatype + +newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))] + +instance Monoid (ArbGen a) where + mempty = AG mempty + AG xs `mappend` AG ys = AG (xs `mappend` ys) + +generator :: ArbGen a -> Gen a +generator (AG pairs) = sized rec + where + factor = foldr (lcm . denominator . fst) 1 pairs + rec n = frequency (map make (select pairs)) + where + select + | n == 0 = filter ((==0) . fst . snd) + | otherwise = id + make (r, (a, gf)) = + let m = round (fromInteger factor*r) + xs = replicateM a $ rec $ n `div` 2 + in (m, liftM2 ($) gf xs) + +generators :: [ArbGen a] -> Gen a +generators = generator . mconcat + +--------------------------------------------------------- +-- Constructors + +arbGen :: Arbitrary b => (b -> a) -> ArbGen a +arbGen f = newGen 0 (liftM (const . f) arbitrary) + +constGen :: a -> ArbGen a +constGen = pureGen 0 . const + +constGens :: [a] -> ArbGen a +constGens = mconcat . map constGen + +unaryGen :: (a -> a) -> ArbGen a +unaryGen f = pureGen 1 (f . head) + +unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a +unaryArbGen f = newGen 1 $ liftM (\a -> f a . head) arbitrary + +unaryGens :: [a -> a] -> ArbGen a +unaryGens = mconcat . map unaryGen + +binaryGen :: (a -> a -> a) -> ArbGen a +binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1)) + +binaryGens :: [a -> a -> a] -> ArbGen a +binaryGens = mconcat . map binaryGen + +pureGen :: Int -> ([a] -> a) -> ArbGen a +pureGen n = newGen n . return + +toArbGen :: Gen a -> ArbGen a +toArbGen = newGen 0 . liftM const + +newGen :: Int -> Gen ([a] -> a) -> ArbGen a +newGen n f = AG [(1, (n, f))] + +--------------------------------------------------------- +-- Frequency combinators + +common, uncommon, rare :: ArbGen a -> ArbGen a +common = changeFrequency 2 +uncommon = changeFrequency (1/2) +rare = changeFrequency (1/5) + +changeFrequency :: Rational -> ArbGen a -> ArbGen a +changeFrequency r (AG xs) = AG (map (first (*r)) xs) diff --git a/src/Common/Utils/StringRef.hs b/src/Common/Utils/StringRef.hs new file mode 100644 --- /dev/null +++ b/src/Common/Utils/StringRef.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- References to Strings, proving a fast comparison implementation (Eq and +-- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy +-- Virutal Machine (LVM) identifiers. +-- +----------------------------------------------------------------------------- +module Common.Utils.StringRef + ( StringRef, stringRef, toString, tableStatus + ) where + +import Common.Utils (commaList) +import Data.Bits +import Data.IORef +import Data.List +import System.IO.Unsafe +import qualified Data.IntMap as IM + +---------------------------------------------------------------- +-- StringRef datatype and instance declarations + +data StringRef = S !Int + deriving (Eq, Ord) + +---------------------------------------------------------------- +-- Hash table + +type HashTable = IM.IntMap [String] + +tableRef :: IORef HashTable +tableRef = unsafePerformIO (newIORef IM.empty) + +---------------------------------------------------------------- +-- Conversion to and from strings + +stringRef :: String -> StringRef +stringRef s = unsafePerformIO $ do + let hash = hashString s + m <- readIORef tableRef + case IM.insertLookupWithKey (\_ -> combine) hash [s] m of + (Nothing, new) -> do + writeIORef tableRef new + return (S (encodeIndexZero hash)) + (Just old, new) -> + case findIndex (==s) old of + Just index -> + return (S (encode hash index)) + Nothing -> do + let index = length old + writeIORef tableRef new + return (S (encode hash index)) + +toString :: StringRef -> String +toString (S i) = unsafePerformIO $ do + m <- readIORef tableRef + case IM.lookup (extractHash i) m of + Just xs -> return (atIndex (extractIndex i) xs) + Nothing -> intErr "id not found" + +---------------------------------------------------------------- +-- Bit encoding + +encode :: Int -> Int -> Int +encode hash index = hash + index `shiftL` 12 + +encodeIndexZero :: Int -> Int +encodeIndexZero hash = hash + +extractHash :: Int -> Int +extractHash i = i `mod` 4096 + +extractIndex :: Int -> Int +extractIndex i = i `shiftR` 12 + +---------------------------------------------------------------- +-- Hash function + +-- simple hash function that performs quite good in practice +hashString :: String -> Int +hashString s = (f s `mod` prime) `mod` maxHash + where + f = foldl' next 0 -- ' strict fold + next n c = n*65599 + fromEnum c + prime = 32537 --65599 -- require: prime < maxHash + +maxHash :: Int +maxHash = 0xFFF -- 12 bits + +---------------------------------------------------------------- +-- Utility functions + +atIndex :: Int -> [a] -> a +atIndex 0 (x:_) = x +atIndex i (_:xs) = atIndex (i-1) xs +atIndex _ _ = intErr "corrupt symbol table" + +combine :: Eq a => [a] -> [a] -> [a] +combine [a] = rec + where + rec [] = [a] + rec this@(x:xs) + | a == x = this + | otherwise = x:rec xs +combine _ = intErr "combine" + +intErr :: String -> a +intErr s = error ("Internal error in Common.StringRef: " ++ s) + +---------------------------------------------------------------- +-- Testing and debugging + +tableStatus :: IO String +tableStatus = readIORef tableRef >>= \m -> + let xs = map f (IM.assocs m) + f (i, ys) = '#' : show i ++ ": " ++ commaList (map g (frequency ys)) ++ + " [total = " ++ show (length ys) ++ "]" + g (a, n) | n == 1 = show a + | otherwise = show a ++ " (" ++ show n ++ ")" + in return $ unlines xs + +frequency :: Eq a => [a] -> [(a, Int)] +frequency [] = [] +frequency (x:xs) = + let (ys, zs) = partition (==x) xs + in (x, 1+length ys) : frequency zs diff --git a/src/Common/Utils/TestSuite.hs b/src/Common/Utils/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/Common/Utils/TestSuite.hs @@ -0,0 +1,293 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A lightweight wrapper around the QuickCheck library. It introduces the +-- notion of a test suite, and it stores the test results for later inspection +-- (e.g., for the generation of a test report). A test suite has a monadic +-- interface. +-- +----------------------------------------------------------------------------- +module Common.Utils.TestSuite + ( -- * Test Suite Monad + TestSuite, MonadIO(..) + -- * Test suite constructors + , suite, addProperty, addPropertyWith, warn + , assertTrue, assertNull, assertEquals, assertIO + -- * Running a test suite + , runTestSuite, runTestSuiteResult + -- * Test Suite Result + , TestSuiteResult, subResults, findSubResult + , messages, topMessages, numberOfTests + , makeSummary, printSummary + -- * Messages + , Message, newMessage + , isError, warning, messageLabel + ) where + +import Control.Monad.State +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Time +import Test.QuickCheck +import qualified Data.Foldable as F +import qualified Data.Sequence as S + +---------------------------------------------------------------- +-- Test Suite Monad + +newtype TestSuiteM a = TSM { unTSM :: StateT Content IO a } + +data Content = C + { column :: !Int -- Number of characters on the current line, for formatting + , result :: !TestSuiteResult + } + +type TestSuite = TestSuiteM () + +instance Monad TestSuiteM where + return = TSM . return + m >>= f = TSM (unTSM m >>= unTSM . f) + fail s = do assertTrue s False + return (error "TestSuite.fail: do not bind result") + +instance MonadIO TestSuiteM where + liftIO = TSM . liftIO + +instance Monoid a => Monoid (TestSuiteM a) where + mempty = return mempty + mappend = (>>) + +---------------------------------------------------------------- +-- Test suite constructors + +-- | Construct a (named) test suite containing tests and other suites +suite :: String -> TestSuite -> TestSuite +suite s m = TSM $ do + newline + liftIO $ putStrLn s + reset + t <- updateDiffTime (withEmptyTree (unTSM m)) + addResult (suiteResult s t) + +-- | Add a QuickCheck property to the test suite. The first argument is +-- a label for the property +addProperty :: Testable prop => String -> prop -> TestSuite +addProperty = flip addPropertyWith stdArgs + +-- | Add a QuickCheck property to the test suite, also providing a test +-- configuration (Args) +addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite +addPropertyWith s args p = TSM $ do + newlineIndent + r <- liftIO $ quickCheckWithResult args p + reset + let f = addResult . messageResult . setLabel s + maybe (addResult okResult) f (toTestResult r) + +assertTrue :: String -> Bool -> TestSuite +assertTrue msg = assertIO msg . return + +assertNull :: Show a => String -> [a] -> TestSuite +assertNull s xs = addAssertion (f xs) (return (null xs)) + where f = setLabel s . newMessage . intercalate "\n" . map show + +assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite +assertEquals s x y = addAssertion (setLabel s msg) (return (x==y)) + where msg = newMessage ("Not equal: " ++ show x ++ " and " ++ show y) + +assertIO :: String -> IO Bool -> TestSuite +assertIO s = addAssertion (setLabel s $ newMessage "Assertion failed") + +warn :: String -> TestSuite +warn = (`addAssertion` return False) . warning . newMessage + +-- local helpers +addAssertion :: Message -> IO Bool -> TestSuite +addAssertion msg io = TSM $ do + b <- liftIO (io `catch` \_ -> return False) + if b then do + dot + addResult okResult + else do + newlineIndent + liftIO (print msg) + reset + addResult (messageResult msg) + +withEmptyTree :: StateT Content IO () -> StateT Content IO TestSuiteResult +withEmptyTree m = do + t0 <- gets result + modify $ \c -> c {result = mempty} + m + tr <- gets result + modify $ \c -> c {result = t0} + return tr + +-- formatting helpers +newline :: StateT Content IO () +newline = do + i <- gets column + when (i>0) (liftIO $ putChar '\n') + reset + +newlineIndent :: StateT Content IO () +newlineIndent = do + newline + liftIO $ putStr " " + modify $ \c -> c {column = 3} + +dot :: StateT Content IO () +dot = do + i <- gets column + unless (i>0 && i<60) newlineIndent + liftIO $ putChar '.' + modify $ \c -> c {column = column c+1} + +addResult :: TestSuiteResult -> StateT Content IO () +addResult r = modify $ \c -> c {result = result c `mappend` r} + +reset :: StateT Content IO () +reset = modify $ \c -> c {column = 0} + +---------------------------------------------------------------- +-- Running a test suite + +runTestSuite :: TestSuite -> IO () +runTestSuite s = runTestSuiteResult s >> return () + +runTestSuiteResult :: TestSuite -> IO TestSuiteResult +runTestSuiteResult s = + updateDiffTime $ liftM result $ + execStateT (unTSM s >> newline) (C 0 mempty) + +---------------------------------------------------------------- +-- Test Suite Result + +data TestSuiteResult = TSR + { messageSeq :: S.Seq Message + , suiteSeq :: S.Seq (String, TestSuiteResult) + , numberOfTests :: !Int + , diffTime :: !NominalDiffTime + } + +instance Monoid TestSuiteResult where + mempty = TSR mempty mempty 0 0 + mappend x y = TSR + { messageSeq = messageSeq x `mappend` messageSeq y + , suiteSeq = suiteSeq x `mappend` suiteSeq y + , numberOfTests = numberOfTests x + numberOfTests y + , diffTime = diffTime x + diffTime y + } + +okResult :: TestSuiteResult +okResult = mempty {numberOfTests = 1} + +messageResult :: Message -> TestSuiteResult +messageResult m = okResult {messageSeq = S.singleton m} + +suiteResult :: String -> TestSuiteResult -> TestSuiteResult +suiteResult s a = mempty + { suiteSeq = S.singleton (s, a) + , numberOfTests = numberOfTests a + } + +-- one-line summary +instance Show TestSuiteResult where + show res = + let (xs, ys) = partition isError (messages res) + in "(tests: " ++ show (numberOfTests res) ++ + ", errors: " ++ show (length xs) ++ + ", warnings: " ++ show (length ys) ++ + ", " ++ show (diffTime res) ++ ")" + +subResults :: TestSuiteResult -> [(String, TestSuiteResult)] +subResults = F.toList . suiteSeq + +topMessages :: TestSuiteResult -> [Message] +topMessages = F.toList . messageSeq + +messages :: TestSuiteResult -> [Message] +messages res = + topMessages res ++ concatMap (messages . snd) (subResults res) + +data Message = Message + { message :: String + , isError :: Bool + , messageLabel :: Maybe String + } + +instance Show Message where + show a = (if null pre then "" else pre ++ ": ") ++ message a + where + parens s = "(" ++ s ++ ")" + pre = unwords $ + [ "Warning" | not (isError a) ] ++ + maybe [] (return . parens) (messageLabel a) + +newMessage :: String -> Message +newMessage s = Message s True Nothing + +warning :: Message -> Message +warning m = m {isError = False} + +setLabel :: String -> Message -> Message +setLabel s m = m {messageLabel = Just s} + +findSubResult :: String -> TestSuiteResult -> Maybe TestSuiteResult +findSubResult name = listToMaybe . recs + where + recs = concatMap rec . subResults + rec (n, t) + | n == name = [t] + | otherwise = recs t + +printSummary :: TestSuiteResult -> IO () +printSummary = putStrLn . makeSummary + +makeSummary :: TestSuiteResult -> String +makeSummary res = unlines $ + [ line + , "Tests : " ++ show (numberOfTests res) + , "Failures : " ++ show (length xs) + , "Warnings : " ++ show (length ys) + , "\nTime : " ++ show (diffTime res) + , "\nSuites: " + ] ++ map f (subResults res) + ++ [line] + where + line = replicate 75 '-' + (xs, ys) = partition isError (messages res) + f (name, r) = " " ++ name ++ " " ++ show r + +----------------------------------------------------- +-- Utility functions + +toTestResult :: Result -> Maybe Message +toTestResult res = + let make = Just . newMessage + in case res of + Success _ _ _ -> Nothing + Failure _ _ _ _ msg _ _ -> make msg + NoExpectedFailure _ _ _ -> make "no expected failure" + GaveUp i _ _ -> fmap warning $ make $ + "passed only " ++ show i ++ " tests" + +updateDiffTime :: MonadIO m => m TestSuiteResult -> m TestSuiteResult +updateDiffTime m = do + (res, d) <- getDiffTime m + return res {diffTime = d} + +getDiffTime :: MonadIO m => m a -> m (a, NominalDiffTime) +getDiffTime action = do + t0 <- liftIO getCurrentTime + a <- action + t1 <- liftIO getCurrentTime + return (a, diffUTCTime t1 t0) diff --git a/src/Common/Utils/Uniplate.hs b/src/Common/Utils/Uniplate.hs new file mode 100644 --- /dev/null +++ b/src/Common/Utils/Uniplate.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exports a subset of Data.Generics.Uniplate.Direct (the @Uniplate@ type +-- class and its utility plus constructor functions) +-- +----------------------------------------------------------------------------- +module Common.Utils.Uniplate + ( -- * Uniplate type class and utility functions + Uniplate + , children, contexts, descend, descendM, holes, para + , rewrite, rewriteM, transform, transformM, uniplate, universe + -- * Instance constructors + , (|-), (|*), (||*), plate + ) where + +import Data.Generics.Uniplate.Direct diff --git a/src/Common/View.hs b/src/Common/View.hs --- a/src/Common/View.hs +++ b/src/Common/View.hs @@ -1,217 +1,282 @@ -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- This module defines views on data-types, as described in "Canonical Forms --- in Interactive Exercise Assistants" --- ------------------------------------------------------------------------------ -module Common.View - ( -- * Generalized monadic views - ViewM, match, build, newView, makeView, biArr, identity, (>>>) - , canonical, canonicalWith - , Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..) - -- * Simple views - , View, ViewList, Match, belongsTo - , simplify, simplifyWith, viewEquivalent, viewEquivalentWith - , isCanonical, isCanonicalWith, matchM, canonicalM, viewList - -- * Some combinators - , swapView, listView, switchView, associativeView - -- * Properties on views - , propIdempotence, propSoundness, propNormalForm - ) where - -import Common.Id -import Common.Classes -import Control.Arrow -import Control.Monad -import Data.Maybe -import Test.QuickCheck -import qualified Control.Category as C - ----------------------------------------------------------------------------------- --- Generalized monadic view - -data ViewM m a b where - Prim :: Id -> (a -> m b) -> (b -> a) -> ViewM m a b - (:>>>:) :: ViewM m a b -> ViewM m b c -> ViewM m a c - First :: ViewM m a b -> ViewM m (a, c) (b, c) - Second :: ViewM m b c -> ViewM m (a, b) (a, c) - (:***:) :: ViewM m a c -> ViewM m b d -> ViewM m (a, b) (c, d) - (:&&&:) :: ViewM m a b -> ViewM m a c -> ViewM m a (b, c) - VLeft :: ViewM m a b -> ViewM m (Either a c) (Either b c) - VRight :: ViewM m b c -> ViewM m (Either a b) (Either a c) - (:+++:) :: ViewM m a c -> ViewM m b d -> ViewM m (Either a b) (Either c d) - (:|||:) :: ViewM m a c -> ViewM m b c -> ViewM m (Either a b) c - -instance Monad m => C.Category (ViewM m) where - id = identity - v . w = w :>>>: v - -instance Monad m => Arrow (ViewM m) where - arr f = Prim (newId "views.arr") (return . f) (error "Control.View.arr: function is not invertible") - first = First - second = Second - (***) = (:***:) - (&&&) = (:&&&:) - -instance Monad m => ArrowChoice (ViewM m) where - left = VLeft - right = VRight - (+++) = (:+++:) - (|||) = (:|||:) - ----------------------------------------------------------------------------------- --- Operations on a view - --- The preferred way of constructing a view -newView :: (IsId n, Monad m) => n -> (a -> m b) -> (b -> a) -> ViewM m a b -newView = Prim . newId - -makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b -makeView = newView "views.makeView" - -biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b -biArr f = makeView (return . f) - -match :: Monad m => ViewM m a b -> a -> m b -match view = - case view of - Prim _ f _ -> f - v :>>>: w -> \a -> match v a >>= match w - First v -> \(a, c) -> match v a >>= \b -> return (b, c) - Second v -> \(a, b) -> match v b >>= \c -> return (a, c) - v :***: w -> \(a, c) -> liftM2 (,) (match v a) (match w c) - v :&&&: w -> \a -> liftM2 (,) (match v a) (match w a) - VLeft v -> either (liftM Left . match v) (return . Right) - VRight v -> either (return . Left) (liftM Right . match v) - v :+++: w -> either (liftM Left . match v) (liftM Right . match w) - v :|||: w -> either (match v) (match w) - -build :: ViewM m a b -> b -> a -build view = - case view of - Prim _ _ f -> f - v :>>>: w -> build v . build w - First v -> first (build v) - Second v -> second (build v) - v :***: w -> build v *** build w - v :&&&: _ -> build v . fst -- left-biased - VLeft v -> either (Left . build v) Right - VRight v -> either Left (Right . build v) - v :+++: w -> either (Left . build v) (Right . build w) - v :|||: _ -> Left . build v -- left-biased - -canonical :: Monad m => ViewM m a b -> a -> m a -canonical = canonicalWith id - -canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a -canonicalWith f view = liftM (build view . f) . match view - ---------------------------------------------------------------- --- Simple views (based on a particular monad) - -type View = ViewM Maybe -type ViewList = ViewM [] -type Match a b = a -> Maybe b - -simplify :: View a b -> a -> a -simplify = simplifyWith id - -simplifyWith :: (b -> b) -> View a b -> a -> a -simplifyWith f view a = fromMaybe a (canonicalWith f view a) - -belongsTo :: a -> View a b -> Bool -belongsTo a view = isJust (match view a) - -viewEquivalent :: Eq b => View a b -> a -> a -> Bool -viewEquivalent = viewEquivalentWith (==) - -viewEquivalentWith :: (b -> b -> Bool) -> View a b -> a -> a -> Bool -viewEquivalentWith eq view x y = - case (match view x, match view y) of - (Just a, Just b) -> a `eq` b - _ -> False - -isCanonical :: Eq a => View a b -> a -> Bool -isCanonical = isCanonicalWith (==) - -isCanonicalWith :: (a -> a -> Bool) -> View a b -> a -> Bool -isCanonicalWith eq v a = maybe False (eq a) (canonical v a) - --- generalized match on a ViewM Maybe -matchM :: Monad m => View a b -> a -> m b -matchM v = maybe (Prelude.fail "no match") return . match v - --- generalized canonical element on a ViewM Maybe -canonicalM :: Monad m => View a b -> a -> m a -canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v - -viewList :: (Crush m, Monad m) => ViewM m a b -> ViewList a b -viewList v = makeView (crush . match v) (build v) - ---------------------------------------------------------------- --- Some combinators - -identity :: Monad m => ViewM m a a -identity = newView "views.identity" return id - -swapView :: View (a, b) (b, a) -swapView = - let swap (a, b) = (b, a) - in newView "views.swap" (return . swap) swap - -listView :: Monad m => ViewM m a b -> ViewM m [a] [b] -listView v = makeView (mapM (match v)) (map (build v)) - -switchView :: (Monad m, Switch f) => ViewM m a b -> ViewM m (f a) (f b) -switchView v = makeView (switch . fmap (match v)) (fmap (build v)) - -associativeView :: View a (a, a) -> ViewList a (a, a) -associativeView v = makeView (reverse . f) (build v) - where f a = - case matchM v a of - Just (x, y) -> [(x, y)] ++ [(x1, build v (x2, y)) | (x1, x2) <- f x] - ++ [(build v (x, y1), y2) | (y1, y2) <- f y] - Nothing -> [] - ---------------------------------------------------------------- --- Properties on views - -propIdempotence :: (Show a, Eq a) => Gen a -> View a b -> Property -propIdempotence g v = forAll g $ \a -> - let b = simplify v a - in b == simplify v b - -propSoundness :: Show a => (a -> a -> Bool) -> Gen a -> View a c -> Property -propSoundness semEq g v = forAll g $ \a -> - let b = simplify v a - in semEq a b - -propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines views on data-types, as described in "Canonical Forms +-- in Interactive Exercise Assistants" +-- +----------------------------------------------------------------------------- +module Common.View + ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..) + , Control.Arrow.ArrowZero(..), Control.Arrow.ArrowPlus(..) + , (>>>), (<<<) + -- * @IsMatch@ type class + , IsMatch(..), matchM, belongsTo, viewEquivalent, viewEquivalentWith + , Match, makeMatch + -- * @IsView@ type class + , IsView(..), simplify, simplifyWith + , canonical, canonicalWith, canonicalWithM, isCanonical, isCanonicalWith + -- * Views + , View, identity, makeView, matcherView + -- * Isomorphisms + , Isomorphism, from, to + -- * Some combinators + , swapView, listView, traverseView, ($<) + -- * Packaging a view + , ViewPackage(..) + -- * Properties on views + , propIdempotence, propSoundness, propNormalForm + ) where + +import Common.Classes +import Common.Id +import Control.Arrow +import Control.Monad +import Data.Maybe +import Test.QuickCheck +import qualified Control.Category as C +import qualified Data.Traversable as T + +---------------------------------------------------------------------------------- +-- @IsMatch@ type class + +class IsMatch f where + match :: f a b -> a -> Maybe b + matcher :: f a b -> Match a b + -- default definitions + match = runKleisli . unM . matcher + matcher = makeMatch . match + +-- |generalized monadic variant of @match@ +matchM :: (Monad m, IsMatch f) => f a b -> a -> m b +matchM v = maybe (fail "no match") return . match v + +belongsTo :: IsMatch f => a -> f a b -> Bool +belongsTo a view = isJust (match view a) + +viewEquivalent :: (IsMatch f, Eq b) => f a b -> a -> a -> Bool +viewEquivalent = viewEquivalentWith (==) + +viewEquivalentWith :: IsMatch f => (b -> b -> Bool) -> f a b -> a -> a -> Bool +viewEquivalentWith eq view x y = + case (match view x, match view y) of + (Just a, Just b) -> a `eq` b + _ -> False + +newtype Match a b = M { unM :: Kleisli Maybe a b } + deriving (C.Category, Arrow, ArrowZero, ArrowPlus, ArrowChoice) + +instance IsMatch Match where + matcher = id + +makeMatch :: (a -> Maybe b) -> Match a b +makeMatch = M . Kleisli + +---------------------------------------------------------------------------------- +-- @IsView@ type class + +-- |Minimal complete definition: @toView@ or both @match@ and @build@. +class IsMatch f => IsView f where + build :: f a b -> b -> a + toView :: f a b -> View a b + -- default definitions + build f = build (toView f) + toView f = makeView (match f) (build f) + +canonical :: IsView f => f a b -> a -> Maybe a +canonical = canonicalWith id + +canonicalWith :: IsView f => (b -> b) -> f a b -> a -> Maybe a +canonicalWith f = canonicalWithM (return . f) + +canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a +canonicalWithM f view a = + match view a >>= liftM (build view) . f + +isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool +isCanonical = isCanonicalWith (==) + +isCanonicalWith :: IsView f => (a -> a -> Bool) -> f a b -> a -> Bool +isCanonicalWith eq v a = maybe False (eq a) (canonical v a) + +simplify :: IsView f => f a b -> a -> a +simplify = simplifyWith id + +simplifyWith :: IsView f => (b -> b) -> f a b -> a -> a +simplifyWith f view a = fromMaybe a (canonicalWith f view a) + +---------------------------------------------------------------------------------- +-- Views + +data View a b where + Prim :: Match a b -> (b -> a) -> View a b + (:@) :: Id -> View a b -> View a b + (:>>>:) :: View a b -> View b c -> View a c + (:***:) :: View a c -> View b d -> View (a, b) (c, d) + (:+++:) :: View a c -> View b d -> View (Either a b) (Either c d) + Traverse :: T.Traversable f => View a b -> View (f a) (f b) + +instance C.Category View where + id = makeView return id + v . w = w :>>>: v + +instance Arrow View where + arr = (!->) + first = (*** identity) + second = (identity ***) + (***) = (:***:) + f &&& g = copy >>> (f *** g) + +instance BiArrow View where + (<->) f = makeView (return . f) + +instance ArrowChoice View where + left = (+++ identity) + right = (identity +++) + (+++) = (:+++:) + f ||| g = (f +++ g) >>> merge + +instance IsMatch View where + matcher view = + case view of + Prim m _ -> m + _ :@ v -> matcher v + v :>>>: w -> matcher v >>> matcher w + v :***: w -> matcher v *** matcher w + v :+++: w -> matcher v +++ matcher w + Traverse v -> makeMatch $ T.mapM (match v) + +instance IsView View where + build view = + case view of + Prim _ f -> f + _ :@ v -> build v + v :>>>: w -> build v <<< build w + v :***: w -> build v *** build w + v :+++: w -> biMap (build v) (build w) + Traverse v -> fmap (build v) + + toView = id + +instance HasId (View a b) where + getId (n :@ _) = n + getId _ = mempty + changeId f (n :@ a) = f n :@ a + changeId f a = f mempty :@ a + +instance Identify (View a b) where + n @> v | isEmptyId a = v + | otherwise = a :@ v + where + a = newId n + +makeView :: (a -> Maybe b) -> (b -> a) -> View a b +makeView = matcherView . makeMatch + +matcherView :: Match a b -> (b -> a) -> View a b +matcherView = Prim + +identity :: C.Category f => f a a +identity = C.id + +---------------------------------------------------------------------------------- +-- Isomorphisms (embedding-projection pairs) + +-- to ep . from ep == id +data Isomorphism a b = EP { pid :: Id, from :: a -> b, to :: b -> a } + +instance C.Category Isomorphism where + id = id <-> id + f . g = from f . from g <-> to g . to f + +instance Arrow Isomorphism where + arr = (!->) + first = (*** identity) + second = (identity ***) + p *** q = from p *** from q <-> to p *** to q + f &&& g = copy >>> (f *** g) + +instance BiArrow Isomorphism where + (<->) = EP mempty + +instance ArrowChoice Isomorphism where + left = (+++ identity) + right = (identity +++) + p +++ q = from p +++ from q <-> to p +++ to q + f ||| g = (f +++ g) >>> merge + +instance IsMatch Isomorphism where + match p = Just . from p + +instance IsView Isomorphism where + toView p = getId p @> makeView (match p) (to p) + +instance HasId (Isomorphism a b) where + getId = pid + changeId f p = p { pid = f (pid p) } + +instance Identify (Isomorphism a b) where + (@>) = changeId . const . newId + +---------------------------------------------------------------------------------- +-- Some combinators + +swapView :: Isomorphism (a, b) (b, a) +swapView = "views.swap" @> swap + +-- | Specialized version of traverseView +listView :: View a b -> View [a] [b] +listView = traverseView + +-- or is liftView a better name? +traverseView :: T.Traversable f => View a b -> View (f a) (f b) +traverseView = Traverse + +($<) :: T.Traversable f => View a (f b) -> View b c -> View a (f c) +a $< b = a >>> traverseView b + +swap :: BiArrow arr => arr (a, b) (b, a) +swap = f <-> f + where + f :: (a, b) -> (b, a) + f (a, b) = (b, a) + +copy :: BiArrow arr => arr a (a, a) +copy = (\a -> (a, a)) <-> fst + +merge :: BiArrow arr => arr (Either a a) a +merge = either id id <-> Left + +---------------------------------------------------------------------------------- +-- Packaging a view for documentation purposes + +data ViewPackage where + ViewPackage :: + (Show a, Show b, Eq a) => (String -> Maybe a) -> View a b -> ViewPackage + +instance HasId ViewPackage where + getId (ViewPackage _ a) = getId a + changeId f (ViewPackage p a) = ViewPackage p (changeId f a) + +---------------------------------------------------------------------------------- +-- Properties on views + +propIdempotence :: (Show a, Eq a) => Gen a -> View a b -> Property +propIdempotence g v = forAll g $ \a -> + let b = simplify v a + in b == simplify v b + +propSoundness :: Show a => (a -> a -> Bool) -> Gen a -> View a c -> Property +propSoundness semEq g v = forAll g $ \a -> + let b = simplify v a + in semEq a b + +propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property propNormalForm g v = forAll g $ \a -> a == simplify v a - -{- proving a parameterized view equivalent to one with a "context" - -abstr1 :: (a -> View b c) -> View (a, b) (a, c) -abstr1 fun = makeView f g - where - f (a, b) = do - c <- match (fun a) b - return (a, c) - g (a, c) = (a, build (fun a) c) - -abstr2 :: View (a, b) (a, c) -> (a -> View b c) -abstr2 v a = makeView f g - where - f b = do - (_, c) <- match v (a, b) - return c - g c = snd (build v (a, c)) -} diff --git a/src/Documentation/DefaultPage.hs b/src/Documentation/DefaultPage.hs --- a/src/Documentation/DefaultPage.hs +++ b/src/Documentation/DefaultPage.hs @@ -1,100 +1,102 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.DefaultPage where - -import Common.Exercise -import Control.Monad -import Service.DomainReasoner -import Service.Types -import System.Directory -import System.FilePath -import Text.HTML -import qualified Text.XML as XML - -generatePage :: String -> String -> HTMLBuilder -> DomainReasoner () -generatePage = generatePageAt 0 - -generatePageAt :: Int -> String -> String -> HTMLBuilder -> DomainReasoner () -generatePageAt n dir txt body = do - version <- getFullVersion - let filename = dir ++ "/" ++ txt - dirpart = takeDirectory filename - doc = defaultPage version (findTitle body) n body - liftIO $ do - putStrLn $ "Generating " ++ filename - unless (null dirpart) (createDirectoryIfMissing True dirpart) - writeFile filename (showHTML doc) - -defaultPage :: String -> String -> Int -> HTMLBuilder -> HTML -defaultPage version title level builder = - htmlPage title (Just (up level ++ "ideas.css")) $ do - header level - builder - footer version - -header :: Int -> HTMLBuilder -header level = do - divClass "menu" $ do - make exerciseOverviewPageFile "Exercises" - make "services.html" "Services" - make "tests.html" "Tests" - make "coverage/hpc_index.html" "Coverage" - make "api/index.html" "API" - hr - where - make target s = f $ link (up level ++ target) $ text s - f m = spaces 3 >> text "[" >> space >> m >> space >> text "]" >> spaces 3 - -footer :: String -> HTMLBuilder -footer version = do - hr - italic $ text $ "Automatically generated from sources: " ++ version - -up :: Int -> String -up = concat . flip replicate "../" - -findTitle :: HTMLBuilder -> String -findTitle = maybe "" XML.getData . XML.findChild "h1" . XML.makeXML "page" - -filePathId :: HasId a => a -> FilePath -filePathId a = foldr (\x y -> x ++ "/" ++ y) (unqualified a) (qualifiers a) - ------------------------------------------------------------- --- Paths and files - -exerciseOverviewPageFile, exerciseOverviewAllPageFile, - serviceOverviewPageFile, testsPageFile :: String - -exerciseOverviewPageFile = "exercises.html" -exerciseOverviewAllPageFile = "exercises-all.html" -serviceOverviewPageFile = "services.html" -testsPageFile = "tests.html" - -exercisePageFile, exerciseDerivationsFile, exerciseStrategyFile, - exerciseDiagnosisFile, ruleFile :: HasId a => a -> FilePath -exercisePageFile a = filePathId a ++ ".html" -exerciseDerivationsFile a = filePathId a ++ "-derivations.html" -exerciseStrategyFile a = filePathId a ++ "-strategy.html" -exerciseDiagnosisFile a = filePathId a ++ "-diagnosis.html" -ruleFile a = filePathId ("rule" # getId a) ++ ".html" - -servicePageFile :: Service -> String -servicePageFile srv = "services/" ++ filePathId srv ++ ".html" - -diagnosisExampleFile :: Id -> String -diagnosisExampleFile a = "examples/" ++ showId a ++ ".txt" - ------------------------------------------------------------- --- Utility functions - -showBool :: Bool -> String +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.DefaultPage where + +import Common.Id +import Control.Monad +import Service.DomainReasoner +import Service.Types +import System.Directory +import System.FilePath +import Text.HTML +import qualified Text.XML as XML + +generatePage :: String -> String -> HTMLBuilder -> DomainReasoner () +generatePage = generatePageAt 0 + +generatePageAt :: Int -> String -> String -> HTMLBuilder -> DomainReasoner () +generatePageAt n dir txt body = do + version <- getFullVersion + let filename = dir ++ "/" ++ txt + dirpart = takeDirectory filename + doc = defaultPage version (findTitle body) n body + liftIO $ do + putStrLn $ "Generating " ++ filename + unless (null dirpart) (createDirectoryIfMissing True dirpart) + writeFile filename (showHTML doc) + +defaultPage :: String -> String -> Int -> HTMLBuilder -> HTML +defaultPage version title level builder = + htmlPage title (Just (up level ++ "ideas.css")) $ do + header level + divClass "content" builder + footer version + +header :: Int -> HTMLBuilder +header level = divClass "header" $ do + divClass "ideas-logo" $ image (up level ++ "ideas.png") + divClass "ounl-logo" $ image (up level ++ "ounl.png") + make exerciseOverviewPageFile "Exercises" + make "services.html" "Services" + make "tests.html" "Tests" + make "coverage/hpc_index.html" "Coverage" + make "api/index.html" "API" + where + make target = spanClass "menuitem" . link (up level ++ target) . text + +footer :: String -> HTMLBuilder +footer version = divClass "footer" $ + text $ "Automatically generated from sources: " ++ version + +up :: Int -> String +up = concat . flip replicate "../" + +findTitle :: HTMLBuilder -> String +findTitle = maybe "" XML.getData . XML.findChild "h1" . XML.makeXML "page" + +filePathId :: HasId a => a -> FilePath +filePathId a = foldr (\x y -> x ++ "/" ++ y) (unqualified a) (qualifiers a) + +------------------------------------------------------------ +-- Paths and files + +exerciseOverviewPageFile, exerciseOverviewAllPageFile, + serviceOverviewPageFile, testsPageFile, viewsOverviewPageFile :: String + +exerciseOverviewPageFile = "exercises.html" +exerciseOverviewAllPageFile = "exercises-all.html" +serviceOverviewPageFile = "services.html" +viewsOverviewPageFile = "views.html" +testsPageFile = "tests.html" + +exercisePageFile, exerciseDerivationsFile, exerciseStrategyFile, + exerciseDiagnosisFile, ruleFile :: HasId a => a -> FilePath +exercisePageFile a = filePathId a ++ ".html" +exerciseDerivationsFile a = filePathId a ++ "-derivations.html" +exerciseStrategyFile a = filePathId a ++ "-strategy.html" +exerciseDiagnosisFile a = filePathId a ++ "-diagnosis.html" +ruleFile a = filePathId ("rule" # getId a) ++ ".html" + +servicePageFile :: Service -> String +servicePageFile srv = "services/" ++ filePathId srv ++ ".html" + +viewPageFile :: HasId a => a -> String +viewPageFile a = "views/" ++ showId a ++ ".html" + +diagnosisExampleFile :: Id -> String +diagnosisExampleFile a = "examples/" ++ showId a ++ ".xml" + +------------------------------------------------------------ +-- Utility functions + +showBool :: Bool -> String showBool b = if b then "yes" else "no" diff --git a/src/Documentation/DerivationUnitTests.hs b/src/Documentation/DerivationUnitTests.hs deleted file mode 100644 --- a/src/Documentation/DerivationUnitTests.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2009, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.DerivationUnitTests (main) where - -import Control.Monad -import Common.Exercise -import Text.XML -import Domain.Math.Power.Exercises - -base = "test/dwo-derivations" - -main = make powerOfAExercise - -make :: Exercise a -> IO () -make ex = zipWithM_ (makeTest ex) [1 ..] (examples ex) - -makeTest :: Exercise a -> Int -> a -> IO () -makeTest ex n a = do - let file = base ++ "/" ++ show (exerciseCode ex) ++ show n ++ ".xml" - putStrLn $ "Writing " ++ file - writeFile file $ showXML $ makeRequest a ex - -makeRequest :: a -> Exercise a -> XML -makeRequest a ex = makeXML "request" $ do - "service" .=. "derivation" - "exerciseid" .=. show (exerciseCode ex) - "encoding" .=. "string" - element "state" $ - element "expr" $ - text $ prettyPrinter ex a diff --git a/src/Documentation/ExampleFile.hs b/src/Documentation/ExampleFile.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/ExampleFile.hs @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- An example file contains a collection of examples for a certain exercise id, +-- encoded in XML. The examples can be for the diagnose and ready services. +-- +----------------------------------------------------------------------------- +module Documentation.ExampleFile + ( ExampleFile, items, Item(..) + , readExampleFile, writeExampleFile + ) where + +import Common.Id +import Common.Utils (readM) +import Control.Monad +import Data.Maybe +import Text.XML + +data ExampleFile = EF { fileId :: Id, items :: [Item] } + +instance Show ExampleFile where + show a = "Example file for " ++ showId a ++ + " (" ++ show (length (items a)) ++ " items)" + +instance HasId ExampleFile where + getId = fileId + changeId f a = a { fileId = f (fileId a) } + +data Item = Diagnose String String String + | Ready String (Maybe Bool) String + +readExampleFile :: FilePath -> IO ExampleFile +readExampleFile file = do + txt <- readFile file + xml <- either fail return (parseXML txt) + guard (name xml == "examples") + exid <- findAttribute "exerciseid" xml + xs <- mapM getItem (children xml) + return $ EF (newId exid) xs + +getItem :: XML -> IO Item +getItem xml = do + guard (name xml == "diagnose") + before <- findAttribute "before" xml + after <- findAttribute "after" xml + let descr = fromMaybe "" $ findAttribute "description" xml + return $ Diagnose before after descr + `mplus` do + guard (name xml == "ready") + term <- findAttribute "term" xml + let expected = findAttribute "expected" xml >>= readM + descr = fromMaybe "" $ findAttribute "description" xml + return $ Ready term expected descr + +writeExampleFile :: FilePath -> ExampleFile -> IO () +writeExampleFile file ex = writeFile file $ showXML $ + makeXML "examples" $ do + "exerciseid" .=. showId ex + mapM_ buildItem (items ex) + +buildItem :: Item -> XMLBuilder +buildItem item = + case item of + Diagnose before after descr -> + element "diagnose" $ do + "before" .=. before + "after" .=. after + "description" .=. descr + Ready term expected descr -> + element "ready" $ do + "term" .=. term + maybe (return ()) (("expected" .=.) . show) expected + "description" .=. descr diff --git a/src/Documentation/ExercisePage.hs b/src/Documentation/ExercisePage.hs --- a/src/Documentation/ExercisePage.hs +++ b/src/Documentation/ExercisePage.hs @@ -1,208 +1,220 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.ExercisePage (makeExercisePage) where - -import Common.Context -import Common.Exercise -import Common.Derivation -import Common.Strategy hiding (not, replicate) -import Common.Transformation -import Common.Utils (Some(..), splitAtSequence) -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import Documentation.DefaultPage -import Documentation.RulePresenter -import Service.BasicServices -import Service.Diagnose -import Service.DomainReasoner -import Service.ExercisePackage -import Service.State -import Service.StrategyInfo -import System.Directory -import System.Random -import Text.HTML - -makeExercisePage :: String -> ExercisePackage a -> DomainReasoner () -makeExercisePage dir pkg = do - let ex = exercise pkg - make = makeId pkg - makeId a = generatePageAt (length (qualifiers a)) dir . ($ (getId a)) - exFile = dir ++ "/" ++ diagnosisExampleFile (getId ex) - - exampleFileExists <- liftIO (doesFileExist exFile) - - make exercisePageFile (exercisePage exampleFileExists pkg) - make exerciseStrategyFile (strategyPage ex) - unless (null (examples (exercise pkg))) $ - make exerciseDerivationsFile (derivationsPage ex) - when (exampleFileExists) $ do - xs <- liftIO (readFile exFile) - make exerciseDiagnosisFile (diagnosisPage xs pkg) - `catchError` \_ -> return () - -exercisePage :: Bool -> ExercisePackage a -> HTMLBuilder -exercisePage exampleFileExists pkg = do - idboxHTML "strategy" (getId pkg) - - h2 "1. General information" - - let bolds (x:xs) = bold x:xs - bolds [] = [] - - table $ map bolds - [ [ text "Code", ttText (showId ex)] - , [ text "Status", text (show $ status ex)] - , [ text "Strategy" - , link (up level ++ exerciseStrategyFile exid) $ - text (showId $ strategy ex) - ] - , [ text "OpenMath support" - , text $ showBool $ withOpenMath pkg - ] - , [ text "Textual feedback" - , text $ showBool $ isJust $ getExerciseText pkg - ] - , [ text "Restartable strategy" - , text $ showBool $ canBeRestarted ex - ] - , [ text "Exercise generator" - , text $ showBool $ isJust $ randomExercise ex - ] - , [ text "Examples" - , text $ show $ length $ examples ex - ] - ] - - h2 "2. Rules" - let rs = rulesInStrategy (strategy ex) - ups = up (length (qualifiers pkg)) - f r = [ link (ups ++ ruleFile r) $ ttText (showId r) - , text $ showBool $ isBuggyRule r - , text $ showBool $ hasArguments r - , text $ showBool $ r `elem` rs - , text $ concat $ intersperse "," $ map showId $ ruleGroups r - , when (isRewriteRule r) $ - ruleToHTML (Some ex) r - ] - table ( [bold $ text "Rule name", bold $ text "Buggy" - , bold $ text "Args" - , bold $ text "Used", bold $ text "Groups" - , bold $ text "Rewrite rule" - ] - : map f (ruleset ex) - ) - when exampleFileExists $ do - para $ link (up level ++ exerciseDiagnosisFile exid) $ do - br - text "See diagnosis examples" - - h2 "3. Example" - let state = generateWith (mkStdGen 0) pkg 5 - derivationHTML ex (stateTerm state) - para $ unless (null (examples ex)) $ - link (up level ++ exerciseDerivationsFile exid) (text "More examples") - where - ex = exercise pkg - exid = getId ex - level = length (qualifiers pkg) - -strategyPage :: Exercise a -> HTMLBuilder -strategyPage ex = do - h1 title - h2 "1. Representation in XML" - highlightXML True (strategyToXML (strategy ex)) - h2 "2. Locations" - let f (loc, a) = - [text (show loc), indent (length loc) >> text (showId a)] - indent n = text (replicate (3*n) '.') - table ( [bold $ text "Location", bold $ text "Label"] - : map f (strategyLocations (strategy ex)) - ) - where - title = "Strategy for " ++ showId ex - -derivationsPage :: Exercise a -> HTMLBuilder -derivationsPage ex = do - h1 "Examples" - forM_ (zip [1::Int ..] (examples ex)) $ \(i, a) -> do - h2 (show i ++ ".") - derivationHTML ex a - -derivationHTML :: Exercise a -> a -> HTMLBuilder -derivationHTML ex a = divClass "derivation" $ do - pre $ derivationM (forStep ups) (forTerm ex) der - unless (ok der) $ - divClass "error" $ text "<>" - where - ups = length (qualifiers ex) - der = derivationDiffEnv (defaultDerivation ex a) - ok = maybe False (isReady ex) . fromContext . last . terms - -idboxHTML :: String -> Id -> HTMLBuilder -idboxHTML kind i = divClass "idbox" $ do - font "id" $ ttText (showId i) - spaces 3 - text $ "(" ++ kind ++ ")" - unless (null $ description i) $ do - br - italic (text (description i)) - -diagnosisPage :: String -> ExercisePackage a -> HTMLBuilder -diagnosisPage xs pkg = do - h1 ("Diagnosis examples for " ++ showId pkg) - forM_ (zip [1::Int ..] (mapMaybe f (lines xs))) $ \(i, (t0, t1, expl)) -> do - h2 (show i ++ ".") - preText (t0 ++ "\n =>\n" ++ t1) - para $ do - unless (null expl) $ do - bold $ text "Description:" - space - text expl - br - bold $ text "Diagnosis:" - space - text (getDiagnosis t0 t1) - where - ex = exercise pkg - f a = do - (x, b) <- splitAtSequence "==>" a - let (y, z) = fromMaybe (b, "") (splitAtSequence ":::" b) - trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace - return (trim x, trim y, trim z) - - getDiagnosis t0 t1 = - case (parser ex t0, parser ex t1) of - (Left msg, _) -> "parse error (before): " ++ msg - (_, Left msg) -> "parse error (afterr): " ++ msg - (Right a, Right b) -> show (diagnose (emptyState pkg a) b) - -forStep :: HasId a => Int -> (a, Environment) -> HTMLBuilder -forStep n (i, env) = do - spaces 3 - text "=>" - space - let target = up n ++ ruleFile i - make | null (description i) = link target - | otherwise = linkTitle target (description i) - make (text (unqualified i)) - br - unless (nullEnv env) $ do - spaces 6 - text (show env) - br - -forTerm :: Exercise a -> Context a -> HTMLBuilder -forTerm ex ca = do - text (prettyPrinterContext ex ca) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.ExercisePage (makeExercisePage, idboxHTML) where + +import Common.Library hiding (up) +import Common.Utils (Some(..), commaList) +import Control.Monad +import Data.Maybe +import Documentation.DefaultPage +import Documentation.ExampleFile +import Documentation.OpenMathDerivations +import Documentation.RulePresenter +import Service.BasicServices +import Service.Diagnose +import Service.DomainReasoner +import Service.State +import Service.StrategyInfo +import System.Directory +import System.Random +import Text.HTML + +makeExercisePage :: String -> Exercise a -> DomainReasoner () +makeExercisePage dir ex = do + let make = makeId ex + makeId a = generatePageAt (length (qualifiers a)) dir . ($ getId a) + exFile = dir ++ "/" ++ diagnosisExampleFile (getId ex) + + exampleFileExists <- liftIO (doesFileExist exFile) + + make exercisePageFile (exercisePage exampleFileExists ex) + make exerciseStrategyFile (strategyPage ex) + unless (null (examples ex)) $ do + make exerciseDerivationsFile (derivationsPage ex) + liftIO $ makeOpenMathDerivations dir ex + when exampleFileExists $ do + ef <- liftIO (readExampleFile exFile) + make exerciseDiagnosisFile (diagnosisPage ef ex) + `catchError` \_ -> return () + +exercisePage :: Bool -> Exercise a -> HTMLBuilder +exercisePage exampleFileExists ex = do + idboxHTML "exercise" exid + + h2 "1. General information" + + let bolds (x:xs) = bold x:xs + bolds [] = [] + + table False $ map bolds + [ [ text "Code", ttText (showId ex)] + , [ text "Status", text (show $ status ex)] + , [ text "Strategy" + , link (up len ++ exerciseStrategyFile exid) $ + text (showId $ strategy ex) + ] + , [ text "OpenMath support" + , text $ showBool $ isJust $ hasTermView ex + ] + {- , [ text "Textual feedback" + , text $ showBool $ isJust $ getScript ex + ] -} + , [ text "Restartable strategy" + , text $ showBool $ canBeRestarted ex + ] + , [ text "Exercise generator" + , text $ showBool $ isJust $ randomExercise ex + ] + , [ text "Examples" + , text $ show $ length $ examples ex + ] + ] + + h2 "2. Rules" + let rs = rulesInStrategy (strategy ex) + goUp = up (length (qualifiers ex)) + f r = [ link (goUp ++ ruleFile r) $ ttText (showId r) + , text $ showBool $ isBuggyRule r + , text $ showBool $ hasArguments r + , text $ showBool $ r `elem` rs + , when (isRewriteRule r) $ + ruleToHTML (Some ex) r + ] + table True + ( [ text "Rule name", text "Buggy", text "Args" + , text "Used", text "Rewrite rule" + ] + : map f (ruleset ex) + ) + when exampleFileExists $ + para $ link (up len ++ exerciseDiagnosisFile exid) $ do + br + text "See diagnosis examples" + -- preText $ show $ treesToInfo ex trees + + h2 "3. Example" + let state = generate (mkStdGen 0) ex Medium + derivationHTML ex (stateTerm state) + para $ unless (null (examples ex)) $ + link (up len ++ exerciseDerivationsFile exid) (text "More examples") + where + exid = getId ex + len = length (qualifiers ex) + {- + trees = [ mapFirst getId (derivationTree (strategy ex) (inContext ex a)) + | (_, a) <- examples ex + ] -} + +strategyPage :: Exercise a -> HTMLBuilder +strategyPage ex = do + h1 title + h2 "1. Representation in XML" + highlightXML True (strategyToXML (strategy ex)) + h2 "2. Locations" + let f (loc, a) = + [text (show loc), indent (length loc) >> text (showId a)] + indent n = text (replicate (3*n) '.') + table True + ( [text "Location", text "Label"] + : map f (strategyLocations (strategy ex)) + ) + where + title = "Strategy for " ++ showId ex + +derivationsPage :: Exercise a -> HTMLBuilder +derivationsPage ex = do + h1 "Examples" + forM_ (zip [1::Int ..] (examples ex)) $ \(i, (_, a)) -> do + h2 (show i ++ ".") + derivationHTML ex a + +derivationHTML :: Exercise a -> a -> HTMLBuilder +derivationHTML ex a = divClass "derivation" $ do + when (isJust (hasTermView ex)) $ + let file = up upn ++ "derivations/" ++ showId ex ++ ".xml" + in divClass "mathml" $ link file $ text "MathML" + pre $ derivationM (forStep upn) (forTerm ex) der + unless (ok der) $ + divClass "error" $ text "<>" + where + upn = length (qualifiers ex) + der = derivationPrevious (derivationDiffEnv (defaultDerivation ex a)) + ok = maybe False (isReady ex) . fromContext . lastTerm + +idboxHTML :: String -> Id -> HTMLBuilder +idboxHTML kind i = divClass "idbox" $ do + divClass "id-type" $ text kind + spanClass "id-code" $ ttText (showId i) + divClass "id-description" $ text $ + if null (description i) then "no description" else description i + +diagnosisPage :: ExampleFile -> Exercise a -> HTMLBuilder +diagnosisPage ef ex = do + h1 ("Diagnosis examples for " ++ showId ex) + let rs = [ (t, eb, descr) | Ready t eb descr <- items ef ] + unless (null rs) $ table True $ + map text ["term", "ready", "description"] : map readyItem rs + let ts = [ (t0, t1, expl) | Diagnose t0 t1 expl <- items ef ] + zipWithM_ diagnoseItem [1::Int ..] ts + where + readyItem (t, eb, descr) = + let mark = if ok then id else spanClass "error" + (ok, result) = + case parser ex t of + Left _ -> (False, "error") + Right a -> let b = isReady ex a + in (maybe True (==b) eb, showBool b) + in map mark [ttText t, text result, text descr] + + diagnoseItem i (t0, t1, expl) = do + h2 (show i ++ ".") + preText (t0 ++ "\n =>\n" ++ t1) + unless (null expl) $ para $ do + bold $ text "Description:" + space + text expl + br + bold $ text "Diagnosis:" + space + text (getDiagnosis t0 t1) + + getDiagnosis t0 t1 = + case (parser ex t0, parser ex t1) of + (Left msg, _) -> "parse error (before): " ++ msg + (_, Left msg) -> "parse error (after): " ++ msg + (Right a, Right b) -> show (diagnose (emptyState ex a) b) + +forStep :: Int -> ((Rule (Context a), Environment), Context a) -> HTMLBuilder +forStep n ((r, env), old) = do + spaces 3 + text "=>" + space + let target = up n ++ ruleFile r + make | null (description r) = link target + | otherwise = titleA (description r) . link target + make (text (unqualified r)) + let xs = fromMaybe [] (expectedArguments r old) + g (ArgValue descr x) = labelArgument descr ++ "=" ++ showArgument descr x + unless (null xs) $ do + br + spaces 6 + text (commaList (map g xs)) + unless (nullEnv env) $ do + br + spaces 6 + text (show env) + br + +forTerm :: Exercise a -> Context a -> HTMLBuilder +forTerm ex ca = do + text (prettyPrinterContext ex ca) br diff --git a/src/Documentation/Make.hs b/src/Documentation/Make.hs --- a/src/Documentation/Make.hs +++ b/src/Documentation/Make.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,17 +11,18 @@ ----------------------------------------------------------------------------- module Documentation.Make (DocItem(..), makeDocumentation) where -import Common.TestSuite import Common.Utils (Some(..)) +import Common.Utils.TestSuite import Control.Monad import Data.Maybe -import Service.DomainReasoner -import Documentation.SelfCheck import Documentation.ExercisePage +import Documentation.OverviewPages import Documentation.RulePage -import Documentation.TestsPage +import Documentation.SelfCheck import Documentation.ServicePage -import Documentation.OverviewPages +import Documentation.TestsPage +import Documentation.ViewPage +import Service.DomainReasoner data DocItem = Pages | SelfCheck | BlackBox (Maybe String) deriving Eq @@ -29,20 +30,27 @@ makeDocumentation :: String -> String -> DocItem -> DomainReasoner () makeDocumentation docDir testDir item = case item of - Pages -> do + Pages -> do report "Generating overview pages" makeOverviewExercises docDir makeOverviewServices docDir report "Generating exercise pages" - pkgs <- getPackages - forM_ pkgs $ \(Some pkg) -> - makeExercisePage docDir pkg + exs <- getExercises + forM_ exs $ \(Some ex) -> + makeExercisePage docDir ex + report "Generating view pages" + makeViewPages docDir report "Generating rule pages" makeRulePages docDir report "Generating service pages" getServices >>= mapM_ (makeServicePage docDir) report "Running tests" makeTestsPage docDir testDir + {- report "Status hashtable" + let file = docDir ++ "/hashtable.out" + liftIO $ do + putStrLn $ "Generating " ++ show file + tableStatus >>= writeFile file -} SelfCheck -> do checks <- selfCheck testDir result <- liftIO (runTestSuiteResult checks) @@ -52,7 +60,7 @@ checks <- liftIO $ blackBoxTests run (fromMaybe testDir mdir) result <- liftIO $ runTestSuiteResult checks liftIO (printSummary result) - + report :: String -> DomainReasoner () report s = liftIO $ do let line = replicate 75 '-' diff --git a/src/Documentation/OpenMathDerivations.hs b/src/Documentation/OpenMathDerivations.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/OpenMathDerivations.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.OpenMathDerivations (makeOpenMathDerivations) where + +import Common.Library +import Control.Monad +import Data.Maybe +import Service.OpenMathSupport +import Text.OpenMath.Object +import Text.XML + +makeOpenMathDerivations :: String -> Exercise a -> IO () +makeOpenMathDerivations dir ex = + when (isJust $ hasTermView ex) $ do + let file = dir ++ "/derivations/" ++ showId ex ++ ".xml" + putStrLn $ "Generating " ++ file + writeFile file $ + "\n" ++ + show (derivationsXML ex) + +derivationsXML :: Exercise a -> XML +derivationsXML ex = makeXML "derivations" $ do + "title" .=. showId ex + forM_ (zip [1::Int ..] (examples ex)) $ \(i, (_, a)) -> + element "derivation" $ do + "title" .=. show i + let der = derivationPrevious (derivationDiffEnv (defaultDerivation ex a)) + derivationM f g der + where + f ((r, _), _) = element "step" $ text (showId r) + g a = case fromContext a >>= toOpenMath ex of + Just om -> builder (omobj2xml om) + Nothing -> return () diff --git a/src/Documentation/OverviewPages.hs b/src/Documentation/OverviewPages.hs --- a/src/Documentation/OverviewPages.hs +++ b/src/Documentation/OverviewPages.hs @@ -1,87 +1,86 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.OverviewPages - ( makeOverviewExercises, makeOverviewServices - ) where - -import Documentation.DefaultPage -import Data.Char -import Data.List -import Data.Maybe -import Control.Monad -import Common.Utils (Some(..), safeHead) -import Common.Exercise -import Service.DomainReasoner -import Service.Types -import Text.HTML - -makeOverviewExercises :: String -> DomainReasoner () -makeOverviewExercises dir = do - list <- getExercises - generatePage dir exerciseOverviewPageFile $ - exerciseOverviewPage False list - generatePage dir exerciseOverviewAllPageFile $ - exerciseOverviewPage True list - -makeOverviewServices :: String -> DomainReasoner () -makeOverviewServices dir = do - list <- getServices - generatePage dir serviceOverviewPageFile (serviceOverviewPage list) - -exerciseOverviewPage :: Bool -> [Some Exercise] -> HTMLBuilder -exerciseOverviewPage showAll list = do - h1 title - - unless showAll $ para $ do - text "Show" - space - link exerciseOverviewAllPageFile $ - text "all exercises" - text ", including the ones under development" - - forM_ (zip [1::Int ..] (grouping list)) $ \(i, (dom, xs)) -> do - h2 (show i ++ ". " ++ dom) - table (map makeRow xs) - where - title | showAll = "All exercises" - | otherwise = "Exercises" - - makeRow (Some ex) = - [ link (exercisePageFile code) $ ttText (show code) - , do spaces 10 - f (status ex) - spaces 10 - , text $ description ex - ] - where - code = getId ex - f st = italic $ text ("(" ++ map toLower (show st) ++ ")") - - grouping = map g . groupBy eq . sortBy cmp . filter p - where - cmp (Some a) (Some b) = compareId (exerciseId a) (exerciseId b) - eq a b = f a == f b - f (Some ex) = safeHead (qualifiers (exerciseId ex)) - g xs = (fromMaybe "" (f (head xs)), xs) - p (Some ex) = showAll || isPublic ex - -serviceOverviewPage :: [Service] -> HTMLBuilder -serviceOverviewPage list = do - h1 "Services" - let (xs, ys) = partition serviceDeprecated (sortBy compareId list) - make s = link (servicePageFile s) (ttText (showId s)) - ul $ map make ys - unless (null xs) $ do - h2 "Deprecated" +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.OverviewPages + ( makeOverviewExercises, makeOverviewServices + ) where + +import Common.Exercise +import Common.Id +import Common.Utils (Some(..), safeHead) +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import Documentation.DefaultPage +import Service.DomainReasoner +import Service.Types +import Text.HTML + +makeOverviewExercises :: String -> DomainReasoner () +makeOverviewExercises dir = do + list <- getExercises + generatePage dir exerciseOverviewPageFile $ + exerciseOverviewPage False list + generatePage dir exerciseOverviewAllPageFile $ + exerciseOverviewPage True list + +makeOverviewServices :: String -> DomainReasoner () +makeOverviewServices dir = do + list <- getServices + generatePage dir serviceOverviewPageFile (serviceOverviewPage list) + +exerciseOverviewPage :: Bool -> [Some Exercise] -> HTMLBuilder +exerciseOverviewPage showAll list = do + h1 title + + forM_ (zip [1::Int ..] (grouping list)) $ \(i, (dom, xs)) -> do + h2 (show i ++ ". " ++ dom) + table False (map makeRow xs) + + unless showAll $ para $ do + text "Show" + space + link exerciseOverviewAllPageFile $ + text "all exercises" + text ", including the ones under development" + where + title | showAll = "All exercises" + | otherwise = "Exercises" + + makeRow (Some ex) = + [ link (exercisePageFile code) $ ttText (show code) + , do spaces 10 + f (status ex) + spaces 10 + , text $ description ex + ] + where + code = getId ex + f st = italic $ text ("(" ++ map toLower (show st) ++ ")") + + grouping = map g . groupBy eq . sortBy cmp . filter p + where + cmp (Some a) (Some b) = compareId (exerciseId a) (exerciseId b) + eq a b = f a == f b + f (Some ex) = safeHead (qualifiers (exerciseId ex)) + g xs = (fromMaybe "" (f (head xs)), xs) + p (Some ex) = showAll || isPublic ex + +serviceOverviewPage :: [Service] -> HTMLBuilder +serviceOverviewPage list = do + h1 "Services" + let (xs, ys) = partition serviceDeprecated (sortBy compareId list) + make s = link (servicePageFile s) (ttText (showId s)) + ul $ map make ys + unless (null xs) $ do + h2 "Deprecated" ul $ map make xs - - diff --git a/src/Documentation/RulePage.hs b/src/Documentation/RulePage.hs --- a/src/Documentation/RulePage.hs +++ b/src/Documentation/RulePage.hs @@ -1,119 +1,110 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.RulePage (makeRulePages) where - -import Common.Context -import Common.Exercise -import Common.Transformation -import Common.Utils (commaList, Some(..)) -import Control.Monad -import Data.List -import Documentation.DefaultPage -import Documentation.RulePresenter -import Service.DomainReasoner -import Service.ExercisePackage -import Service.RulesInfo (rewriteRuleToFMP, collectExamples, ExampleMap) -import Text.HTML -import Text.OpenMath.FMP -import Text.OpenMath.Object -import qualified Data.Map as M -import qualified Text.XML as XML - -data ExItem a = EI (ExercisePackage a) (ExampleMap a) - -makeRulePages :: String -> DomainReasoner () -makeRulePages dir = do - pkgs <- getPackages - let exMap = M.fromList - [ (getId pkg, Some (EI pkg (collectExamples (exercise pkg)))) - | Some pkg <- pkgs - ] - ruleMap = M.fromListWith (++) - [ (getId r, [Some pkg]) - | Some pkg <- pkgs - , r <- ruleset (exercise pkg) - ] - forM_ (M.toList ruleMap) $ \(ruleId, list@(Some pkg:_)) -> do - let noExamples = Some (EI pkg M.empty) - level = length (qualifiers ruleId) + 1 - usedIn = sortBy compareId [ getId pkg1 | Some pkg1 <- list ] - case M.findWithDefault noExamples (getId pkg) exMap of - Some (EI pkg1 e) -> do - let ex = exercise pkg1 - forM_ (getRule ex ruleId) $ \r -> - generatePageAt level dir (ruleFile ruleId) $ - rulePage ex e usedIn r - -rulePage :: Exercise a -> ExampleMap a -> [Id] -> Rule (Context a) -> HTMLBuilder -rulePage ex exMap usedIn r = do - idboxHTML "rule" (getId r) - let idList = text . commaList . map showId - para $ table - [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)] - , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)] - , [bold $ text "Groups", idList $ ruleGroups r] - , [bold $ text "Siblings", idList $ ruleSiblings r] - ] - when (isRewriteRule r) $ para $ - ruleToHTML (Some ex) r - - h3 "Used in exercises" - let f a = link (up ups ++ exercisePageFile a) (tt $ text $ show a) - ups = length (qualifiers r) + 1 - ul $ map f usedIn - - -- Examples - let ys = M.findWithDefault [] (getId r) exMap - unless (null ys) $ do - h3 "Examples" - forM_ (take 3 ys) $ \(a, b) -> para $ divClass "step" $ pre $ do - forTerm ex (inContext ex a) - forStep ups (getId r, emptyEnv) - forTerm ex (inContext ex b) - - -- FMPS - let xs = getRewriteRules r - unless (null xs) $ do - h3 "Formal Mathematical Properties" - forM_ xs $ \(Some rr, b) -> para $ do - let fmp = rewriteRuleToFMP b rr - highlightXML False $ XML.makeXML "FMP" $ - XML.builder (omobj2xml (toObject fmp)) - -idboxHTML :: String -> Id -> HTMLBuilder -idboxHTML kind i = divClass "idbox" $ do - para $ do - font "id" $ ttText (showId i) - spaces 3 - text $ "(" ++ kind ++ ")" - unless (null $ description i) $ - para $ italic $ text (description i) - -forStep :: Int -> (Id, Environment) -> HTMLBuilder -forStep n (i, env) = do - spaces 3 - text "=>" - space - let target = up n ++ ruleFile i - make | null (description i) = link target - | otherwise = linkTitle target (description i) - make (text (unqualified i)) - br - unless (nullEnv env) $ do - spaces 6 - text (show env) - br - -forTerm :: Exercise a -> Context a -> HTMLBuilder -forTerm ex ca = do - text (prettyPrinterContext ex ca) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.RulePage (makeRulePages) where + +import Common.Library hiding (up) +import Common.Utils (commaList, Some(..)) +import Control.Monad +import Data.List +import Documentation.DefaultPage +import Documentation.ExercisePage (idboxHTML) +import Documentation.RulePresenter +import Service.DomainReasoner +import Service.RulesInfo (rewriteRuleToFMP, collectExamples, ExampleMap) +import Text.HTML +import Text.OpenMath.FMP +import Text.OpenMath.Object +import qualified Data.Map as M +import qualified Text.XML as XML + +data ExItem a = EI (Exercise a) (ExampleMap a) + +makeRulePages :: String -> DomainReasoner () +makeRulePages dir = do + exs <- getExercises + let exMap = M.fromList + [ (getId ex, Some (EI ex (collectExamples ex))) + | Some ex <- exs + ] + ruleMap = M.fromListWith (++) + [ (getId r, [Some ex]) + | Some ex <- exs + , r <- ruleset ex + ] + forM_ (M.toList ruleMap) $ \(ruleId, list) -> + case list of + [] -> return () + Some ex:_ -> + case M.findWithDefault noExamples (getId ex) exMap of + Some (EI ex1 e) -> + forM_ (getRule ex1 ruleId) $ \r -> + generatePageAt lev dir (ruleFile ruleId) $ + rulePage ex1 e usedIn r + where + noExamples = Some (EI ex M.empty) + lev = length (qualifiers ruleId) + 1 + usedIn = sortBy compareId [ getId ex1 | Some ex1 <- list ] + +rulePage :: Exercise a -> ExampleMap a -> [Id] -> Rule (Context a) -> HTMLBuilder +rulePage ex exMap usedIn r = do + idboxHTML "rule" (getId r) + let idList = text . commaList . map showId + para $ table False + [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)] + , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)] + , [bold $ text "Siblings", idList $ ruleSiblings r] + ] + when (isRewriteRule r) $ para $ + ruleToHTML (Some ex) r + + h3 "Used in exercises" + let f a = link (up upn ++ exercisePageFile a) (tt $ text $ show a) + upn = length (qualifiers r) + 1 + ul $ map f usedIn + + -- Examples + let ys = M.findWithDefault [] (getId r) exMap + unless (null ys) $ do + h3 "Examples" + forM_ (take 3 ys) $ \(a, b) -> para $ divClass "step" $ pre $ do + forTerm ex (inContext ex a) + forStep upn (getId r, emptyEnv) + forTerm ex (inContext ex b) + + -- FMPS + let xs = getRewriteRules r + unless (null xs) $ do + h3 "Formal Mathematical Properties" + forM_ xs $ \(Some rr, b) -> para $ do + let fmp = rewriteRuleToFMP b rr + highlightXML False $ XML.makeXML "FMP" $ + XML.builder (omobj2xml (toObject fmp)) + +forStep :: Int -> (Id, Environment) -> HTMLBuilder +forStep n (i, env) = do + spaces 3 + text "=>" + space + let target = up n ++ ruleFile i + make | null (description i) = link target + | otherwise = titleA (description i) . link target + make (text (unqualified i)) + br + unless (nullEnv env) $ do + spaces 6 + text (show env) + br + +forTerm :: Exercise a -> Context a -> HTMLBuilder +forTerm ex ca = do + text (prettyPrinterContext ex ca) br diff --git a/src/Documentation/RulePresenter.hs b/src/Documentation/RulePresenter.hs --- a/src/Documentation/RulePresenter.hs +++ b/src/Documentation/RulePresenter.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -12,22 +12,20 @@ module Documentation.RulePresenter (ruleToHTML) where import Common.Library -import Control.Monad import Common.Utils (Some(..), safeHead) -import Common.Rewriting.Term +import Control.Monad import Data.List +import Data.Maybe import Text.HTML ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder -ruleToHTML ex r = - forM_ (getRewriteRules r) $ \(Some rr, b) -> +ruleToHTML ex r = + forM_ (getRewriteRules r) $ \(Some rr, b) -> rewriteRuleToHTML b ex rr rewriteRuleToHTML :: Bool -> Some Exercise -> RewriteRule a -> HTMLBuilder rewriteRuleToHTML sound ex r = do let lhs :~> rhs = ruleSpecTerm r - -- showRuleName (unqualified r) - -- spaces 3 showTerm ex lhs spaces 3 showLeadsTo sound @@ -35,11 +33,6 @@ showTerm ex rhs br -{- -showRuleName :: String -> HTMLBuilder -showRuleName s = text ("[" ++ s ++ "]") --} - showLeadsTo :: Bool -> HTMLBuilder showLeadsTo sound = text (if sound then "\x21D2" else "\x21CF") @@ -48,29 +41,28 @@ where rec term = case term of - Var s -> s - Num i -> show i - Float a -> show a - Meta n -> showMeta ex n - _ -> concatMap (either id recp) $ + TVar s -> s + TNum i -> show i + TFloat a -> show a + TMeta n -> showMeta ex n + _ -> concatMap (either id recp) $ case getSpine term of - (Con s, xs) -> - case specialSymbol s xs of - Just ys -> ys - Nothing -> spaced (Left (show s) : map Right xs) + (TCon s, xs) -> + let txt = spaced (Left (show s) : map Right xs) + in fromMaybe txt (specialSymbol s xs) (x, xs) -> spaced (map Right (x:xs)) - - recp term = parIf (isApply term) (rec term) + + recp term = parIf (isApp term) (rec term) spaced = intersperse (Left " ") - - isApply (Apply _ _) = True - isApply _ = False - - parIf b s = if b then "(" ++ s ++ ")" else s - + + isApp (TApp _ _) = True + isApp _ = False + + parIf b s = if b then "(" ++ s ++ ")" else s + specialSymbol :: Symbol -> [Term] -> Maybe [Either String Term] -- constants -specialSymbol s [] +specialSymbol s [] | sameSymbol s "logic1.true" = con "T" | sameSymbol s "logic1.false" = con "F" | sameSymbol s "relalg.universe" = con "V" -- universe @@ -104,13 +96,13 @@ | sameSymbol s "relalg.add" = bin " \x2020 " -- relative addition/dagger where bin x = return [Right a, Left x, Right b] -specialSymbol s1 [Apply (Apply (Con s2) x) a] - | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" = - return [Left "D(", Right x, Left ") ", Right a] +specialSymbol s1 [TApp (TApp (TCon s2) x) a] + | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" = + return [Left "D(", Right x, Left ") ", Right a] specialSymbol _ _ = Nothing sameSymbol :: Symbol -> String -> Bool -sameSymbol = (==) . show +sameSymbol = (==) . show showMeta :: Exercise a -> Int -> String showMeta ex n diff --git a/src/Documentation/SelfCheck.hs b/src/Documentation/SelfCheck.hs --- a/src/Documentation/SelfCheck.hs +++ b/src/Documentation/SelfCheck.hs @@ -1,120 +1,133 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.SelfCheck (selfCheck, blackBoxTests) where - -import System.Directory -import Common.TestSuite -import Common.Utils (useFixedStdGen, Some(..), snd3) -import Common.Exercise -import Service.ExercisePackage -import Control.Monad -import Service.Request -import Service.DomainReasoner -import Service.ModeJSON -import Service.ModeXML -import qualified Text.OpenMath.Tests as OpenMath -import qualified Text.UTF8 as UTF8 -import qualified Text.JSON as JSON -import Data.List - -selfCheck :: String -> DomainReasoner TestSuite -selfCheck dir = do - pkgs <- getPackages - domainSuite <- getTestSuite - run <- runWithCurrent - - return $ do - suite "Framework checks" $ do - suite "Text encodings" $ do - addProperty "UTF8 encoding" UTF8.propEncoding - addProperty "JSON encoding" JSON.propEncoding - addProperty "OpenMath encoding" OpenMath.propEncoding - - suite "Domain checks" domainSuite - - suite "Exercise checks" $ - forM_ pkgs $ \(Some pkg) -> - exerciseTestSuite (exercise pkg) - - suite "Black box tests" $ do - liftIO (blackBoxTests run dir) >>= id - --- Returns the number of tests performed -blackBoxTests :: (DomainReasoner Bool -> IO Bool) -> String -> IO TestSuite -blackBoxTests run path = do - putStrLn ("Scanning " ++ path) - -- analyse content - xs0 <- getDirectoryContents path - let (xml, xs1) = partition (".xml" `isSuffixOf`) xs0 - (json, xs2) = partition (".json" `isSuffixOf`) xs1 - -- perform tests - ts1 <- forM json $ \x -> - doBlackBoxTest run JSON (path ++ "/" ++ x) - ts2 <- forM xml $ \x -> - doBlackBoxTest run XML (path ++ "/" ++ x) - -- recursively visit subdirectories - ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do - let p = path ++ "/" ++ x - valid <- doesDirectoryExist p - if not valid - then return (return ()) - else liftM (suite $ "Directory " ++ simplerDirectory p) - (blackBoxTests run p) - return $ - sequence_ (ts1 ++ ts2 ++ ts3) - -doBlackBoxTest :: (DomainReasoner Bool -> IO Bool) -> DataFormat -> FilePath -> IO TestSuite -doBlackBoxTest run format path = do - b <- doesFileExist expPath - return $ if not b - then warn $ expPath ++ " does not exist" - else assertIO (stripDirectoryPart path) $ run $ do - -- Comparing output with expected output - liftIO useFixedStdGen -- fix the random number generator - txt <- liftIO $ readFile path - expt <- liftIO $ readFile expPath - out <- case format of - JSON -> liftM snd3 (processJSON txt) - XML -> liftM snd3 (processXML txt) - -- Conditional forces evaluation of the result, to make sure that - -- all file handles are closed afterwards. - if out ~= expt then return True else return False - `catchError` - \_ -> return False - where - expPath = baseOf path ++ ".exp" - baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse - x ~= y = filterVersion x == filterVersion y - - filterVersion = - let p s = not (null s || "version" `isInfixOf` s) - in unlines . filter p . lines - -simplerDirectory :: String -> String -simplerDirectory s - | "../" `isPrefixOf` s = simplerDirectory (drop 3 s) - | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s) - | otherwise = s - -stripDirectoryPart :: String -> String -stripDirectoryPart = reverse . takeWhile (/= '/') . reverse - -{- -logicConfluence :: IO () -logicConfluence = reportTest "logic rules" (isConfluent f rs) - where - f = normalizeWith ops . normalFormWith ops rs - ops = map makeCommutative Logic.logicOperators - rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd] - rs = [ r | RewriteRule r <- concatMap transformations rwrs ] - -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.SelfCheck (selfCheck, blackBoxTests) where + +import Common.Exercise +import Common.Utils (useFixedStdGen, Some(..), snd3) +import Common.Utils.TestSuite +import Control.Monad +import Data.List +import Service.DomainReasoner +import Service.ModeJSON +import Service.ModeXML +import Service.Request +import System.Directory +import qualified Common.Algebra.Boolean as Algebra +import qualified Common.Algebra.Field as Algebra +import qualified Common.Rewriting.Substitution as Substitution +import qualified Common.Rewriting.Unification as Unification +import qualified Common.Strategy.Tests as Strategy +import qualified Text.JSON as JSON +import qualified Text.OpenMath.Tests as OpenMath +import qualified Text.UTF8 as UTF8 + +selfCheck :: String -> DomainReasoner TestSuite +selfCheck dir = do + list <- getExercises + domainSuite <- getTestSuite + run <- runWithCurrent + + return $ do + suite "Framework checks" $ do + suite "Text encodings" $ do + addProperty "UTF8 encoding" UTF8.propEncoding + addProperty "JSON encoding" JSON.propEncoding + addProperty "OpenMath encoding" OpenMath.propEncoding + Substitution.tests + Unification.unificationTests + Strategy.tests + suite "Field properties" $ + mapM_ (addProperty "field") Algebra.propsField + suite "Boolean properties" $ + mapM_ (addProperty "boolean") Algebra.propsBoolean + + suite "Domain checks" domainSuite + + suite "Exercise checks" $ + forM_ list $ \(Some ex) -> + exerciseTestSuite ex + + suite "Black box tests" $ + join (liftIO (blackBoxTests run dir)) + +-- Returns the number of tests performed +blackBoxTests :: (DomainReasoner Bool -> IO Bool) -> String -> IO TestSuite +blackBoxTests run path = do + putStrLn ("Scanning " ++ path) + -- analyse content + xs0 <- getDirectoryContents path + let (xml, xs1) = partition (".xml" `isSuffixOf`) xs0 + (json, xs2) = partition (".json" `isSuffixOf`) xs1 + -- perform tests + ts1 <- forM json $ \x -> + doBlackBoxTest run JSON (path ++ "/" ++ x) + ts2 <- forM xml $ \x -> + doBlackBoxTest run XML (path ++ "/" ++ x) + -- recursively visit subdirectories + ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do + let p = path ++ "/" ++ x + valid <- doesDirectoryExist p + if not valid + then return (return ()) + else liftM (suite $ "Directory " ++ simplerDirectory p) + (blackBoxTests run p) + return $ + sequence_ (ts1 ++ ts2 ++ ts3) + +doBlackBoxTest :: (DomainReasoner Bool -> IO Bool) -> DataFormat -> FilePath -> IO TestSuite +doBlackBoxTest run format path = do + b <- doesFileExist expPath + return $ if not b + then warn $ expPath ++ " does not exist" + else assertIO (stripDirectoryPart path) $ run $ do + -- Comparing output with expected output + (txt, expt) <- liftIO $ do + useFixedStdGen -- fix the random number generator + txt <- readFile path + expt <- liftIO $ readFile expPath + return (txt, expt) + out <- case format of + JSON -> liftM snd3 (processJSON txt) + XML -> liftM snd3 (processXML txt) + -- Conditional forces evaluation of the result, to make sure that + -- all file handles are closed afterwards. + if out ~= expt then return True else return False + `catchError` + \_ -> return False + where + expPath = baseOf path ++ ".exp" + baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse + x ~= y = filterVersion x == filterVersion y -- compare line-based + + filterVersion = + let p s = not (null s || "version" `isInfixOf` s) + in filter p . lines . filter (/= '\r') + +simplerDirectory :: String -> String +simplerDirectory s + | "../" `isPrefixOf` s = simplerDirectory (drop 3 s) + | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s) + | otherwise = s + +stripDirectoryPart :: String -> String +stripDirectoryPart = reverse . takeWhile (/= '/') . reverse + +{- +logicConfluence :: IO () +logicConfluence = reportTest "logic rules" (isConfluent f rs) + where + f = normalizeWith ops . normalFormWith ops rs + ops = map makeCommutative Logic.logicOperators + rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd] + rs = [ r | RewriteRule r <- concatMap transformations rwrs ] + -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] -} diff --git a/src/Documentation/ServicePage.hs b/src/Documentation/ServicePage.hs --- a/src/Documentation/ServicePage.hs +++ b/src/Documentation/ServicePage.hs @@ -1,119 +1,115 @@ -{-# OPTIONS -XRankNTypes #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.ServicePage (makeServicePage) where - -import Documentation.DefaultPage -import Service.ExercisePackage -import Service.TypedExample -import Service.Types -import Service.DomainReasoner -import Service.State -import Text.HTML -import qualified Text.XML as XML -import Text.XML (XML) -import Control.Monad -import Common.Exercise -import Common.Utils (Some(..)) - -makeServicePage :: String -> Service -> DomainReasoner () -makeServicePage dir s = do - xs <- examplesFor (showId s) - generatePageAt 1 dir (servicePageFile s) (servicePage xs s) - -servicePage :: [Example] -> Service -> HTMLBuilder -servicePage xs s = do - h1 (showId s) - - para $ do - bold $ text "Signature:" - space - case serviceFunction s of - _ ::: t -> ttText (show t) - para $ do - bold $ text "Description: " - br - text $ description s - - when (serviceDeprecated s) $ - para $ bold $ text "Warning: this service is deprecated!" - - unless (null xs) $ do - h2 $ "XML examples (" ++ show (length xs) ++ ")" - forM_ (zip [1::Int ..] xs) $ - \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do - h2 $ show i ++ ". " ++ msg - bold $ text "Request:" - highlightXML True xmlRequest - bold $ text "Reply:" - highlightXML True xmlReply - unless xmlTest $ - XML.element "font" $ do - "color" XML..=. "red" - bold $ text "Error: invalid request/reply pair" - ------------------------------------------------------------------------ --- Examples - -type Example = (String, (XML, XML, Bool)) - -examplesFor :: String -> DomainReasoner [Example] -examplesFor s = tryAll [ f t | (t, f) <- list, s == t ] - where - list = - [ ("derivation", makeExample "logic.dnf" (noCfg +++ logic1)) - , ("derivation", makeExample "math.lineq" (noCfg +++ lineq1)) - , ("allfirsts", makeExample "logic.dnf" logic2) - , ("allfirsts", makeExample "math.lineq" lineq2) - , ("onefirst", makeExample "logic.dnf" logic2) - , ("onefirst", makeExample "math.lineq" lineq2) - , ("rulesinfo", makeExample "math.lineq" noArgs) - , ("rulelist", makeExample "math.lineq" exArgs) - , ("strategyinfo", makeExample "math.lineq" exArgs) - , ("examples", makeExample "math.lineq" exArgs) - ] - - logic1, logic2 :: Args - logic1 pkg = newState pkg "~(p /\\ ~q)" - logic2 pkg = newState pkg "~~p /\\ T" - - lineq1, lineq2 :: Args - lineq1 pkg = newState pkg "5*(x+1) == 11" - lineq2 pkg = newState pkg "5*(x+1) == (x-1)/2" - - (f +++ g) pkg = f pkg ++ g pkg - - noCfg _ = [Nothing ::: maybeTp StrategyCfg] - noArgs _ = [] - exArgs pkg = [pkg ::: ExercisePkg] - -tryAll :: [DomainReasoner a] -> DomainReasoner [a] -tryAll xs = - let f m = liftM return m `catchError` const (return []) - in liftM concat (mapM f xs) - -newState :: Monad m => ExercisePackage a -> String -> m (TypedValue a) -newState pkg s = do - let ex = exercise pkg - case parser ex s of - Left msg -> fail ("newState: " ++ msg) - Right a -> return (emptyState pkg a ::: stateTp) - -type Args = forall a . ExercisePackage a -> [TypedValue a] - -makeExample :: String -> Args -> String -> DomainReasoner Example -makeExample pkgName f srvName = do - let a = newId pkgName - Some pkg <- findPackage a - srv <- findService srvName - tr <- typedExample pkg srv (f pkg) - return (showId pkg, tr) +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.ServicePage (makeServicePage) where + +import Common.Exercise +import Common.Id +import Common.Utils (Some(..)) +import Control.Monad +import Documentation.DefaultPage +import Service.DomainReasoner +import Service.State +import Service.TypedExample +import Service.Types +import Text.HTML +import Text.XML (XML) + +makeServicePage :: String -> Service -> DomainReasoner () +makeServicePage dir s = do + xs <- examplesFor (showId s) + generatePageAt 1 dir (servicePageFile s) (servicePage xs s) + +servicePage :: [Example] -> Service -> HTMLBuilder +servicePage xs s = do + h1 (showId s) + + para $ do + bold $ text "Signature:" + space + case serviceFunction s of + _ ::: t -> ttText (show t) + para $ do + bold $ text "Description: " + br + text $ description s + + when (serviceDeprecated s) $ + para $ bold $ text "Warning: this service is deprecated!" + + unless (null xs) $ do + h2 $ "XML examples (" ++ show (length xs) ++ ")" + forM_ (zip [1::Int ..] xs) $ + \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do + h2 $ show i ++ ". " ++ msg + bold $ text "Request:" + highlightXML True xmlRequest + bold $ text "Reply:" + highlightXML True xmlReply + unless xmlTest $ + spanClass "error" $ + bold $ text "Error: invalid request/reply pair" + +----------------------------------------------------------------------- +-- Examples + +type Example = (String, (XML, XML, Bool)) + +examplesFor :: String -> DomainReasoner [Example] +examplesFor s = tryAll [ f t | (t, f) <- list, s == t ] + where + list = + [ ("derivation", makeExample "logic.dnf" (noCfg +++ logic1)) + , ("derivation", makeExample "math.lineq" (noCfg +++ lineq1)) + , ("allfirsts", makeExample "logic.dnf" logic2) + , ("allfirsts", makeExample "math.lineq" lineq2) + , ("onefirst", makeExample "logic.dnf" logic2) + , ("onefirst", makeExample "math.lineq" lineq2) + , ("rulesinfo", makeExample "math.lineq" noArgs) + , ("rulelist", makeExample "math.lineq" exArgs) + , ("strategyinfo", makeExample "math.lineq" exArgs) + , ("examples", makeExample "math.lineq" exArgs) + ] + + logic1, logic2 :: Args + logic1 ex = newState ex "~(p /\\ ~q)" + logic2 ex = newState ex "~~p /\\ T" + + lineq1, lineq2 :: Args + lineq1 ex = newState ex "5*(x+1) == 11" + lineq2 ex = newState ex "5*(x+1) == (x-1)/2" + + (f +++ g) ex = f ex ++ g ex + + noCfg _ = [Nothing ::: maybeType StrategyCfg] + noArgs _ = [] + exArgs ex = [ex ::: Exercise] + +tryAll :: [DomainReasoner a] -> DomainReasoner [a] +tryAll xs = + let f m = liftM return m `catchError` const (return []) + in liftM concat (mapM f xs) + +newState :: Monad m => Exercise a -> String -> m (TypedValue a) +newState ex s = + case parser ex s of + Left msg -> fail ("newState: " ++ msg) + Right a -> return (emptyState ex a ::: stateType) + +type Args = forall a . Exercise a -> [TypedValue a] + +makeExample :: String -> Args -> String -> DomainReasoner Example +makeExample exName f srvName = do + Some ex <- findExercise (newId exName) + srv <- findService srvName + tr <- typedExample ex srv (f ex) + return (showId ex, tr) diff --git a/src/Documentation/TestsPage.hs b/src/Documentation/TestsPage.hs --- a/src/Documentation/TestsPage.hs +++ b/src/Documentation/TestsPage.hs @@ -1,76 +1,50 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Documentation.TestsPage (makeTestsPage) where - -import Common.TestSuite -import Documentation.DefaultPage -import Documentation.SelfCheck -import Service.DomainReasoner -import Text.HTML -import qualified Text.XML as XML - -makeTestsPage :: String -> String -> DomainReasoner () -makeTestsPage docDir testDir = do - checks <- selfCheck testDir - result <- liftIO (runTestSuiteResult checks) - generatePage docDir testsPageFile (testsPage result) - -testsPage :: TestSuiteResult -> HTMLBuilder -testsPage result = do - h1 "Summary" - preText (makeSummary result) - h1 "Tests" - makeTestLogWith formatHTML result - -formatHTML :: FormatLog HTMLBuilder -formatHTML = FormatLog - { formatRoot = \_ -> id - , formatSuite = \loc s _ _ a -> - showHeader loc s >> a - , formatSuccesses = \xs -> - let f (_, n) = if n==1 then "." else "(passed " ++ show n ++ " tests)" - in mapM_ (\s -> ttText s >> br) (breakLine (concatMap f xs)) - , formatFailure = \s msg -> colorRed $ do - bold (ttText ("Error" ++ putLabel s)) - tt space - ttText msg - br - , formatWarning = \s msg -> colorOrange $ do - ttText ("Warning" ++ putLabel s) - tt space - ttText msg - br - } - where - putLabel s = if null s then ":" else " (" ++ s ++ "):" - -breakLine :: String -> [String] -breakLine xs - | null xs = [] - | otherwise = ys : breakLine zs - where - (ys, zs) = splitAt 80 xs - -showHeader :: [Int] -> String -> HTMLBuilder -showHeader [a] s = h2 (show a ++ ". " ++ s) -showHeader [a,b] s = h3 (show a ++ "." ++ show b ++ ". " ++ s) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.TestsPage (makeTestsPage) where + +import Common.Utils.TestSuite +import Control.Monad +import Documentation.DefaultPage +import Documentation.SelfCheck +import Service.DomainReasoner +import Text.HTML + +makeTestsPage :: String -> String -> DomainReasoner () +makeTestsPage docDir testDir = do + checks <- selfCheck testDir + result <- liftIO (runTestSuiteResult checks) + generatePage docDir testsPageFile (testsPage result) + +testsPage :: TestSuiteResult -> HTMLBuilder +testsPage result = do + h1 "Summary" + preText (makeSummary result) + h1 "Tests" + formatResult [] result + +formatResult :: [Int] -> TestSuiteResult -> HTMLBuilder +formatResult loc result = do + ttText (show result) + br + forM_ (topMessages result) $ \m -> + spanClass (if isError m then "error" else "warning") + (ttText (show m) >> br) + let subs = zip [1::Int ..] (subResults result) + forM_ subs $ \(i, (s, a)) -> do + let newloc = loc ++ [i] + showHeader newloc s + formatResult newloc a + +showHeader :: [Int] -> String -> HTMLBuilder +showHeader [a] s = h2 (show a ++ ". " ++ s) +showHeader [a,b] s = h3 (show a ++ "." ++ show b ++ ". " ++ s) showHeader _ s = para (bold (text s)) - -colorRed :: HTMLBuilder -> HTMLBuilder -colorRed body = XML.element "font" $ do - "color" XML..=. "red" - body - -colorOrange :: HTMLBuilder -> HTMLBuilder -colorOrange body = XML.element "font" $ do - "color" XML..=. "#FE9A2E" - body diff --git a/src/Documentation/ViewPage.hs b/src/Documentation/ViewPage.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/ViewPage.hs @@ -0,0 +1,74 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Documentation.ViewPage (makeViewPages) where + +import Common.Id +import Common.View +import Control.Monad +import Data.List +import Data.Maybe +import Documentation.DefaultPage +import Documentation.ExampleFile +import Documentation.ExercisePage +import Prelude hiding ((^)) +import Service.DomainReasoner +import Text.HTML + +makeViewPages :: String -> DomainReasoner () +makeViewPages dir = do + views <- liftM (sortBy compareId) getViews + generatePage dir viewsOverviewPageFile (makeOverviewPage views) + forM_ views $ \v -> do + let exFile = dir ++ "/" ++ diagnosisExampleFile (getId v) + xs <- liftIO $ liftM items (readExampleFile exFile) + `catch` \_ -> return [] + generatePageAt 1 dir (viewPageFile v) (viewPage xs v) + +makeOverviewPage :: HasId a => [a] -> HTMLBuilder +makeOverviewPage xs = do + h1 "Views" + table True (top : map make xs) + where + top = map text ["id", "description"] + make x = [link (viewPageFile x) (text (showId x)), text (description x)] + +viewPage :: [Item] -> ViewPackage -> HTMLBuilder +viewPage list (ViewPackage f v) = do + idboxHTML "view" (getId v) + unless (null list) $ do + h2 "Examples" + table True (top : content) + where + top = map text + ["term", "representation", "canonical", "description"] + + content = map present . reorder . concatMap make $ list + + make (Ready t _ descr) = + case f t of + Just a -> + [(True, t, match v a, canonical v a, descr)] + Nothing -> + [(False, t, Nothing, Nothing, descr)] + make _ = [] + + reorder [] = [] + reorder (x:xs) = x : ys ++ reorder zs + where + (ys, zs) | isJust (g x) = partition p xs + | otherwise = ([], xs) + p a = g a == g x + g (_, _, _, c, _) = c + + present (ok, t, b, c, descr) = + let mark = if ok then id else spanClass "error" + in map (mark . text) [t, maybe "-" show b, maybe "-" show c, descr] diff --git a/src/Domain/LinearAlgebra.hs b/src/Domain/LinearAlgebra.hs --- a/src/Domain/LinearAlgebra.hs +++ b/src/Domain/LinearAlgebra.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,20 +9,12 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra - ( module Domain.LinearAlgebra.Matrix - , module Domain.LinearAlgebra.Parser - , module Domain.LinearAlgebra.MatrixRules - , module Domain.LinearAlgebra.EquationsRules - , module Domain.LinearAlgebra.Strategies - , module Domain.LinearAlgebra.LinearSystem - , module Domain.LinearAlgebra.Exercises - ) where - -import Domain.LinearAlgebra.Matrix -import Domain.LinearAlgebra.Parser -import Domain.LinearAlgebra.MatrixRules -import Domain.LinearAlgebra.EquationsRules hiding (changeCover, findIndexM) -import Domain.LinearAlgebra.Strategies -import Domain.LinearAlgebra.LinearSystem -import Domain.LinearAlgebra.Exercises +module Domain.LinearAlgebra (module Export) where + +import Domain.LinearAlgebra.EquationsRules as Export hiding (changeCover, findIndexM) +import Domain.LinearAlgebra.Exercises as Export +import Domain.LinearAlgebra.LinearSystem as Export +import Domain.LinearAlgebra.Matrix as Export +import Domain.LinearAlgebra.MatrixRules as Export +import Domain.LinearAlgebra.Parser as Export +import Domain.LinearAlgebra.Strategies as Export diff --git a/src/Domain/LinearAlgebra/Checks.hs b/src/Domain/LinearAlgebra/Checks.hs --- a/src/Domain/LinearAlgebra/Checks.hs +++ b/src/Domain/LinearAlgebra/Checks.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -14,7 +14,8 @@ import Common.Classes import Common.Context import Common.Exercise -import Common.TestSuite +import Common.Utils.TestSuite +import Data.Maybe import Domain.LinearAlgebra hiding (getSolution) import Domain.Math.Expr import Domain.Math.Simplification (simplify) @@ -33,12 +34,12 @@ propEchelon :: Matrix Rational -> Bool propEchelon = - withoutContext inRowEchelonForm . applyD forwardPass . gaussContext + fromMaybe False . fromContextWith inRowEchelonForm . applyD forwardPass . gaussContext propReducedEchelon :: Matrix Rational -> Bool -propReducedEchelon = - withoutContext inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext - +propReducedEchelon = + fromMaybe False . fromContextWith inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext + propSound :: Matrix Rational -> Bool propSound m = (fromContext . applyD gaussianElimStrategy . gaussContext) m @@ -46,7 +47,7 @@ propSolution :: Matrix Rational -> Property propSolution m1 = - forAll (arbSolution m1) $ \(solution, m2) -> + forAll (arbSolution m1) $ \(solution, m2) -> let m3 = (fromContext . applyD gaussianElimStrategy . gaussContext) m2 p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0 g = (*) . fromRational @@ -58,9 +59,6 @@ let finalCol = map (return . sum . zipWith (*) solution) (rows m) newMatrix = makeMatrix $ zipWith (++) (rows m) finalCol return (solution, newMatrix) - -withoutContext :: (a -> Bool) -> Context a -> Bool -withoutContext f = maybe False f . fromContext gaussContext :: Matrix Rational -> Context (Matrix Expr) gaussContext = inContext gaussianElimExercise . fmap fromRational diff --git a/src/Domain/LinearAlgebra/EquationsRules.hs b/src/Domain/LinearAlgebra/EquationsRules.hs --- a/src/Domain/LinearAlgebra/EquationsRules.hs +++ b/src/Domain/LinearAlgebra/EquationsRules.hs @@ -1,219 +1,215 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.LinearAlgebra.EquationsRules where - -import Prelude hiding (repeat) -import Common.Context -import Common.Transformation -import Common.Utils -import Common.Navigator -import Common.Id -import Common.View hiding (simplify) -import Control.Monad -import Data.List hiding (repeat) -import Data.Maybe -import Domain.Math.Expr -import Domain.Math.Data.Relation -import Domain.Math.Simplification (simplify) -import Domain.LinearAlgebra.LinearView -import Domain.LinearAlgebra.LinearSystem -import Domain.LinearAlgebra.MatrixRules (covered) -- for context -import Test.QuickCheck - -equationsRules :: [Rule (Context (LinearSystem Expr))] -equationsRules = - [ ruleExchangeEquations, ruleEliminateVar, ruleDropEquation - , ruleInconsistentSystem - , ruleScaleEquation, ruleBackSubstitution, ruleIdentifyFreeVariables - , ruleCoverUpEquation, ruleUncoverEquation, ruleCoverAllEquations - ] - -ruleExchangeEquations :: Rule (Context (LinearSystem Expr)) -ruleExchangeEquations = describe "Exchange two equations" $ - simplifySystem $ makeRule "linearalgebra.linsystem.exchange" $ - supplyLabeled2 descr args (\x y -> liftTransContext $ exchange x y) - where - descr = ("equation 1", "equation 2") - args = evalCM $ \ls -> do - mv <- minvar ls - eqs <- remaining ls - i <- findIndexM (elem mv . getVarsSystem . return) eqs - cov <- readVar covered - return (cov, cov + i) - -ruleEliminateVar :: Rule (Context (LinearSystem Expr)) -ruleEliminateVar = describe "Eliminate a variable (using addition)" $ - simplifySystem $ makeRule "linearalgebra.linsystem.eliminate" $ - supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z) - where - descr = ("equation 1", "equation 2", "scale factor") - args = evalCM $ \ls -> do - mv <- minvar ls - hd:rest <- remaining ls - let getCoef = coefficientOf mv . leftHandSide - (i, coef) <- maybeCM $ safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ] - guard (getCoef hd /= 0) - let v = negate coef / getCoef hd - cov <- readVar covered - return (i + cov + 1, cov, v) - -ruleDropEquation :: Rule (Context (LinearSystem Expr)) -ruleDropEquation = describe "Drop trivial equations (such as 0=0)" $ - simplifySystem $ makeSimpleRule "linearalgebra.linsystem.trivial" $ withCM $ \ls -> do - i <- findIndexM (fromMaybe False . testConstants (==)) ls - modifyVar covered (\n -> if i < n then n-1 else n) - return (deleteIndex i ls) - -ruleInconsistentSystem :: Rule (Context (LinearSystem Expr)) -ruleInconsistentSystem = describe "Inconsistent system (0=1)" $ - simplifySystem $ makeSimpleRule "linearalgebra.linsystem.inconsistent" $ withCM $ \ls -> do - let stop = [0 :==: 1] - guard (invalidSystem ls && ls /= stop) - writeVar covered 1 - return stop - -ruleScaleEquation :: Rule (Context (LinearSystem Expr)) -ruleScaleEquation = describe "Scale equation to one" $ - simplifySystem $ makeRule "linearalgebra.linsystem.scale" $ - supplyLabeled2 descr args (\x y -> liftTransContext $ scaleEquation x y) - where - descr = ("equation", "scale factor") - args = evalCM $ \ls -> do - cov <- readVar covered - eq <- maybeCM $ safeHead $ drop cov ls - let expr = leftHandSide eq - mv <- minvar ls - guard (coefficientOf mv expr /= 0) - let coef = 1 / coefficientOf mv expr - return (cov, coef) - -ruleBackSubstitution :: Rule (Context (LinearSystem Expr)) -ruleBackSubstitution = describe "Back substitution" $ - simplifySystem $ makeRule "linearalgebra.linsystem.subst" $ - supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z) - where - descr = ("equation 1", "equation 2", "scale factor") - args = evalCM $ \ls -> do - cov <- readVar covered - eq <- maybeCM $ safeHead $ drop cov ls - let expr = leftHandSide eq - mv <- maybeCM $ safeHead (vars expr) - i <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls) - let coef = negate $ coefficientOf mv (leftHandSide (ls !! i)) - return (i, cov, coef) - -ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a)) -ruleIdentifyFreeVariables = describe "Identify free variables" $ - minorRule $ makeSimpleRule "linearalgebra.linsystem.freevars" $ withCM $ \ls -> - let vs = [ head ys | ys <- map (vars . leftHandSide) ls, not (null ys) ] - f eq = - let (e1, e2) = splitLinearExpr (`notElem` vs) (leftHandSide eq) -- constant ends up in e1 - in e2 :==: rightHandSide eq - e1 - in return (map f ls) - -ruleCoverUpEquation :: Rule (Context (LinearSystem a)) -ruleCoverUpEquation = describe "Cover up first equation" $ - minorRule $ makeRule "linearalgebra.linsystem.coverup" $ changeCover succ - -ruleUncoverEquation :: Rule (Context (LinearSystem a)) -ruleUncoverEquation = describe "Uncover one equation" $ - minorRule $ makeRule "linearalgebra.linsystem.uncover" $ changeCover pred - -ruleCoverAllEquations :: Rule (Context (LinearSystem a)) -ruleCoverAllEquations = describe "Cove all equations" $ - minorRule $ makeSimpleRule "linearalgebra.linsystem.coverall" $ withCM $ \ls -> do - writeVar covered (length ls) - return ls - --- local helper functions -deleteIndex :: Int -> [a] -> [a] -deleteIndex i xs = ys ++ drop 1 zs - where (ys, zs) = splitAt i xs - -testConstants :: IsLinear a => (a -> a -> Bool) -> Equation a -> Maybe Bool -testConstants f (lhs :==: rhs) - | hasNoVar lhs && hasNoVar rhs = Just (f lhs rhs) - | otherwise = Nothing - --- simplify a linear system -simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr)) -simplifySystem = doAfter $ change (map (fmap f)) - where f = simplifyWith (fmap simplify) linearView - ---------------------------------------------------------------------------------- --- Parameterized transformations - -exchange :: Int -> Int -> Transformation [a] -exchange i j - | i > j = exchange j i - | otherwise = makeTrans $ \xs -> do - guard (i/=j && validEquation i xs && validEquation j xs) - let (begin, x:rest) = splitAt i xs - (middle, y:end) = splitAt (j-i-1) rest - return $ begin++[y]++middle++[x]++end - -scaleEquation :: IsLinear a => Int -> a -> Transformation (LinearSystem a) -scaleEquation i a = makeTrans $ \xs -> do - guard (a `notElem` [0,1] && validEquation i xs) - let (begin, this:end) = splitAt i xs - return (begin ++ [fmap (a*) this] ++ end) - -addEquations :: IsLinear a => Int -> Int -> a -> Transformation (LinearSystem a) -addEquations i j a = makeTrans $ \xs -> do - guard (i/=j && validEquation i xs && validEquation j xs) - let (begin, this:end) = splitAt i xs - exprj = xs!!j - return $ begin++[combineWith (+) this (fmap (a*) exprj)]++end - -changeCover :: (Int -> Int) -> Transformation (Context (LinearSystem a)) -changeCover f = makeTrans $ withCM $ \ls -> do - new <- liftM f (readVar covered) - guard (new >= 0 && new <= length ls) - writeVar covered new - return ls - --- local helper function -combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a -combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2 - -validEquation :: Int -> [a] -> Bool -validEquation n xs = n >= 0 && n < length xs - --------------------- --- TEMP - --- | The equations that remain to be solved -remaining :: LinearSystem a -> ContextMonad (Equations a) -remaining ls = do - cov <- readVar covered - return (drop cov ls) - --- | The minimal variable in the remaining equations -minvar :: IsLinear a => LinearSystem a -> ContextMonad String -minvar ls = do - list <- liftM getVarsSystem (remaining ls) - guard (not $ null list) - return (minimum list) - -systemInNF :: (Arbitrary a, IsLinear a) => Gen (LinearSystem a) -systemInNF = do - n <- arbitrary - replicateM n $ liftM2 (:==:) arbitrary arbitrary - -toIntegerSystem :: RealFrac a => LinearSystem a -> LinearSystem Integer -toIntegerSystem = map (fmap round) - -fromIntegerSystem :: RealFrac a => LinearSystem Integer -> LinearSystem a -fromIntegerSystem = map (fmap fromInteger) - -findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.EquationsRules where + +import Common.Library hiding (simplify) +import Common.Utils +import Control.Monad +import Data.List +import Data.Maybe +import Domain.LinearAlgebra.LinearSystem +import Domain.LinearAlgebra.LinearView +import Domain.LinearAlgebra.MatrixRules (covered) -- for context +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Simplification (simplify) +import Prelude +import Test.QuickCheck + +equationsRules :: [Rule (Context (LinearSystem Expr))] +equationsRules = + [ ruleExchangeEquations, ruleEliminateVar, ruleDropEquation + , ruleInconsistentSystem + , ruleScaleEquation, ruleBackSubstitution, ruleIdentifyFreeVariables + , ruleCoverUpEquation, ruleUncoverEquation, ruleCoverAllEquations + ] + +ruleExchangeEquations :: Rule (Context (LinearSystem Expr)) +ruleExchangeEquations = describe "Exchange two equations" $ + simplifySystem $ makeRule "linearalgebra.linsystem.exchange" $ + supply2 descr args (\x y -> liftTransContext $ exchange x y) + where + descr = ("equation 1", "equation 2") + args = evalCM $ \ls -> do + mv <- minvar ls + eqs <- remaining ls + i <- findIndexM (elem mv . getVarsSystem . return) eqs + cov <- readVar covered + return (cov, cov + i) + +ruleEliminateVar :: Rule (Context (LinearSystem Expr)) +ruleEliminateVar = describe "Eliminate a variable (using addition)" $ + simplifySystem $ makeRule "linearalgebra.linsystem.eliminate" $ + supply3 descr args (\x y z -> liftTransContext $ addEquations x y z) + where + descr = ("equation 1", "equation 2", "scale factor") + args = evalCM $ \ls -> do + mv <- minvar ls + hd:rest <- remaining ls + let getCoef = coefficientOf mv . leftHandSide + (i, coef) <- maybeCM $ safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ] + guard (getCoef hd /= 0) + let v = negate coef / getCoef hd + cov <- readVar covered + return (i + cov + 1, cov, v) + +ruleDropEquation :: Rule (Context (LinearSystem Expr)) +ruleDropEquation = describe "Drop trivial equations (such as 0=0)" $ + simplifySystem $ makeSimpleRule "linearalgebra.linsystem.trivial" $ withCM $ \ls -> do + i <- findIndexM (fromMaybe False . testConstants (==)) ls + modifyVar covered (\n -> if i < n then n-1 else n) + return (deleteIndex i ls) + +ruleInconsistentSystem :: Rule (Context (LinearSystem Expr)) +ruleInconsistentSystem = describe "Inconsistent system (0=1)" $ + simplifySystem $ makeSimpleRule "linearalgebra.linsystem.inconsistent" $ withCM $ \ls -> do + let stop = [0 :==: 1] + guard (invalidSystem ls && ls /= stop) + writeVar covered 1 + return stop + +ruleScaleEquation :: Rule (Context (LinearSystem Expr)) +ruleScaleEquation = describe "Scale equation to one" $ + simplifySystem $ makeRule "linearalgebra.linsystem.scale" $ + supply2 descr args (\x y -> liftTransContext $ scaleEquation x y) + where + descr = ("equation", "scale factor") + args = evalCM $ \ls -> do + cov <- readVar covered + eq <- maybeCM $ safeHead $ drop cov ls + let expr = leftHandSide eq + mv <- minvar ls + guard (coefficientOf mv expr /= 0) + let coef = 1 / coefficientOf mv expr + return (cov, coef) + +ruleBackSubstitution :: Rule (Context (LinearSystem Expr)) +ruleBackSubstitution = describe "Back substitution" $ + simplifySystem $ makeRule "linearalgebra.linsystem.subst" $ + supply3 descr args (\x y z -> liftTransContext $ addEquations x y z) + where + descr = ("equation 1", "equation 2", "scale factor") + args = evalCM $ \ls -> do + cov <- readVar covered + eq <- maybeCM $ safeHead $ drop cov ls + let expr = leftHandSide eq + mv <- maybeCM $ safeHead (vars expr) + i <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls) + let coef = negate $ coefficientOf mv (leftHandSide (ls !! i)) + return (i, cov, coef) + +ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a)) +ruleIdentifyFreeVariables = describe "Identify free variables" $ + minorRule $ makeSimpleRule "linearalgebra.linsystem.freevars" $ withCM $ \ls -> + let vs = [ head ys | ys <- map (vars . leftHandSide) ls, not (null ys) ] + f eq = + let (e1, e2) = splitLinearExpr (`notElem` vs) (leftHandSide eq) -- constant ends up in e1 + in e2 :==: rightHandSide eq - e1 + in return (map f ls) + +ruleCoverUpEquation :: Rule (Context (LinearSystem a)) +ruleCoverUpEquation = describe "Cover up first equation" $ + minorRule $ makeRule "linearalgebra.linsystem.coverup" $ changeCover succ + +ruleUncoverEquation :: Rule (Context (LinearSystem a)) +ruleUncoverEquation = describe "Uncover one equation" $ + minorRule $ makeRule "linearalgebra.linsystem.uncover" $ changeCover pred + +ruleCoverAllEquations :: Rule (Context (LinearSystem a)) +ruleCoverAllEquations = describe "Cove all equations" $ + minorRule $ makeSimpleRule "linearalgebra.linsystem.coverall" $ withCM $ \ls -> do + writeVar covered (length ls) + return ls + +-- local helper functions +deleteIndex :: Int -> [a] -> [a] +deleteIndex i xs = ys ++ drop 1 zs + where (ys, zs) = splitAt i xs + +testConstants :: IsLinear a => (a -> a -> Bool) -> Equation a -> Maybe Bool +testConstants f (lhs :==: rhs) + | hasNoVar lhs && hasNoVar rhs = Just (f lhs rhs) + | otherwise = Nothing + +-- simplify a linear system +simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr)) +simplifySystem = doAfter $ change (map (fmap f)) + where f = simplifyWith (fmap simplify) linearView + +--------------------------------------------------------------------------------- +-- Parameterized transformations + +exchange :: Int -> Int -> Transformation [a] +exchange i j + | i > j = exchange j i + | otherwise = makeTrans $ \xs -> do + guard (i/=j && validEquation i xs && validEquation j xs) + let (begin, x:rest) = splitAt i xs + (middle, y:end) = splitAt (j-i-1) rest + return $ begin++[y]++middle++[x]++end + +scaleEquation :: IsLinear a => Int -> a -> Transformation (LinearSystem a) +scaleEquation i a = makeTrans $ \xs -> do + guard (a `notElem` [0,1] && validEquation i xs) + let (begin, this:end) = splitAt i xs + return (begin ++ [fmap (a*) this] ++ end) + +addEquations :: IsLinear a => Int -> Int -> a -> Transformation (LinearSystem a) +addEquations i j a = makeTrans $ \xs -> do + guard (i/=j && validEquation i xs && validEquation j xs) + let (begin, this:end) = splitAt i xs + exprj = xs!!j + return $ begin++[combineWith (+) this (fmap (a*) exprj)]++end + +changeCover :: (Int -> Int) -> Transformation (Context (LinearSystem a)) +changeCover f = makeTrans $ withCM $ \ls -> do + new <- liftM f (readVar covered) + guard (new >= 0 && new <= length ls) + writeVar covered new + return ls + +-- local helper function +combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a +combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2 + +validEquation :: Int -> [a] -> Bool +validEquation n xs = n >= 0 && n < length xs + +-------------------- +-- TEMP + +-- | The equations that remain to be solved +remaining :: LinearSystem a -> ContextMonad (Equations a) +remaining ls = do + cov <- readVar covered + return (drop cov ls) + +-- | The minimal variable in the remaining equations +minvar :: IsLinear a => LinearSystem a -> ContextMonad String +minvar ls = do + list <- liftM getVarsSystem (remaining ls) + guard (not $ null list) + return (minimum list) + +systemInNF :: (Arbitrary a, IsLinear a) => Gen (LinearSystem a) +systemInNF = do + n <- arbitrary + replicateM n $ liftM2 (:==:) arbitrary arbitrary + +toIntegerSystem :: RealFrac a => LinearSystem a -> LinearSystem Integer +toIntegerSystem = map (fmap round) + +fromIntegerSystem :: RealFrac a => LinearSystem Integer -> LinearSystem a +fromIntegerSystem = map (fmap fromInteger) + +findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int findIndexM p = maybe mzero return . findIndex p diff --git a/src/Domain/LinearAlgebra/Exercises.hs b/src/Domain/LinearAlgebra/Exercises.hs --- a/src/Domain/LinearAlgebra/Exercises.hs +++ b/src/Domain/LinearAlgebra/Exercises.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,16 +9,14 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra.Exercises +module Domain.LinearAlgebra.Exercises ( gramSchmidtExercise, linearSystemExercise , gaussianElimExercise, systemWithMatrixExercise ) where -import Common.Classes -import Common.Context -import Common.Exercise -import Common.Transformation +import Common.Library hiding (simplify) import Control.Monad +import Data.Function import Domain.LinearAlgebra.EquationsRules import Domain.LinearAlgebra.GramSchmidtRules import Domain.LinearAlgebra.LinearSystem @@ -41,10 +39,11 @@ Right a -> Right (fmap simplified a) Left msg -> Left msg , prettyPrinter = unlines . map show . vectors - , equivalence = \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt + , equivalence = withoutContext $ + \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt in f x == f y , extraRules = rulesGramSchmidt - , isReady = orthonormalList . filter (not . isZero) . vectors + , ready = predicate (orthonormalList . filter (not . isZero) . vectors) , strategy = gramSchmidtStrategy , randomExercise = let f = simplified . fromInteger . (`mod` 25) in simpleGenerator (liftM (fmap f) arbitrary) @@ -59,37 +58,39 @@ Right a -> Right (simplify a) Left msg -> Left msg , prettyPrinter = unlines . map show - , equivalence = \x y -> let f = fromContext . applyD linearSystemStrategy + , equivalence = withoutContext $ + \x y -> let f = fromContext . applyD linearSystemStrategy . inContext linearSystemExercise . map toStandardForm - in case (f x, f y) of + in case (f x, f y) of (Just a, Just b) -> getSolution a == getSolution b - _ -> False + _ -> False , extraRules = equationsRules , ruleOrdering = ruleOrderingWithId [getId ruleScaleEquation] - , isReady = inSolvedForm + , ready = predicate inSolvedForm , strategy = linearSystemStrategy , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix) } - + gaussianElimExercise :: Exercise (Matrix Expr) gaussianElimExercise = makeExercise - { exerciseId = describe "Gaussian Elimination" $ + { exerciseId = describe "Gaussian Elimination" $ newId "linearalgebra.gaussianelim" , status = Stable , parser = \s -> case parseMatrix s of Right a -> Right (simplify a) Left msg -> Left msg , prettyPrinter = ppMatrixWith show - , equivalence = \x y -> fmap simplified x === fmap simplified y + , equivalence = withoutContext (eqMatrix `on` fmap simplified) , extraRules = matrixRules - , isReady = inRowReducedEchelonForm + , ready = predicate inRowReducedEchelonForm , strategy = gaussianElimStrategy , randomExercise = simpleGenerator arbMatrix + , testGenerator = Just arbMatrix } - + systemWithMatrixExercise :: Exercise Expr systemWithMatrixExercise = makeExercise - { exerciseId = describe "Solve Linear System with Matrix" $ + { exerciseId = describe "Solve Linear System with Matrix" $ newId "linearalgebra.systemwithmatrix" , status = Provisional , parser = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of @@ -100,40 +101,39 @@ (Just ls, _) -> (unlines . map show) (ls :: Equations Expr) (_, Just m) -> ppMatrix (m :: Matrix Expr) _ -> show expr - , equivalence = \x y -> let f expr = case (fromExpr expr, fromExpr expr) of + , equivalence = withoutContext $ + \x y -> let f expr = case (fromExpr expr, fromExpr expr) of (Just ls, _) -> Just (ls :: Equations Expr) (_, Just m) -> Just $ matrixToSystem (m :: Matrix Expr) _ -> Nothing in case (f x, f y) of - (Just a, Just b) -> equivalence linearSystemExercise a b + (Just a, Just b) -> simpleEquivalence linearSystemExercise a b _ -> False , extraRules = map useC equationsRules ++ map useC (matrixRules :: [Rule (Context (Matrix Expr))]) - , isReady = inSolvedForm . (fromExpr :: Expr -> Equations Expr) + , ready = predicate (inSolvedForm . (fromExpr :: Expr -> Equations Expr)) , strategy = systemWithMatrixStrategy , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr))) , testGenerator = fmap (liftM toExpr) (testGenerator linearSystemExercise) } - + -------------------------------------------------------------- -- Other stuff (to be cleaned up) arbMatrix :: Num a => Gen (Matrix a) arbMatrix = fmap (fmap fromInteger) arbNiceMatrix - + arbUpperMatrix :: (Enum a, Num a) => Gen (Matrix a) -arbUpperMatrix = do - a <- oneof $ map return [-5 .. 5] - b <- oneof $ map return [-5 .. 5] - c <- oneof $ map return [-5 .. 5] - return $ makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]] +arbUpperMatrix = threeNums $ \a b c -> + makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]] arbAugmentedMatrix :: (Enum a, Num a) => Gen (Matrix a) -arbAugmentedMatrix = do - a <- oneof $ map return [-5 .. 5] - b <- oneof $ map return [-5 .. 5] - c <- oneof $ map return [-5 .. 5] - return $ makeMatrix [[1, 0, 0, 1], [a, 1, 0, 1], [b, c, 1, 1]] - +arbAugmentedMatrix = threeNums $ \a b c -> + makeMatrix [[1, 0, 0, 1], [a, 1, 0, 1], [b, c, 1, 1]] + +threeNums :: (Enum a, Num a) => (a -> a -> a -> b) -> Gen b +threeNums f = let m = elements [-5 .. 5] + in liftM3 f m m m + arbNiceMatrix :: (Enum a, Num a) => Gen (Matrix a) arbNiceMatrix = do m1 <- arbUpperMatrix diff --git a/src/Domain/LinearAlgebra/GramSchmidtRules.hs b/src/Domain/LinearAlgebra/GramSchmidtRules.hs --- a/src/Domain/LinearAlgebra/GramSchmidtRules.hs +++ b/src/Domain/LinearAlgebra/GramSchmidtRules.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -12,11 +12,11 @@ module Domain.LinearAlgebra.GramSchmidtRules where import Common.Context -import Common.Transformation import Common.Navigator hiding (current) +import Common.Transformation import Common.Utils -import Domain.LinearAlgebra.Vector import Control.Monad +import Domain.LinearAlgebra.Vector varI, varJ :: Var Int varI = newVar "considered" 0 @@ -36,7 +36,7 @@ -- Make the current vector orthogonal with some other vector -- that has already been considered ruleOrthogonal :: Floating a => Rule (Context (VectorSpace a)) -ruleOrthogonal = makeRule "Make orthogonal" $ supplyLabeled2 descr args transOrthogonal +ruleOrthogonal = makeRule "Make orthogonal" $ supply2 descr args transOrthogonal where descr = ("vector 1", "vector 2") args = evalCM $ \_ -> do @@ -45,7 +45,7 @@ guard (i>j) return (j, i) --- Variable "j" is for administrating which vectors are already orthogonal +-- Variable "j" is for administrating which vectors are already orthogonal ruleNextOrthogonal :: Rule (Context (VectorSpace a)) ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $ withCM $ \vs -> do i <- readVar varI @@ -54,7 +54,7 @@ writeVar varJ j return vs --- Consider the next vector +-- Consider the next vector -- This rule should fail if there are no vectors left ruleNext :: Rule (Context (VectorSpace a)) ruleNext = minorRule $ makeSimpleRule "Consider next vector" $ withCM $ \vs -> do @@ -73,7 +73,7 @@ setCurrent :: Vector a -> VectorSpace a -> ContextMonad (VectorSpace a) setCurrent v vs = do - i <- readVar varI + i <- readVar varI case splitAt (i-1) (vectors vs) of (xs, _:ys) -> return $ makeVectorSpace (xs ++ v:ys) _ -> mzero @@ -87,7 +87,7 @@ guard (isUnit u) case splitAt j (vectors xs) of (begin, v:end) -> Just $ makeVectorSpace $ begin ++ makeOrthogonal u v:end - _ -> Nothing + _ -> Nothing -- Find proper abstraction, and move this function to transformation module contextTrans :: (a -> Maybe a) -> Transformation (Context a) diff --git a/src/Domain/LinearAlgebra/LinearSystem.hs b/src/Domain/LinearAlgebra/LinearSystem.hs --- a/src/Domain/LinearAlgebra/LinearSystem.hs +++ b/src/Domain/LinearAlgebra/LinearSystem.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,25 +11,25 @@ ----------------------------------------------------------------------------- module Domain.LinearAlgebra.LinearSystem where -import Domain.Math.Data.Relation -import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows) -import Domain.LinearAlgebra.LinearView +import Common.Rewriting +import Common.Utils +import Common.Utils.Uniplate +import Control.Monad +import Data.Foldable (toList) import Data.List import Data.Maybe -import Common.Classes -import Control.Monad -import Common.Utils -import Common.Uniplate -import Common.Rewriting +import Domain.LinearAlgebra.LinearView +import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows) +import Domain.Math.Data.Relation import qualified Data.Set as S type LinearSystem a = Equations a getVarsSystem :: IsLinear a => LinearSystem a -> [String] -getVarsSystem = S.toList . S.unions . map varSet . concatMap crush +getVarsSystem = S.toList . S.unions . map varSet . concatMap toList evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool -evalSystem f = +evalSystem f = let evalEq (x :==: y) = x==y in all (evalEq . fmap (evalLinearExpr f)) @@ -50,7 +50,7 @@ make (lhs :==: rhs) = do v <- getVariable lhs return (v, rhs) - + -- No constant on the left, no variables on the right inStandardForm :: IsLinear a => Equation a -> Bool inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && hasNoVar rhs @@ -60,7 +60,6 @@ let c = getConstant rhs - getConstant lhs in (lhs - rhs + c) :==: c - inSolvedForm :: IsLinear a => LinearSystem a -> Bool inSolvedForm xs = invalidSystem xs || isJust (getSolution xs) @@ -83,10 +82,10 @@ where varList = vs ++ (variables \\ vs) makeEquation [] = 0 :==: 0 - makeEquation xs = - let lhs = sum (zipWith (\v a -> a * variable v) varList (init xs)) + makeEquation xs = + let lhs = sum (zipWith (\v a -> a * variable v) varList (init xs)) rhs = last xs in lhs :==: rhs - + variables :: [String] variables = map (\n -> 'x' : [n]) $ ['1' .. '9'] ++ ['a' .. 'z'] -- should be sorted!! diff --git a/src/Domain/LinearAlgebra/LinearView.hs b/src/Domain/LinearAlgebra/LinearView.hs --- a/src/Domain/LinearAlgebra/LinearView.hs +++ b/src/Domain/LinearAlgebra/LinearView.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -14,11 +14,11 @@ , splitLinearExpr, evalLinearExpr, linearView ) where -import Control.Monad -import Data.List import Common.Rewriting -import Common.Uniplate +import Common.Utils.Uniplate import Common.View +import Control.Monad +import Data.List import Domain.Math.Expr import qualified Data.Map as M @@ -29,9 +29,9 @@ linearView :: View Expr (LinearMap Expr) linearView = makeView f g - where + where -- compositional (sumView would be a more restrictive alternative) - f expr = + f expr = case expr of Nat _ -> return $ LM M.empty expr Var s -> return $ LM (M.singleton s 1) 0 @@ -43,7 +43,7 @@ Sqrt a -> join $ liftM sqrtLM (f a) Number _ -> return $ LM M.empty expr Sym s as -> mapM f as >>= symLM s - + g (LM m c) = build sumView (concatMap make (M.toList m) ++ [c | c /= 0]) make (s, e) | e == 0 = [] @@ -58,7 +58,7 @@ negateLM (LM m c) = LM (M.map negate m) (negate c) timesLM :: Num a => LinearMap a -> LinearMap a -> Maybe (LinearMap a) -timesLM lm1@(LM m1 c1) lm2@(LM m2 c2) +timesLM lm1@(LM m1 c1) lm2@(LM m2 c2) | M.null m1 = return $ fmap (c1*) lm2 | M.null m2 = return $ fmap (*c2) lm1 | otherwise = Nothing @@ -101,7 +101,7 @@ Nothing -> descend (evalLinearExpr f) a renameVariables :: IsLinear a => (String -> String) -> a -> a -renameVariables f a = +renameVariables f a = case getVariable a of Just s -> variable (f s) Nothing -> descend (renameVariables f) a diff --git a/src/Domain/LinearAlgebra/Matrix.hs b/src/Domain/LinearAlgebra/Matrix.hs --- a/src/Domain/LinearAlgebra/Matrix.hs +++ b/src/Domain/LinearAlgebra/Matrix.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,29 +9,31 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra.Matrix +module Domain.LinearAlgebra.Matrix ( Matrix, Row, Column, isRectangular, makeMatrix, identity, mapWithPos , changeEntries, changeEntry, setEntries, setEntry , rows, row, columns, column, dimensions, entry, isEmpty , add, scale, multiply - , reduce, forward, backward, inverse, invertible, rank, nullity, (===) + , reduce, forward, backward, inverse, invertible, rank, nullity, eqMatrix , switchRows, scaleRow, addRow , inRowEchelonForm, inRowReducedEchelonForm , nonZero, pivot, isPivotColumn , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular ) where -import Common.Classes -import Common.Rewriting hiding (inverse) +import Common.Rewriting +import Control.Applicative import Control.Monad +import Data.Foldable (Foldable, foldMap) import Data.List hiding (transpose) import Data.Maybe +import Data.Monoid +import Data.Traversable (Traversable, sequenceA) import Domain.Math.Simplification -import Domain.Math.Expr.Symbols (openMathSymbol) import Test.QuickCheck -import qualified Text.OpenMath.Dictionary.Linalg2 as OM import qualified Data.List as L import qualified Data.Map as M +import qualified Text.OpenMath.Dictionary.Linalg2 as OM -- Invariant: a matrix is always rectangular newtype Matrix a = M [[a]] @@ -40,14 +42,17 @@ type Row a = [a] type Column a = [a] -instance Functor Matrix where +instance Functor Matrix where fmap f (M rs) = M (map (map f) rs) -instance Switch Matrix where - switch (M xss) = liftM M (mapM sequence xss) +instance Foldable Matrix where + foldMap f (M xss) = foldMap (mconcat . map f) xss +instance Traversable Matrix where + sequenceA (M xss) = M <$> sequenceA (map sequenceA xss) + instance IsTerm a => IsTerm (Matrix a) where - toTerm = + toTerm = let f = function matrixrowSymbol . map toTerm in function matrixSymbol . map f . rows fromTerm a = do @@ -66,13 +71,13 @@ coarbitrary = coarbitrary . rows arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a) -arbSizedMatrix (i, j) = +arbSizedMatrix (i, j) = do rs <- replicateM i (vector j) return (makeMatrix rs) matrixSymbol, matrixrowSymbol :: Symbol -matrixSymbol = openMathSymbol OM.matrixSymbol -matrixrowSymbol = openMathSymbol OM.matrixrowSymbol +matrixSymbol = newSymbol OM.matrixSymbol +matrixrowSymbol = newSymbol OM.matrixrowSymbol instance Simplify a => Simplify (Matrix a) where simplifyWith opt = fmap (simplifyWith opt) @@ -145,7 +150,7 @@ scale a = fmap (*a) multiply :: Num a => Matrix a -> Matrix a -> Matrix a -multiply a b +multiply a b | snd (dimensions a) == fst (dimensions b) = M $ map (\r -> map (sum . zipWith (*) r) (columns b)) (rows a) | otherwise = @@ -158,7 +163,7 @@ reduce = backward . forward forward :: Fractional a => Matrix a -> Matrix a -forward m +forward m | h==0 || w==0 = m | all (==0) col = M $ zipWith (:) (repeat 0) $ rows $ forward $ M $ map tail $ rows m | x == 0 = forward (switchRows 0 (fromJust $ findIndex (/= 0) col) m) @@ -184,21 +189,21 @@ rank = length . filter (isJust . pivot) . rows . reduce nullity :: Fractional a => Matrix a -> Int -nullity m = snd (dimensions m) - rank m - +nullity m = snd (dimensions m) - rank m + inverse :: Fractional a => Matrix a -> Maybe (Matrix a) inverse m | h /= w = Nothing | rank m < w = Nothing | otherwise = Just $ M $ map (drop h) $ rows $ reduce $ M $ zipWith (++) (rows m) $ rows $ identity h - where + where (h, w) = dimensions m invertible :: Fractional a => Matrix a -> Bool invertible = isJust . inverse -(===) :: Fractional a => Matrix a -> Matrix a -> Bool -m1 === m2 = reduce m1 == reduce m2 +eqMatrix :: Fractional a => Matrix a -> Matrix a -> Bool +eqMatrix m1 m2 = reduce m1 == reduce m2 -- test = rank $ makeMatrix $ [[0 :: Rational ,1,1,1], [1,2,3,2], [3,1,1,3]] @@ -216,7 +221,7 @@ where (i, j) = dimensions m identityMatrix :: Num a => Int -> Matrix a -identityMatrix n = M $ map (\y -> map (\x -> if x==y then 1 else 0) list) list +identityMatrix n = M $ map (\y -> map (\x -> if x==y then 1 else 0) list) list where list = [0..n-1] ------------------------------------------------------- @@ -229,28 +234,28 @@ switchRows i j m@(M rs) | i == j = m | i > j = switchRows j i m - | checkRow i m && checkRow j m = + | checkRow i m && checkRow j m = let (before, r1:rest) = splitAt i rs (middle, r2:after) = splitAt (j-i-1) rest in M $ before ++ [r2] ++ middle ++ [r1] ++ after - | otherwise = + | otherwise = error "switchRows: invalid rows" scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a scaleRow i a m@(M rs) - | checkRow i m = + | checkRow i m = let f y = if y==i then map (*a) else id in M $ zipWith f [0..] rs - | otherwise = + | otherwise = error "scaleRow: invalid row" addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a -addRow i j a m@(M rs) - | checkRow i m && checkRow j m = +addRow i j a m@(M rs) + | checkRow i m && checkRow j m = let rj = map (*a) (row j m) f y = if y==i then zipWith (+) rj else id in M $ zipWith f [0..] rs - | otherwise = + | otherwise = error "addRow: invalid row" ------------------------------------------------------- @@ -265,7 +270,7 @@ inRowEchelonForm :: Num a => Matrix a -> Bool inRowEchelonForm (M rs) = - null (filter nonZero (dropWhile nonZero rs)) && + not (any nonZero (dropWhile nonZero rs)) && increasing (map (length . takeWhile (==0)) (filter nonZero rs)) where increasing (x:ys@(y:_)) = x < y && increasing ys @@ -277,7 +282,7 @@ -- or row canonical form inRowReducedEchelonForm :: Num a => Matrix a -> Bool inRowReducedEchelonForm m@(M rs) = - inRowEchelonForm m && + inRowEchelonForm m && all (==1) (mapMaybe pivot rs) && all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs) @@ -287,7 +292,7 @@ _ -> Nothing isPivotColumn :: Num a => Column a -> Bool -isPivotColumn c = +isPivotColumn c = case filter (/=0) c of [1] -> True _ -> False diff --git a/src/Domain/LinearAlgebra/MatrixRules.hs b/src/Domain/LinearAlgebra/MatrixRules.hs --- a/src/Domain/LinearAlgebra/MatrixRules.hs +++ b/src/Domain/LinearAlgebra/MatrixRules.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,20 +11,20 @@ ----------------------------------------------------------------------------- module Domain.LinearAlgebra.MatrixRules where -import Domain.Math.Simplification -import Domain.LinearAlgebra.Matrix import Common.Context import Common.Navigator import Common.Transformation import Control.Monad import Data.List +import Domain.LinearAlgebra.Matrix +import Domain.Math.Simplification matrixRules :: (Argument a, Fractional a) => [Rule (Context (Matrix a))] -matrixRules = +matrixRules = let noArgs f = f (const Nothing) in [ noArgs ruleScaleRow , noArgs ruleExchangeRows - , noArgs ruleAddMultiple + , noArgs ruleAddMultiple ] ruleFindColumnJ :: Num a => Rule (Context (Matrix a)) @@ -33,7 +33,7 @@ i <- findIndexM nonZero cols writeVar columnJ i return m - + ruleExchangeNonZero :: (Simplify a, Num a) => Rule (Context (Matrix a)) ruleExchangeNonZero = simplify $ ruleExchangeRows $ evalCM $ \m -> do nonEmpty m @@ -61,7 +61,7 @@ cov <- readVar covered let v = negate (col!!i) return (i + cov + 1, cov, v) - + ruleZerosBP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) ruleZerosBP = simplify $ ruleAddMultiple $ evalCM $ \m -> do nonEmpty m @@ -84,17 +84,17 @@ -- Parameterized rules ruleScaleRow :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, a)) -> Rule (Context (Matrix a)) -ruleScaleRow f = makeRule "linearalgebra.gaussianelim.scale" (supplyLabeled2 descr f rowScale) +ruleScaleRow f = makeRule "linearalgebra.gaussianelim.scale" (supply2 descr f rowScale) where descr = ("row", "scale factor") - + ruleExchangeRows :: Num a => (Context (Matrix a) -> Maybe (Int, Int)) -> Rule (Context (Matrix a)) -ruleExchangeRows f = makeRule "linearalgebra.gaussianelim.exchange" (supplyLabeled2 descr f rowExchange) +ruleExchangeRows f = makeRule "linearalgebra.gaussianelim.exchange" (supply2 descr f rowExchange) where descr = ("row 1", "row 2") ruleAddMultiple :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, Int, a)) -> Rule (Context (Matrix a)) -ruleAddMultiple f = makeRule "linearalgebra.gaussianelim.add" (supplyLabeled3 descr f rowAdd) +ruleAddMultiple f = makeRule "linearalgebra.gaussianelim.add" (supply3 descr f rowAdd) where descr = ("row 1", "row2", "scale factor") - + --------------------------------------------------------------------------------- -- Parameterized transformations @@ -102,7 +102,7 @@ rowExchange i j = matrixTrans $ \m -> do guard (i /= j && validRow i m && validRow j m) return (switchRows i j m) - + rowScale :: Num a => Int -> a -> Transformation (Context (Matrix a)) rowScale i k = matrixTrans $ \m -> do guard (k `notElem` [0, 1] && validRow i m) @@ -119,7 +119,7 @@ guard (new >= 0 && new <= fst (dimensions m)) writeVar covered new return m - + matrixTrans :: (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a)) matrixTrans f = makeTrans $ \c -> do a <- fromContext c @@ -129,7 +129,7 @@ -- local helper function validRow :: Int -> Matrix a -> Bool validRow i m = i >= 0 && i < fst (dimensions m) - + nonEmpty :: Matrix a -> ContextMonad () nonEmpty m = subMatrix m >>= guard . not . isEmpty @@ -138,9 +138,9 @@ columnJ = newVar "columnJ" 0 subMatrix :: Matrix a -> ContextMonad (Matrix a) -subMatrix m = do +subMatrix m = do cov <- readVar covered return $ makeMatrix $ drop cov $ rows m - + findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int findIndexM p = maybe mzero return . findIndex p diff --git a/src/Domain/LinearAlgebra/Parser.hs b/src/Domain/LinearAlgebra/Parser.hs --- a/src/Domain/LinearAlgebra/Parser.hs +++ b/src/Domain/LinearAlgebra/Parser.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,87 +9,74 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra.Parser - ( parseMatrix, parseVectorSpace, ppMatrix, ppMatrixWith - , parseSystem +module Domain.LinearAlgebra.Parser + ( parseMatrix, parseVectorSpace, parseSystem + , ppMatrix, ppMatrixWith ) where -import Domain.Math.Data.Relation -import Domain.LinearAlgebra.Matrix +import Data.Char +import Data.Either +import Data.List import Domain.LinearAlgebra.LinearSystem import Domain.LinearAlgebra.LinearView (isLinear) +import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.Vector +import Domain.Math.Data.Relation import Domain.Math.Expr -import Text.Parsing -{- -testje = case parseSystem " \n\n x == 43 \n 3*y == sqrt 4 \n" of -- "\n\n 1*x + 3*y + 2 + 87 == 2 \n " of - this -> this -} - parseSystem :: String -> Either String (LinearSystem Expr) -parseSystem = either Left f . parseWithM s pSystem - where - s0 = specialSymbols "\n" scannerExpr - s = s0 {keywordOperators = "==" : keywordOperators s0 } - f Nothing = Left "System is not linear" - f (Just m) = Right m +parseSystem input = + case foreachLine parseEqExpr input of + Left msg -> Left msg + Right eqs + | all f eqs -> Right eqs + | otherwise -> Left "System is not linear" + where + f (a :==: b) = isLinear a && isLinear b -pSystem :: TokenParser (Maybe (LinearSystem Expr)) -pSystem = convertSystem <$> pEquations pExpr - where - convertSystem :: Equations Expr -> Maybe (LinearSystem Expr) - convertSystem eqs - | all f eqs = return eqs - | otherwise = Nothing - where - f (a :==: b) = isLinear a && isLinear b - ----------------------------------------------------------- --- Parser parseMatrix :: String -> Either String (Matrix Expr) -parseMatrix = either Left f . parseWithM s p - where - s = specialSymbols "\n" scannerExpr - p = pMatrix pFractional - f Nothing = Left "Matrix is not rectangular" - f (Just m) = Right m - -pMatrix :: TokenParser a -> TokenParser (Maybe (Matrix a)) -pMatrix p = make <$> pLines True (pList1 p) - where - make xs = if isRectangular xs then Just (makeMatrix xs) else Nothing +parseMatrix input = + case foreachLine parseExprTuple input of + Left msg -> Left msg + Right xss + | isRectangular xss -> Right (makeMatrix xss) + | otherwise -> Left "Matrix is not rectangular" parseVectorSpace :: String -> Either String (VectorSpace Expr) -parseVectorSpace = parseWithM s p - where - s = specialSymbols "\n" scannerExpr - p = makeVectorSpace <$> pVectors pExpr - -pVectors :: TokenParser a -> TokenParser [Vector a] -pVectors p = pLines True (pVector p) - -pVector :: TokenParser a -> TokenParser (Vector a) -pVector p = fromList <$> myParens (myListSep (pSpec ',') p) +parseVectorSpace input = + case foreachLine parseExprTuple input of + Left msg -> Left msg + Right xss + | sameDimension vs -> Right (makeVectorSpace vs) + | otherwise -> Left "Vectors have different dimensions" + where + vs = map fromList xss -myListSep :: TokenParser a -> TokenParser b -> TokenParser [b] -myListSep sep p = optional ((:) <$> p <*> pList (sep *> p)) [] +nonEmptyLines :: String -> [String] +nonEmptyLines = filter (not . all isSpace) . lines -myParens :: TokenParser a -> TokenParser a -myParens p = pSpec '(' *> p <* pSpec ')' +foreachLine :: (String -> Either String a) -> String -> Either String [a] +foreachLine p input = + case (partitionEithers . map p . nonEmptyLines) input of + (msg:_, _) -> Left msg + ([], as) -> Right as ----------------------------------------------------------- --- Pretty-Printer ppMatrix :: Show a => Matrix a -> String ppMatrix = ppMatrixWith show - + ppMatrixWith :: (a -> String) -> Matrix a -> String -ppMatrixWith f = ppStringMatrix . fmap f - +ppMatrixWith f = ppStringMatrix . fmap f + ppStringMatrix :: Matrix String -> String ppStringMatrix = format . rows where - format m = let ws = foldr (zipWith max . map length) (repeat 0) m + format m = let ws = foldr (zipWith max . map length) (repeat 0) m align i s = take i (s ++ repeat ' ') - in unlines $ map (unwords . zipWith align ws) m + par s = "(" ++ s ++ ")" + in unlines $ map (par . intercalate ", " . zipWith align ws) m diff --git a/src/Domain/LinearAlgebra/Strategies.hs b/src/Domain/LinearAlgebra/Strategies.hs --- a/src/Domain/LinearAlgebra/Strategies.hs +++ b/src/Domain/LinearAlgebra/Strategies.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,42 +9,42 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra.Strategies +module Domain.LinearAlgebra.Strategies ( gaussianElimStrategy, linearSystemStrategy , gramSchmidtStrategy, systemWithMatrixStrategy , forwardPass ) where -import Prelude hiding (repeat) -import Domain.Math.Expr -import Domain.Math.Simplification -import Domain.LinearAlgebra.Matrix -import Domain.LinearAlgebra.MatrixRules +import Common.Context +import Common.Id +import Common.Strategy hiding (not) +import Common.Transformation import Domain.LinearAlgebra.EquationsRules import Domain.LinearAlgebra.GramSchmidtRules import Domain.LinearAlgebra.LinearSystem -import Common.Strategy hiding (not) -import Common.Transformation -import Common.Context -import Common.Id +import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.MatrixRules import Domain.LinearAlgebra.Vector +import Domain.Math.Expr +import Domain.Math.Simplification +import Prelude hiding (repeat) gaussianElimStrategy :: LabeledStrategy (Context (Matrix Expr)) -gaussianElimStrategy = label "Gaussian elimination" $ +gaussianElimStrategy = label "Gaussian elimination" $ forwardPass <*> backwardPass forwardPass :: LabeledStrategy (Context (Matrix Expr)) -forwardPass = label "Forward pass" $ +forwardPass = label "Forward pass" $ simplifyRule <*> - repeat ( label "Find j-th column" ruleFindColumnJ + repeat ( label "Find j-th column" ruleFindColumnJ <*> label "Exchange rows" (try ruleExchangeNonZero) <*> label "Scale row" (try ruleScaleToOne) <*> label "Zeros in j-th column" (repeat ruleZerosFP) <*> label "Cover up top row" ruleCoverRow ) - + backwardPass :: LabeledStrategy (Context (Matrix Expr)) -backwardPass = label "Backward pass" $ +backwardPass = label "Backward pass" $ simplifyRule <*> repeat ( label "Uncover row" ruleUncoverRow <*> label "Sweep" (repeat ruleZerosBP) @@ -61,9 +61,9 @@ ) backSubstitution :: LabeledStrategy (Context (LinearSystem Expr)) -backSubstitution = label "Back substitution" $ +backSubstitution = label "Back substitution" $ ruleIdentifyFreeVariables <*> backSubstitutionSimple - + systemToEchelonWithEEO :: LabeledStrategy (Context (LinearSystem Expr)) systemToEchelonWithEEO = label "System to Echelon Form (EEO)" $ @@ -88,17 +88,17 @@ systemWithMatrixStrategy :: LabeledStrategy (Context Expr) systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $ - repeat (mapRules useC dropEquation) - <*> conv1 - <*> mapRules useC gaussianElimStrategy - <*> conv2 + repeat (mapRules useC dropEquation) + <*> conv1 + <*> mapRules useC gaussianElimStrategy + <*> conv2 <*> repeat (mapRules useC dropEquation) gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr))) gramSchmidtStrategy = label "Gram-Schmidt" $ repeat $ label "Iteration" $ - label "Consider next vector" ruleNext - <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal)) + label "Consider next vector" ruleNext + <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal)) <*> label "Normalize" (try ruleNormalize) varVars :: Var [String] @@ -114,9 +114,9 @@ let (m, vs) = systemToMatrix ls writeVar varVars vs return (toExpr (simplify (m :: Matrix Expr))) - + conv2 :: Rule (Context Expr) -conv2 = describe "Convert matrix to linear system" $ +conv2 = describe "Convert matrix to linear system" $ makeSimpleRule "linearalgebra.linsystem.frommatrix" $ withCM $ \expr -> do vs <- readVar varVars m <- fromExpr expr diff --git a/src/Domain/LinearAlgebra/Vector.hs b/src/Domain/LinearAlgebra/Vector.hs --- a/src/Domain/LinearAlgebra/Vector.hs +++ b/src/Domain/LinearAlgebra/Vector.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.LinearAlgebra.Vector +module Domain.LinearAlgebra.Vector ( Vector, VectorSpace , makeVectorSpace, vectors, sameDimension, gramSchmidt , fromList, toList, liftV, liftV2, showVectorWith @@ -17,12 +17,13 @@ , scale, norm, distance, vectorSum, innerProduct, dimension ) where -import Control.Monad -import Common.Classes import Common.Rewriting +import Control.Applicative +import Control.Monad +import Data.Foldable (Foldable, foldMap) import Data.List +import Data.Traversable (Traversable, sequenceA) import Domain.Math.Simplification -import Domain.Math.Expr.Symbols (openMathSymbol) import Test.QuickCheck import qualified Text.OpenMath.Dictionary.Linalg2 as OM @@ -31,7 +32,7 @@ newtype Vector a = V [a] deriving (Eq, Ord) - + newtype VectorSpace a = VS [Vector a] deriving (Eq, Ord) @@ -41,9 +42,12 @@ instance Functor Vector where fmap f (V xs) = V (map f xs) -instance Switch Vector where - switch (V xs) = liftM V (switch xs) +instance Foldable Vector where + foldMap f (V xs) = foldMap f xs +instance Traversable Vector where + sequenceA (V xs) = V <$> sequenceA xs + instance Show a => Show (Vector a) where show = showVectorWith show @@ -70,7 +74,7 @@ coarbitrary = coarbitrary . toList vectorSymbol :: Symbol -vectorSymbol = openMathSymbol OM.vectorSymbol +vectorSymbol = newSymbol OM.vectorSymbol instance Simplify a => Simplify (Vector a) where simplifyWith opt = fmap (simplifyWith opt) @@ -87,7 +91,7 @@ xs <- fromTerm a guard (sameDimension xs) return (makeVectorSpace xs) - + instance Simplify a => Simplify (VectorSpace a) where simplifyWith opt = fmap (simplifyWith opt) @@ -97,6 +101,7 @@ j <- choose (0, 10 `div` i) xs <- replicateM i (liftM fromList $ replicateM j arbitrary) return $ makeVectorSpace xs + instance CoArbitrary a => CoArbitrary (VectorSpace a) where coarbitrary = coarbitrary . vectors @@ -112,9 +117,9 @@ -- | Checks that all vectors in vector space have same dimension makeVectorSpace :: [Vector a] -> VectorSpace a -makeVectorSpace xs +makeVectorSpace xs | sameDimension xs = VS xs - | otherwise = error "makeVectorSpace: different dimensions" + | otherwise = error "makeVectorSpace: different dimensions" vectors :: VectorSpace a -> [Vector a] vectors (VS xs) = xs @@ -128,7 +133,7 @@ -- Vector operations showVectorWith :: (a -> String) -> Vector a -> String -showVectorWith f (V xs) = "(" ++ concat (intersperse "," (map f xs)) ++ ")" +showVectorWith f (V xs) = "(" ++ intercalate "," (map f xs) ++ ")" toList :: Vector a -> [a] toList (V xs) = xs @@ -165,18 +170,18 @@ orthonormalList :: Floating a => [Vector a] -> Bool orthonormalList xs = all isUnit xs && all (uncurry orthogonal) pairs where - pairs = [ (a, b) | (i, a) <- zip [0::Int ..] xs, (j, b) <- zip [0..] xs, i < j ] + pairs = [ (a, b) | (i, a) <- zip [0::Int ..] xs, (j, b) <- zip [0..] xs, i < j ] -- length of the vector (also called norm) norm :: Floating a => Vector a -> a norm v = sqrt $ innerProduct v v - + distance :: Floating a => Vector a -> Vector a -> a distance v1 v2 = norm (v1 - v2) - + vectorSum :: Num a => Vector a -> a vectorSum = sum . toList - + innerProduct :: Num a => Vector a -> Vector a -> a innerProduct v1 v2 = vectorSum (v1 * v2) diff --git a/src/Domain/Logic.hs b/src/Domain/Logic.hs --- a/src/Domain/Logic.hs +++ b/src/Domain/Logic.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,22 +9,13 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Logic - ( module Domain.Logic.BuggyRules - , module Domain.Logic.Exercises - , module Domain.Logic.Formula - , module Domain.Logic.GeneralizedRules - , module Domain.Logic.Generator - , module Domain.Logic.Parser - , module Domain.Logic.Rules - , module Domain.Logic.Strategies - ) where +module Domain.Logic (module Export) where -import Domain.Logic.BuggyRules hiding (rule, ruleList) -import Domain.Logic.Exercises -import Domain.Logic.Formula -import Domain.Logic.GeneralizedRules -import Domain.Logic.Generator -import Domain.Logic.Parser -import Domain.Logic.Rules hiding (rule, ruleList) -import Domain.Logic.Strategies +import Domain.Logic.BuggyRules as Export +import Domain.Logic.Exercises as Export +import Domain.Logic.Formula as Export +import Domain.Logic.GeneralizedRules as Export +import Domain.Logic.Generator as Export +import Domain.Logic.Parser as Export +import Domain.Logic.Rules as Export +import Domain.Logic.Strategies as Export diff --git a/src/Domain/Logic/BuggyRules.hs b/src/Domain/Logic/BuggyRules.hs --- a/src/Domain/Logic/BuggyRules.hs +++ b/src/Domain/Logic/BuggyRules.hs @@ -1,230 +1,228 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Buggy rules in the logic domain, expressing common misconceptions --- ------------------------------------------------------------------------------ -module Domain.Logic.BuggyRules where - -import Domain.Logic.Formula -import Domain.Logic.Generator() -import Domain.Logic.Rules (makeGroup, logic) -import Common.Id -import Common.Rewriting -import Common.Transformation (Rule, buggyRule) -import qualified Common.Transformation as Rule - --- Collection of all known buggy rules -buggyRules :: [Rule SLogic] -buggyRules = snd $ makeGroup "Common misconceptions" - [ buggyRuleCommImp, buggyRuleAssImp, buggyRuleIdemImp, buggyRuleIdemEqui - , buggyRuleEquivElim1, buggyRuleImplElim2, buggyRuleEquivElim2, buggyRuleEquivElim3 - , buggyRuleImplElim, buggyRuleImplElim1, buggyRuleDeMorgan1, buggyRuleDeMorgan2, buggyRuleDeMorgan3 - , buggyRuleDeMorgan4, buggyRuleDeMorgan5, buggyRuleNotOverImpl, buggyRuleParenth1, buggyRuleParenth2 - , buggyRuleParenth3, buggyRuleAssoc, buggyRuleAbsor - , buggyRuleAndSame, buggyRuleAndCompl, buggyRuleOrSame, buggyRuleOrCompl - , buggyRuleTrueProp, buggyRuleFalseProp, buggyRuleDistr, buggyRuleDistrNot - ] - -rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a -rule = Rule.rule . logic . ( "buggy" # ) - -ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a -ruleList = Rule.ruleList . logic . ( "buggy" # ) - ------------------------------------------------------------------------------ --- Buggy rules - -buggyRuleAndSame :: Rule SLogic -buggyRuleAndSame = buggyRule $ rule "AndSame" $ - \x -> x :&&: x :~> T - -buggyRuleAndCompl :: Rule SLogic -buggyRuleAndCompl = buggyRule $ ruleList "AndCompl" - [ \x -> x :&&: Not x :~> T - , \x -> Not x :&&: x :~> T - , \x -> x :&&: Not x :~> x - , \x -> Not x :&&: x :~> x - ] - -buggyRuleOrSame :: Rule SLogic -buggyRuleOrSame = buggyRule $ rule "OrSame" $ - \x -> x :||: x :~> T - -buggyRuleOrCompl :: Rule SLogic -buggyRuleOrCompl = buggyRule $ ruleList "OrCompl" - [ \x -> x :||: Not x :~> F - , \x -> Not x :||: x :~> F - , \x -> x :||: Not x :~> x - , \x -> Not x :||: x :~> x - ] - -buggyRuleTrueProp :: Rule SLogic -buggyRuleTrueProp = buggyRule $ ruleList "TrueProp" - [ \x -> x :||: T :~> x - , \x -> T :||: x :~> x - , \x -> x :&&: T :~> T - , \x -> T :&&: x :~> T - ] - -buggyRuleFalseProp :: Rule SLogic -buggyRuleFalseProp = buggyRule $ ruleList "FalseProp" - [ \x -> x :||: F :~> F - , \x -> F :||: x :~> F - , \x -> x :&&: F :~> x - , \x -> F :&&: x :~> x - ] - -buggyRuleCommImp :: Rule SLogic -buggyRuleCommImp = buggyRule $ rule "CommImp" $ - \x y -> x :->: y :~> y :->: x --this does not hold: T->T => T->x - -buggyRuleAssImp :: Rule SLogic -buggyRuleAssImp = buggyRule $ ruleList "AssImp" - [ \x y z -> x :->: (y :->: z) :~> (x :->: y) :->: z - , \x y z -> (x :->: y) :->: z :~> x :->: (y :->: z) - ] - -buggyRuleIdemImp :: Rule SLogic -buggyRuleIdemImp = buggyRule $ rule "IdemImp" $ - \x -> x :->: x :~> x - -buggyRuleIdemEqui :: Rule SLogic -buggyRuleIdemEqui = buggyRule $ rule "IdemEqui" $ - \x -> x :<->: x :~> x - -buggyRuleEquivElim1 :: Rule SLogic -buggyRuleEquivElim1 = buggyRule $ ruleList "EquivElim1" - [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y) - , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&: y) - , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y) - , \x y -> x :<->: y :~> (x :&&: y) :||: (x :&&: y) - , \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :||: Not y) - ] - -buggyRuleEquivElim2 :: Rule SLogic -buggyRuleEquivElim2 = buggyRule $ ruleList "EquivElim2" - [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y) - , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y) - , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y) - ] - -buggyRuleEquivElim3 :: Rule SLogic -buggyRuleEquivElim3 = buggyRule $ rule "EquivElim3" $ - \x y -> x :<->: y :~> Not x :||: y - -buggyRuleImplElim :: Rule SLogic -buggyRuleImplElim = buggyRule $ ruleList "ImplElim" - [\x y -> x :->: y :~> Not (x :||: y) - ,\x y -> x :->: y :~> (x :||: y) - ,\x y -> x :->: y :~> Not (x :&&: y) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Buggy rules in the logic domain, expressing common misconceptions +-- +----------------------------------------------------------------------------- +module Domain.Logic.BuggyRules (buggyRules) where + +import Common.Id +import Common.Rewriting +import Common.Transformation (Rule, buggyRule) +import Domain.Logic.Formula +import Domain.Logic.Generator() +import qualified Common.Transformation as Rule + +-- Collection of all known buggy rules +buggyRules :: [Rule SLogic] +buggyRules = + [ buggyRuleCommImp, buggyRuleAssImp, buggyRuleIdemImp, buggyRuleIdemEqui + , buggyRuleEquivElim1, buggyRuleImplElim2, buggyRuleEquivElim2, buggyRuleEquivElim3 + , buggyRuleImplElim, buggyRuleImplElim1, buggyRuleDeMorgan1, buggyRuleDeMorgan2, buggyRuleDeMorgan3 + , buggyRuleDeMorgan4, buggyRuleDeMorgan5, buggyRuleNotOverImpl, buggyRuleParenth1, buggyRuleParenth2 + , buggyRuleParenth3, buggyRuleAssoc, buggyRuleAbsor + , buggyRuleAndSame, buggyRuleAndCompl, buggyRuleOrSame, buggyRuleOrCompl + , buggyRuleTrueProp, buggyRuleFalseProp, buggyRuleDistr, buggyRuleDistrNot + ] + +rule :: RuleBuilder f a => String -> f -> Rule a +rule = Rule.rule . ( "logic.propositional.buggy" # ) + +ruleList :: RuleBuilder f a => String -> [f] -> Rule a +ruleList = Rule.ruleList . ( "logic.propositional.buggy" # ) + +----------------------------------------------------------------------------- +-- Buggy rules + +buggyRuleAndSame :: Rule SLogic +buggyRuleAndSame = buggyRule $ rule "AndSame" $ + \x -> x :&&: x :~> T + +buggyRuleAndCompl :: Rule SLogic +buggyRuleAndCompl = buggyRule $ ruleList "AndCompl" + [ \x -> x :&&: Not x :~> T + , \x -> Not x :&&: x :~> T + , \x -> x :&&: Not x :~> x + , \x -> Not x :&&: x :~> x + ] + +buggyRuleOrSame :: Rule SLogic +buggyRuleOrSame = buggyRule $ rule "OrSame" $ + \x -> x :||: x :~> T + +buggyRuleOrCompl :: Rule SLogic +buggyRuleOrCompl = buggyRule $ ruleList "OrCompl" + [ \x -> x :||: Not x :~> F + , \x -> Not x :||: x :~> F + , \x -> x :||: Not x :~> x + , \x -> Not x :||: x :~> x + ] + +buggyRuleTrueProp :: Rule SLogic +buggyRuleTrueProp = buggyRule $ ruleList "TrueProp" + [ \x -> x :||: T :~> x + , \x -> T :||: x :~> x + , \x -> x :&&: T :~> T + , \x -> T :&&: x :~> T + ] + +buggyRuleFalseProp :: Rule SLogic +buggyRuleFalseProp = buggyRule $ ruleList "FalseProp" + [ \x -> x :||: F :~> F + , \x -> F :||: x :~> F + , \x -> x :&&: F :~> x + , \x -> F :&&: x :~> x + ] + +buggyRuleCommImp :: Rule SLogic +buggyRuleCommImp = buggyRule $ rule "CommImp" $ + \x y -> x :->: y :~> y :->: x --this does not hold: T->T => T->x + +buggyRuleAssImp :: Rule SLogic +buggyRuleAssImp = buggyRule $ ruleList "AssImp" + [ \x y z -> x :->: (y :->: z) :~> (x :->: y) :->: z + , \x y z -> (x :->: y) :->: z :~> x :->: (y :->: z) + ] + +buggyRuleIdemImp :: Rule SLogic +buggyRuleIdemImp = buggyRule $ rule "IdemImp" $ + \x -> x :->: x :~> x + +buggyRuleIdemEqui :: Rule SLogic +buggyRuleIdemEqui = buggyRule $ rule "IdemEqui" $ + \x -> x :<->: x :~> x + +buggyRuleEquivElim1 :: Rule SLogic +buggyRuleEquivElim1 = buggyRule $ ruleList "EquivElim1" + [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y) + , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&: y) + , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y) + , \x y -> x :<->: y :~> (x :&&: y) :||: (x :&&: y) + , \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :||: Not y) + ] + +buggyRuleEquivElim2 :: Rule SLogic +buggyRuleEquivElim2 = buggyRule $ ruleList "EquivElim2" + [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y) + , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y) + , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y) + ] + +buggyRuleEquivElim3 :: Rule SLogic +buggyRuleEquivElim3 = buggyRule $ rule "EquivElim3" $ + \x y -> x :<->: y :~> Not x :||: y + +buggyRuleImplElim :: Rule SLogic +buggyRuleImplElim = buggyRule $ ruleList "ImplElim" + [\x y -> x :->: y :~> Not (x :||: y) + ,\x y -> x :->: y :~> (x :||: y) + ,\x y -> x :->: y :~> Not (x :&&: y) + ] + +buggyRuleImplElim1 :: Rule SLogic +buggyRuleImplElim1 = buggyRule $ rule "ImplElim1" $ + \x y -> x :->: y :~> Not x :&&: y + +buggyRuleImplElim2 :: Rule SLogic +buggyRuleImplElim2 = buggyRule $ rule "ImplElim2" $ + \x y -> x :->: y :~> (x :&&: y) :||: (Not x :&&: Not y) + +buggyRuleDeMorgan1 :: Rule SLogic +buggyRuleDeMorgan1 = buggyRule $ ruleList "DeMorgan1" + [ \x y -> Not (x :&&: y) :~> Not x :||: y + , \x y -> Not (x :&&: y) :~> x :||: Not y + , \x y -> Not (x :&&: y) :~> x :||: y + , \x y -> Not (x :||: y) :~> Not x :&&: y + , \x y -> Not (x :||: y) :~> x :&&: Not y + , \x y -> Not (x :||: y) :~> x :&&: y + ] + +buggyRuleDeMorgan2 :: Rule SLogic +buggyRuleDeMorgan2 = buggyRule $ ruleList "DeMorgan2" + [ \x y -> Not (x :&&: y) :~> Not (Not x :||: Not y) + , \x y -> Not (x :||: y) :~> Not (Not x :&&: Not y) --note the firstNot in both formulas! + ] +buggyRuleDeMorgan3 :: Rule SLogic +buggyRuleDeMorgan3 = buggyRule $ rule "DeMorgan3" $ + \x y -> Not (x :&&: y) :~> Not x :&&: Not y + +buggyRuleDeMorgan4 :: Rule SLogic +buggyRuleDeMorgan4 = buggyRule $ rule "DeMorgan4" $ + \x y -> Not (x :||: y) :~> Not x :||: Not y + +buggyRuleDeMorgan5 :: Rule SLogic +buggyRuleDeMorgan5 = buggyRule $ ruleList "DeMorgan5" + [ \x y z -> Not (Not (x :&&: y) :||: z) :~> Not (Not x :||: Not y):||: z + , \x y z -> Not (Not (x :&&: y) :&&: z) :~> Not (Not x :||: Not y):&&: z + , \x y z -> Not (Not (x :||: y) :||: z) :~> Not (Not x :&&: Not y):||: z + , \x y z -> Not (Not (x :||: y) :&&: z) :~> Not (Not x :&&: Not y):&&: z + ] + +buggyRuleNotOverImpl :: Rule SLogic +buggyRuleNotOverImpl = buggyRule $ rule "NotOverImpl" $ + \x y -> Not (x :->: y) :~> Not x :->: Not y + +buggyRuleParenth1 :: Rule SLogic +buggyRuleParenth1 = buggyRule $ ruleList "Parenth1" + [ \x y -> Not (x :&&: y) :~> Not x :&&: y + , \x y -> Not (x :||: y) :~> Not x :||: y + ] + +buggyRuleParenth2 :: Rule SLogic +buggyRuleParenth2 = buggyRule $ rule "Parenth2" $ + \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y) + +buggyRuleParenth3 :: Rule SLogic +buggyRuleParenth3 = buggyRule $ ruleList "Parenth3" + [ \x y -> Not (Not x :&&: y) :~> x :&&: y + , \x y -> Not (Not x :||: y) :~> x :||: y + , \x y -> Not (Not x :->: y) :~> x :->: y + , \x y -> Not (Not x :<->: y) :~> x :<->: y + ] + +buggyRuleAssoc :: Rule SLogic +buggyRuleAssoc = buggyRule $ ruleList "Assoc" + [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z + , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z) + , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z) + , \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: z + ] + +buggyRuleAbsor :: Rule SLogic +buggyRuleAbsor = buggyRule $ ruleList "Absor" + [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y) + , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y) + , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y) + , \x y z -> (x :&&: y) :&&: ((x :||: y) :||: z) :~> (x :&&: y) + ] + +buggyRuleDistr :: Rule SLogic +buggyRuleDistr = buggyRule $ ruleList "Distr" + [ \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :&&: (x :&&: z) + , \x y z -> (x :||: y) :&&: z :~> (x :&&: z) :&&: (y :&&: z) + , \x y z -> x :&&: (y :||: z) :~> (x :||: y) :&&: (x :||: z) + , \x y z -> (x :||: y) :&&: z :~> (x :||: z) :&&: (y :||: z) + , \x y z -> x :||: (y :&&: z) :~> (x :||: y) :||: (x :||: z) + , \x y z -> (x :&&: y) :||: z :~> (x :||: z) :||: (y :||: z) + , \x y z -> x :||: (y :&&: z) :~> (x :&&: y) :||: (x :&&: z) + , \x y z -> (x :&&: y) :||: z :~> (x :&&: z) :||: (y :&&: z) + ] + +buggyRuleDistrNot :: Rule SLogic +buggyRuleDistrNot = buggyRule $ ruleList "DistrNot" + [ \x y z -> Not x :&&: (y :||: z) :~> (Not x :&&: y) :||: (x :&&: z) + , \x y z -> Not x :&&: (y :||: z) :~> (x :&&: y) :||: (Not x :&&: z) + , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: Not z) :||: (y :&&: z) + , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: z) :||: (y :&&: Not z) + , \x y z -> Not x :||: (y :&&: z) :~> (Not x :||: y) :&&: (x :||: z) + , \x y z -> Not x :||: (y :&&: z) :~> (x :||: y) :&&: (Not x :||: z) + , \x y z -> (x :&&: y) :||: Not z :~> (x :||: Not z) :&&: (y :||: z) + , \x y z -> (x :&&: y) :||: Not z :~> (x :||: z) :&&: (y :||: Not z) ] - -buggyRuleImplElim1 :: Rule SLogic -buggyRuleImplElim1 = buggyRule $ rule "ImplElim1" $ - \x y -> x :->: y :~> Not x :&&: y - -buggyRuleImplElim2 :: Rule SLogic -buggyRuleImplElim2 = buggyRule $ rule "ImplElim2" $ - \x y -> x :->: y :~> (x :&&: y) :||: (Not x :&&: Not y) - -buggyRuleDeMorgan1 :: Rule SLogic -buggyRuleDeMorgan1 = buggyRule $ ruleList "DeMorgan1" - [ \x y -> Not (x :&&: y) :~> Not x :||: y - , \x y -> Not (x :&&: y) :~> x :||: Not y - , \x y -> Not (x :&&: y) :~> x :||: y - , \x y -> Not (x :||: y) :~> Not x :&&: y - , \x y -> Not (x :||: y) :~> x :&&: Not y - , \x y -> Not (x :||: y) :~> x :&&: y - ] - -buggyRuleDeMorgan2 :: Rule SLogic -buggyRuleDeMorgan2 = buggyRule $ ruleList "DeMorgan2" - [ \x y -> Not (x :&&: y) :~> Not (Not x :||: Not y) - , \x y -> Not (x :||: y) :~> Not (Not x :&&: Not y) --note the firstNot in both formulas! - ] -buggyRuleDeMorgan3 :: Rule SLogic -buggyRuleDeMorgan3 = buggyRule $ rule "DeMorgan3" $ - \x y -> Not (x :&&: y) :~> Not x :&&: Not y - -buggyRuleDeMorgan4 :: Rule SLogic -buggyRuleDeMorgan4 = buggyRule $ rule "DeMorgan4" $ - \x y -> Not (x :||: y) :~> Not x :||: Not y - -buggyRuleDeMorgan5 :: Rule SLogic -buggyRuleDeMorgan5 = buggyRule $ ruleList "DeMorgan5" - [ \x y z -> Not (Not (x :&&: y) :||: z) :~> Not (Not x :||: Not y):||: z - , \x y z -> Not (Not (x :&&: y) :&&: z) :~> Not (Not x :||: Not y):&&: z - , \x y z -> Not (Not (x :||: y) :||: z) :~> Not (Not x :&&: Not y):||: z - , \x y z -> Not (Not (x :||: y) :&&: z) :~> Not (Not x :&&: Not y):&&: z - ] - -buggyRuleNotOverImpl :: Rule SLogic -buggyRuleNotOverImpl = buggyRule $ rule "NotOverImpl" $ - \x y -> Not (x :->: y) :~> Not x :->: Not y - -buggyRuleParenth1 :: Rule SLogic -buggyRuleParenth1 = buggyRule $ ruleList "Parenth1" - [ \x y -> Not (x :&&: y) :~> Not x :&&: y - , \x y -> Not (x :||: y) :~> Not x :||: y - ] - -buggyRuleParenth2 :: Rule SLogic -buggyRuleParenth2 = buggyRule $ rule "Parenth2" $ - \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y) - -buggyRuleParenth3 :: Rule SLogic -buggyRuleParenth3 = buggyRule $ ruleList "Parenth3" - [ \x y -> Not (Not x :&&: y) :~> x :&&: y - , \x y -> Not (Not x :||: y) :~> x :||: y - , \x y -> Not (Not x :->: y) :~> x :->: y - , \x y -> Not (Not x :<->: y) :~> x :<->: y - ] - - -buggyRuleAssoc :: Rule SLogic -buggyRuleAssoc = buggyRule $ ruleList "Assoc" - [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z - , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z) - , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z) - , \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: z - ] - -buggyRuleAbsor :: Rule SLogic -buggyRuleAbsor = buggyRule $ ruleList "Absor" - [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y) - , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y) - , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y) - , \x y z -> (x :&&: y) :&&: ((x :||: y) :||: z) :~> (x :&&: y) - ] - -buggyRuleDistr :: Rule SLogic -buggyRuleDistr = buggyRule $ ruleList "Distr" - [ \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :&&: (x :&&: z) - , \x y z -> (x :||: y) :&&: z :~> (x :&&: z) :&&: (y :&&: z) - , \x y z -> x :&&: (y :||: z) :~> (x :||: y) :&&: (x :||: z) - , \x y z -> (x :||: y) :&&: z :~> (x :||: z) :&&: (y :||: z) - , \x y z -> x :||: (y :&&: z) :~> (x :||: y) :||: (x :||: z) - , \x y z -> (x :&&: y) :||: z :~> (x :||: z) :||: (y :||: z) - , \x y z -> x :||: (y :&&: z) :~> (x :&&: y) :||: (x :&&: z) - , \x y z -> (x :&&: y) :||: z :~> (x :&&: z) :||: (y :&&: z) - ] - -buggyRuleDistrNot :: Rule SLogic -buggyRuleDistrNot = buggyRule $ ruleList "DistrNot" - [ \x y z -> Not x :&&: (y :||: z) :~> (Not x :&&: y) :||: (x :&&: z) - , \x y z -> Not x :&&: (y :||: z) :~> (x :&&: y) :||: (Not x :&&: z) - , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: Not z) :||: (y :&&: z) - , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: z) :||: (y :&&: Not z) - , \x y z -> Not x :||: (y :&&: z) :~> (Not x :||: y) :&&: (x :||: z) - , \x y z -> Not x :||: (y :&&: z) :~> (x :||: y) :&&: (Not x :||: z) - , \x y z -> (x :&&: y) :||: Not z :~> (x :||: Not z) :&&: (y :||: z) - , \x y z -> (x :&&: y) :||: Not z :~> (x :||: z) :&&: (y :||: Not z) - ] diff --git a/src/Domain/Logic/Examples.hs b/src/Domain/Logic/Examples.hs --- a/src/Domain/Logic/Examples.hs +++ b/src/Domain/Logic/Examples.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,17 +11,12 @@ -- A set of example proofs -- ----------------------------------------------------------------------------- -module Domain.Logic.Examples +module Domain.Logic.Examples ( exampleProofs ) where - -import Domain.Logic.Formula import Common.Utils (ShowString(..)) - - - - +import Domain.Logic.Formula exampleProofs :: [(SLogic, SLogic)] exampleProofs = [(Not(p :||: (Not p :&&: q)), Not(p :||: q)), @@ -38,12 +33,9 @@ ((p :->: q):->: (p :->: s), (Not q :->: Not p) :->: (Not s :->: Not p)), (Not((p :->:q) :->: (p:&&:q)), (p :->: q) :&&: (Not p :||: Not q)), (Not((p :<->: q) :->: (p :||: (p :<->: q))), F)] - + where p = Var (ShowString "p") q = Var (ShowString "q") s = Var (ShowString "s") - r = Var (ShowString "r") - - - + r = Var (ShowString "r") diff --git a/src/Domain/Logic/Exercises.hs b/src/Domain/Logic/Exercises.hs --- a/src/Domain/Logic/Exercises.hs +++ b/src/Domain/Logic/Exercises.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -8,20 +8,15 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Exercise for the logic domain, used for the OUNL course +-- Exercise for the logic domain, used for the OUNL course -- "Discrete Wiskunde A (DWA)" -- ----------------------------------------------------------------------------- -module Domain.Logic.Exercises +module Domain.Logic.Exercises ( dnfExercise, dnfUnicodeExercise ) where -import Common.Context -import Common.Derivation -import Common.Exercise -import Common.Navigator -import Common.Rewriting (differenceMode) -import Common.Strategy +import Common.Library import Data.Maybe import Domain.Logic.BuggyRules import Domain.Logic.Formula @@ -39,15 +34,14 @@ , status = Stable , parser = parseLogicPars , prettyPrinter = ppLogicPars - , equivalence = eqLogic - , similarity = equalLogicA - , isReady = isDNF - , isSuitable = suitable - , extraRules = map liftToContext (logicRules ++ buggyRules) + , equivalence = withoutContext eqLogic + , similarity = withoutContext equalLogicA + , ready = predicate isDNF + , suitable = predicate mySuitable + , extraRules = map liftToContext (extraLogicRules ++ buggyRules) , strategy = dnfStrategyDWA , navigation = navigator - , difference = differenceMode eqLogic - , testGenerator = Just (restrictGenerator suitable arbitrary) + , testGenerator = Just (restrictGenerator mySuitable arbitrary) , randomExercise = useGenerator (const True) logicExercise } @@ -60,33 +54,30 @@ , prettyPrinter = ppLogicUnicodePars } -logicExercise :: Int -> Gen SLogic -logicExercise n = - let (gen, (minStep, maxStep)) - | n == 1 = generateLevel Easy - | n == 3 = generateLevel Difficult - | otherwise = generateLevel Normal +logicExercise :: Difficulty -> Gen SLogic +logicExercise dif = + let (gen, (minStep, maxStep)) = generateLevel dif ok p = let i = fromMaybe maxBound (stepsRemaining maxStep p) in countEquivalences p <= 2 && i >= minStep && i <= maxStep in restrictGenerator ok gen -suitable :: SLogic -> Bool -suitable = (<=2) . countEquivalences +mySuitable :: SLogic -> Bool +mySuitable = (<=2) . countEquivalences stepsRemaining :: Int -> SLogic -> Maybe Int -stepsRemaining i = +stepsRemaining i = lengthMax i . derivationTree dnfStrategyDWA . inContext dnfExercise --- QuickCheck property to monitor the number of steps needed +-- QuickCheck property to monitor the number of steps needed -- to normalize a random proposition (30-40% is ok) {- testGen :: Property -testGen = forAll generateLogic $ \p -> +testGen = forAll generateLogic $ \p -> let n = steps p in countEquivalences p <= 2 ==> label (show (n >= 4 && n <= 12)) True - + testme :: IO () -testme = quickCheck testGen +testme = quickCheck testGen start = ((r :<->: p) :||: (q :->: s)) :&&: (Not s :<->: (p :||: r)) where diff --git a/src/Domain/Logic/FeedbackText.hs b/src/Domain/Logic/FeedbackText.hs deleted file mode 100644 --- a/src/Domain/Logic/FeedbackText.hs +++ /dev/null @@ -1,172 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Feedback messages reported for the logic domain. Content to be provided --- by Josje Lodder. --- ------------------------------------------------------------------------------ -module Domain.Logic.FeedbackText where - -import Data.List -import Data.Maybe -import Common.Id -import Common.Transformation -import Domain.Logic.Rules -import Domain.Logic.BuggyRules - -feedbackSyntaxError :: String -> String -feedbackSyntaxError msg - | "(" `isPrefixOf` msg = "Syntax error at " ++ msg - | "Syntax error" `isPrefixOf` msg = msg - | otherwise = "Syntax error: " ++ msg - -feedbackBuggy :: Bool -> [Rule a] -> String -feedbackBuggy ready [br] - | br ~= buggyRuleCommImp = - f "Did you think that implication is commutative? This is not the case. " - | br ~= buggyRuleAssImp = - f "Did you think that implication is associative? This is not the case. " - | br ~= buggyRuleImplElim2 = - f "Make sure that you use the rule for implication elimanation, you seemed to use equivalence elimination " - | br ~= buggyRuleEquivElim3 = - f "Make sure that you use the rule for equivalence elimanation, you seemed to use implication elimination " - | br ~= buggyRuleIdemImp = - f "Did you think that implication is idempotent? This is not the case. " - | br ~= buggyRuleIdemEqui = - f "Did you think that equivalence is idempotent? This is not the case. " - | br ~= buggyRuleAndSame = - f "Did you think that phi AND phi is equivalent to True? This is not the case. Idempotency of AND means that phi AND phi is equivalent to phi. " - | br ~= buggyRuleOrSame = - f "Did you think that phi OR phi is equivalent to True? This is not the case. Idempotency of OR means that phi OR phi is equivalent to phi. " - | br ~= buggyRuleAndCompl = - f "Be careful in the application of the the complement-rules " - | br ~= buggyRuleOrCompl = - f "Be careful in the application of the the complement-rules " - | br ~= buggyRuleTrueProp = - f "Be careful in the application of the the True-False rules " - | br ~= buggyRuleFalseProp = - f "Be careful in the application of the the True-False rules " - | br ~= buggyRuleEquivElim1 = - f "Be careful with the elimination of an equivalence; take care of the negations. " - | br ~= buggyRuleEquivElim2 = - f "Be careful with the elimination of an equivalence; make sure that the disjunctions and the conjunctions are at the right place. " - | br ~= buggyRuleImplElim = - f "Be careful with the elimination of an implication; make sure the negation is at the right place. " - | br ~= buggyRuleImplElim1 = - f "Did you try to eliminate an implication? In that case you used an AND instead of an OR " - | br ~= buggyRuleDeMorgan1 = - f "Did you try to apply DeMorgan? Be careful with the negations. " - | br ~= buggyRuleDeMorgan2 = - f "Did you try to apply DeMorgan? Make sure that you remove the outer negation when applying this rule " - | br ~= buggyRuleDeMorgan3 = - f "Did you try to apply DeMorgan? Make sure that you replace AND by OR. " - | br ~= buggyRuleDeMorgan4 = - f "Did you try to apply DeMorgan? Make sure that you replace OR by AND. " - | br ~= buggyRuleDeMorgan5 = - f "Did you try to apply DeMorgan? Take care of the scope of the negations. " - | br ~= buggyRuleNotOverImpl = - f "Did you think that you can distribute a negation over an implication? This is not the case. " - | br ~= buggyRuleParenth1 = - f "Take care of the negations and the parentheses. " - | br ~= buggyRuleParenth2 = - f "Take care of the outer negation when you eliminate an equivalence. " - | br ~= buggyRuleParenth3 = - f "Did you try to apply double negation? At this place this is not allowed, because of the parenthesis between the negations. " - | br ~= buggyRuleAssoc = - f "Did you change the parentheses? This is not allowed in a subformula consisting of a disjunction and a conjunction. " - | br ~= buggyRuleAbsor = - f "Did you try to apply absorption? You cant't apply this rule at this place since the resulting sub formula is not a subformula of the bigger term. " - | br ~= buggyRuleDistr = - f "Did you try to apply distribution? Take care of the place of the disjunctions and the conjunctions. " - | br ~= buggyRuleDistrNot = - f "Did you try to apply distribution? Don't forget the negations!. " - where f = incorrect ready -feedbackBuggy ready _ = incorrect ready "" - -feedbackNotEquivalent :: Bool -> String -feedbackNotEquivalent ready = incorrect ready "" - -feedbackSame :: String -feedbackSame = "You have submitted a similar term. " ++ - "Maybe you inserted or removed parentheses (the tool supports associativity)?" - -feedbackOk :: [Rule a] -> (String, Bool) -feedbackOk [one] = (okay (appliedRule one), True) -feedbackOk _ = ("You have combined multiple steps. Press the Back button and perform one step at the time.", False) - --- TODO Bastiaan: welke regel wordt er dan verwacht door de strategie? -feedbackDetour :: Bool -> Maybe (Rule a) -> [Rule a] -> (String, Bool) -feedbackDetour True _ [one] = (appliedRule one ++ " " ++ feedbackFinished, True) -feedbackDetour True _ _ = (feedbackMultipleSteps ++ " " ++ feedbackFinished, True) -feedbackDetour _ _ [one] | one `inGroup` groupCommutativity = - ("You have applied one of the commutativity rules correctly. This step is not mandatory, but sometimes helps to simplify the formula.", True) -feedbackDetour _ mexp [one] = - let however = case mexp >>= ruleText of - Just s -> "However, the standard strategy suggests to use " ++ s ++ "." - Nothing -> "However, the standard strategy suggests a different step." - in (appliedRule one ++ " This is correct. " ++ however, True) -feedbackDetour ready _ _ = (feedbackUnknown ready, False) - -feedbackUnknown :: Bool -> String -feedbackUnknown ready = feedbackMultipleSteps ++ " " ++ backAndHint ready - -feedbackMultipleSteps :: String -feedbackMultipleSteps = "You have combined multiple steps (or made a mistake)." - -feedbackFinished :: String -feedbackFinished = "Are you aware that you already reached disjunctive normal form?" - -appliedRule :: Rule a -> String -appliedRule r = "You have applied " ++ txt ++ " correctly." - where txt = fromMaybe "some rule" (ruleText r) - -ruleText :: Rule a -> Maybe String -ruleText r - | r ~= ruleFalseZeroOr || r ~= ruleTrueZeroOr || r ~= ruleFalseZeroAnd || r ~= ruleTrueZeroAnd || r ~= ruleNotTrue || r ~= ruleNotFalse = - return "one of the False/True rules" - | r ~= ruleComplOr || r ~= ruleComplAnd = return "a complement rule" - | r ~= ruleNotNot = return "double negation" - | r ~= ruleDefImpl = return "implication elimination" - | r ~= ruleDefEquiv = return "equivalence elimination" - | r `inGroup` groupCommutativity = return "commutativity" - | r `inGroup` groupAssociativity = return "associativity" - | r `inGroup` groupDistributionOrOverAnd = return "distribution of or over and" - | r `inGroup` groupDistributionAndOverOr = return "distribution of and over or" - | r `inGroup` groupIdempotency = return "idempotency" - | r `inGroup` groupAbsorption = return "absorption" - | r `inGroup` groupDeMorgan = return "De Morgan" - | r `inGroup` groupInverseDeMorgan = return "De Morgan" - | r `inGroup` groupInverseDistr = return "distributivity" - -- TODO Josje: aanvullen met alle regels (ook die ook in de DWA strategie voorkomen) - | otherwise = Nothing -------------------------------------------------------------------------- --- General text - -incorrect :: Bool -> String -> String -incorrect ready s = "This is incorrect. " ++ s ++ backAndHint ready - -okay :: String -> String -okay s = "Well done! " ++ s - -backAndHint :: Bool -> String -backAndHint ready = "Press the Back button and try again." ++ - if ready then "" else " You may ask for a hint." - -------------------------------------------------------------------------- --- Helper functions - -(~=) :: Rule a -> Rule b -> Bool -r1 ~= r2 = getId r1 == getId r2 - --- Quick and dirty fix! -inGroup :: Rule a -> (Id, b) -> Bool -inGroup r n = - let rs = filter (~= r) (logicRules ++ buggyRules) - in fst n `elem` concatMap ruleGroups rs diff --git a/src/Domain/Logic/Formula.hs b/src/Domain/Logic/Formula.hs --- a/src/Domain/Logic/Formula.hs +++ b/src/Domain/Logic/Formula.hs @@ -1,231 +1,208 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Logic.Formula where - -import Common.Classes -import Common.Id -import Common.Rewriting -import Common.Uniplate (Uniplate(..), universe) -import Common.Utils (ShowString, subsets) -import Common.View -import Control.Monad -import Data.List -import Data.Maybe -import Domain.Math.Expr.Symbols (openMathSymbol) -import qualified Text.OpenMath.Dictionary.Logic1 as OM - -infixr 2 :<->: -infixr 3 :->: -infixr 4 :||: -infixr 5 :&&: - --- | The data type Logic is the abstract syntax for the domain --- | of logic expressions. -data Logic a = Var a - | Logic a :->: Logic a -- implication - | Logic a :<->: Logic a -- equivalence - | Logic a :&&: Logic a -- and (conjunction) - | Logic a :||: Logic a -- or (disjunction) - | Not (Logic a) -- not - | T -- true - | F -- false - deriving (Eq, Ord) - --- | For simple use, we assume the variables to be strings -type SLogic = Logic ShowString - -instance Show a => Show (Logic a) where - show = ppLogic - -instance Functor Logic where - fmap f = foldLogic (Var . f, (:->:), (:<->:), (:&&:), (:||:), Not, T, F) - -instance Crush Logic where - crush p = [ x | Var x <- universe p ] - -instance Switch Logic where - switch = foldLogic - ( liftM Var, liftM2 (:->:), liftM2 (:<->:), liftM2 (:&&:) - , liftM2 (:||:), liftM Not, return T, return F - ) - --- | The type LogicAlg is the algebra for the data type Logic --- | Used in the fold for Logic. -type LogicAlg b a = (b -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a, a) - --- | foldLogic is the standard fold for Logic. -foldLogic :: LogicAlg b a -> Logic b -> a -foldLogic (var, impl, equiv, conj, disj, neg, true, false) = rec - where - rec logic = - case logic of - Var x -> var x - p :->: q -> rec p `impl` rec q - p :<->: q -> rec p `equiv` rec q - p :&&: q -> rec p `conj` rec q - p :||: q -> rec p `disj` rec q - Not p -> neg (rec p) - T -> true - F -> false - --- | Pretty-printer for propositions -ppLogic :: Show a => Logic a -> String -ppLogic = ppLogicPrio 0 - -ppLogicPrio :: Show a => Int -> Logic a -> String -ppLogicPrio = (\f s -> f s "") . flip (foldLogic alg) - where - alg = ( pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\" - , binop 1 "||", nott, pp "T", pp "F") - binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio) - pp s = const (s++) - nott p _ = ("~"++) . p 4 - parIf b f = if b then ("("++) . f . (")"++) else f - --- | The monadic join for logic -catLogic :: Logic (Logic a) -> Logic a -catLogic = foldLogic (id, (:->:), (:<->:), (:&&:), (:||:), Not, T, F) - --- | evalLogic takes a function that gives a logic value to a variable, --- | and a Logic expression, and evaluates the boolean expression. -evalLogic :: (a -> Bool) -> Logic a -> Bool -evalLogic env = foldLogic (env, impl, (==), (&&), (||), not, True, False) - where - impl p q = not p || q - --- | eqLogic determines whether or not two Logic expression are logically --- | equal, by evaluating the logic expressions on all valuations. -eqLogic :: Eq a => Logic a -> Logic a -> Bool -eqLogic p q = all (\f -> evalLogic f p == evalLogic f q) fs - where - xs = varsLogic p `union` varsLogic q - fs = map (flip elem) (subsets xs) - --- | A Logic expression is atomic if it is a variable or a constant True or False. -isAtomic :: Logic a -> Bool -isAtomic logic = - case logic of - Var _ -> True - Not (Var _) -> True - T -> True - F -> True - _ -> False - --- | Functions isDNF, and isCNF determine whether or not a Logix expression --- | is in disjunctive normal form, or conjunctive normal form, respectively. -isDNF, isCNF :: Logic a -> Bool -isDNF = all isAtomic . concatMap conjunctions . disjunctions -isCNF = all isAtomic . concatMap disjunctions . conjunctions - --- | Function disjunctions returns all Logic expressions separated by an or --- | operator at the top level. -disjunctions :: Logic a -> [Logic a] -disjunctions p = fromMaybe [p] $ match (magmaListView orMonoid) p - --- | Function conjunctions returns all Logic expressions separated by an and --- | operator at the top level. -conjunctions :: Logic a -> [Logic a] -conjunctions p = fromMaybe [p] $ match (magmaListView andMonoid) p - --- | Count the number of equivalences -countEquivalences :: Logic a -> Int -countEquivalences p = length [ () | _ :<->: _ <- universe p ] - --- | Function varsLogic returns the variables that appear in a Logic expression. -varsLogic :: Eq a => Logic a -> [a] -varsLogic p = nub [ s | Var s <- universe p ] - -instance Uniplate (Logic a) where - uniplate this = - case this of - p :->: q -> ([p, q], \[a, b] -> a :->: b) - p :<->: q -> ([p, q], \[a, b] -> a :<->: b) - p :&&: q -> ([p, q], \[a, b] -> a :&&: b) - p :||: q -> ([p, q], \[a, b] -> a :||: b) - Not p -> ([p], \[a] -> Not a) - _ -> ([], \[] -> this) - -instance Different (Logic a) where - different = (T, F) - -instance IsTerm a => IsTerm (Logic a) where - toTerm = foldLogic - ( toTerm, binary impliesSymbol, binary equivalentSymbol - , binary andSymbol, binary orSymbol, unary notSymbol - , symbol trueSymbol, symbol falseSymbol - ) - - fromTerm a = - fromTermWith f a `mplus` liftM Var (fromTerm a) - where - f s [] - | s == trueSymbol = return T - | s == falseSymbol = return F - f s [x] - | s == notSymbol = return (Not x) - f s [x, y] - | s == impliesSymbol = return (x :->: y) - | s == equivalentSymbol = return (x :<->: y) - f s xs@(_:_) - | s == andSymbol = return (foldr1 (:&&:) xs) - | s == orSymbol = return (foldr1 (:||:) xs) - f _ _ = fail "fromTerm" - -trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol, - andSymbol, orSymbol :: Symbol - -trueSymbol = openMathSymbol OM.trueSymbol -falseSymbol = openMathSymbol OM.falseSymbol -notSymbol = openMathSymbol OM.notSymbol -impliesSymbol = openMathSymbol OM.impliesSymbol -equivalentSymbol = openMathSymbol OM.equivalentSymbol -andSymbol = openMathSymbol OM.andSymbol -orSymbol = openMathSymbol OM.orSymbol - -logicOperators :: [Magma (Logic a)] -logicOperators = map toMagma [andMonoid, orMonoid] - -andMonoid :: Monoid (Logic a) -andMonoid = monoid andOperator (makeConstant (getId trueSymbol) T isT) - where - isT T = True - isT _ = False - -orMonoid :: Monoid (Logic a) -orMonoid = monoid orOperator (makeConstant (getId falseSymbol) F isF) - where - isF F = True - isF _ = False - -andOperator:: BinaryOp (Logic a) -andOperator = makeBinary (getId andSymbol) (:&&:) isAnd - where - isAnd (p :&&: q) = Just (p, q) - isAnd _ = Nothing - -orOperator :: BinaryOp (Logic a) -orOperator = makeBinary (getId orSymbol) (:||:) isOr - where - isOr (p :||: q) = Just (p, q) - isOr _ = Nothing - -implOperator :: BinaryOp (Logic a) -implOperator = makeBinary (getId impliesSymbol) (:->:) isImpl - where - isImpl (p :->: q) = Just (p, q) - isImpl _ = Nothing - -equivOperator :: BinaryOp (Logic a) -equivOperator = makeBinary (getId equivalentSymbol) (:<->:) isEquiv - where - isEquiv (p :<->: q) = Just (p, q) - isEquiv _ = Nothing +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Formula + ( module Domain.Logic.Formula + , conjunctions, disjunctions, ors, ands + ) where + +import Common.Algebra.Boolean +import Common.Algebra.CoBoolean +import Common.Classes +import Common.Rewriting +import Common.Utils (ShowString, subsets) +import Common.Utils.Uniplate +import Control.Applicative +import Control.Monad +import Data.Foldable (Foldable, foldMap, toList) +import Data.List +import qualified Data.Traversable as T +import qualified Text.OpenMath.Dictionary.Logic1 as OM + +infixr 2 :<->: +infixr 3 :->: +infixr 4 :||: +infixr 5 :&&: + +-- | The data type Logic is the abstract syntax for the domain +-- | of logic expressions. +data Logic a = Var a + | Logic a :->: Logic a -- implication + | Logic a :<->: Logic a -- equivalence + | Logic a :&&: Logic a -- and (conjunction) + | Logic a :||: Logic a -- or (disjunction) + | Not (Logic a) -- not + | T -- true + | F -- false + deriving (Eq, Ord) + +-- | For simple use, we assume the variables to be strings +type SLogic = Logic ShowString + +instance Show a => Show (Logic a) where + show = ppLogic + +instance Functor Logic where + fmap = T.fmapDefault + +instance Foldable Logic where + foldMap = T.foldMapDefault + +instance T.Traversable Logic where + traverse f = foldLogic + ( fmap Var . f, liftA2 (:->:), liftA2 (:<->:), liftA2 (:&&:) + , liftA2 (:||:), liftA Not, pure T, pure F + ) + +instance BoolValue (Logic a) where + fromBool b = if b then T else F + isTrue T = True + isTrue _ = False + isFalse F = True + isFalse _ = False + +instance Boolean (Logic a) where + (<&&>) = (:&&:) + (<||>) = (:||:) + complement = Not + +instance CoBoolean (Logic a) where + isAnd (p :&&: q) = Just (p, q) + isAnd _ = Nothing + isOr (p :||: q) = Just (p, q) + isOr _ = Nothing + isComplement (Not p) = Just p + isComplement _ = Nothing + +instance Container Logic where + singleton = Var + getSingleton (Var a) = Just a + getSingleton _ = Nothing + +-- | The type LogicAlg is the algebra for the data type Logic +-- | Used in the fold for Logic. +type LogicAlg b a = (b -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a, a) + +-- | foldLogic is the standard fold for Logic. +foldLogic :: LogicAlg b a -> Logic b -> a +foldLogic (var, impl, equiv, conj, disj, neg, tr, fl) = rec + where + rec logic = + case logic of + Var x -> var x + p :->: q -> rec p `impl` rec q + p :<->: q -> rec p `equiv` rec q + p :&&: q -> rec p `conj` rec q + p :||: q -> rec p `disj` rec q + Not p -> neg (rec p) + T -> tr + F -> fl + +-- | Pretty-printer for propositions +ppLogic :: Show a => Logic a -> String +ppLogic = ppLogicPrio 0 + +ppLogicPrio :: Show a => Int -> Logic a -> String +ppLogicPrio = (\f s -> f s "") . flip (foldLogic alg) + where + alg = ( pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\" + , binop 1 "||", nott, pp "T", pp "F") + binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio) + pp s = const (s++) + nott p _ = ("~"++) . p 4 + parIf b f = if b then ("("++) . f . (")"++) else f + +-- | The monadic join for logic +catLogic :: Logic (Logic a) -> Logic a +catLogic = foldLogic (id, (:->:), (:<->:), (:&&:), (:||:), Not, T, F) + +-- | evalLogic takes a function that gives a logic value to a variable, +-- | and a Logic expression, and evaluates the boolean expression. +evalLogic :: (a -> Bool) -> Logic a -> Bool +evalLogic env = foldLogic (env, impl, (==), (&&), (||), not, True, False) + where + impl p q = not p || q + +-- | eqLogic determines whether or not two Logic expression are logically +-- | equal, by evaluating the logic expressions on all valuations. +eqLogic :: Eq a => Logic a -> Logic a -> Bool +eqLogic p q = all (\f -> evalLogic f p == evalLogic f q) fs + where + xs = varsLogic p `union` varsLogic q + fs = map (flip elem) (subsets xs) + +-- | A Logic expression is atomic if it is a variable or a constant True or False. +isAtomic :: Logic a -> Bool +isAtomic logic = + case logic of + Not (Var _) -> True + _ -> null (children logic) + +-- | Functions isDNF, and isCNF determine whether or not a Logix expression +-- | is in disjunctive normal form, or conjunctive normal form, respectively. +isDNF, isCNF :: Logic a -> Bool +isDNF = all isAtomic . concatMap conjunctions . disjunctions +isCNF = all isAtomic . concatMap disjunctions . conjunctions + +-- | Count the number of equivalences +countEquivalences :: Logic a -> Int +countEquivalences p = length [ () | _ :<->: _ <- universe p ] + +-- | Function varsLogic returns the variables that appear in a Logic expression. +varsLogic :: Eq a => Logic a -> [a] +varsLogic = nub . toList + +instance Uniplate (Logic a) where + uniplate this = + case this of + p :->: q -> plate (:->:) |* p |* q + p :<->: q -> plate (:<->:) |* p |* q + p :&&: q -> plate (:&&:) |* p |* q + p :||: q -> plate (:||:) |* p |* q + Not p -> plate Not |* p + _ -> plate this + +instance Different (Logic a) where + different = (T, F) + +instance IsTerm a => IsTerm (Logic a) where + toTerm = foldLogic + ( toTerm, binary impliesSymbol, binary equivalentSymbol + , binary andSymbol, binary orSymbol, unary notSymbol + , symbol trueSymbol, symbol falseSymbol + ) + + fromTerm a = + fromTermWith f a `mplus` liftM Var (fromTerm a) + where + f s [] + | s == trueSymbol = return T + | s == falseSymbol = return F + f s [x] + | s == notSymbol = return (Not x) + f s [x, y] + | s == impliesSymbol = return (x :->: y) + | s == equivalentSymbol = return (x :<->: y) + f s xs + | s == andSymbol = return (ands xs) + | s == orSymbol = return (ors xs) + f _ _ = fail "fromTerm" + +trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol, + andSymbol, orSymbol :: Symbol + +trueSymbol = newSymbol OM.trueSymbol +falseSymbol = newSymbol OM.falseSymbol +notSymbol = newSymbol OM.notSymbol +impliesSymbol = newSymbol OM.impliesSymbol +equivalentSymbol = newSymbol OM.equivalentSymbol +andSymbol = makeAssociative $ newSymbol OM.andSymbol +orSymbol = makeAssociative $ newSymbol OM.orSymbol diff --git a/src/Domain/Logic/GeneralizedRules.hs b/src/Domain/Logic/GeneralizedRules.hs --- a/src/Domain/Logic/GeneralizedRules.hs +++ b/src/Domain/Logic/GeneralizedRules.hs @@ -1,156 +1,143 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Generalized rules, and inverse rules, for De Morgan and distributivity --- ------------------------------------------------------------------------------ -module Domain.Logic.GeneralizedRules - ( generalRules, inverseRules - , generalRuleDeMorganOr, generalRuleDeMorganAnd - , generalRuleAndOverOr, generalRuleOrOverAnd - , inverseDeMorganOr, inverseDeMorganAnd - , inverseAndOverOr, inverseOrOverAnd - ) where - --- Note: the generalized rules do not take AC-unification into account, --- and perhaps they should. -import Domain.Logic.Formula -import Common.Transformation (Rule) -import qualified Common.Transformation as Rule -import Control.Monad - -generalRules :: [Rule SLogic] -generalRules = - [ generalRuleDeMorganOr, generalRuleDeMorganAnd - , generalRuleAndOverOr, generalRuleOrOverAnd - ] - -inverseRules :: [Rule SLogic] -inverseRules = - [ inverseDeMorganOr, inverseDeMorganAnd - , inverseAndOverOr, inverseOrOverAnd - ] - -makeSimpleRule :: String -> (a -> Maybe a) -> Rule a -makeSimpleRule s = Rule.makeSimpleRule ("logic.propositional." ++ s) - ------------------------------------------------------------------------------ --- Inverse rules - --- generalized (works for multiple terms) -inverseDeMorganOr :: Rule SLogic -inverseDeMorganOr = makeSimpleRule "InvDeMorganOr" $ \p -> do - let xs = conjunctions p - guard (length xs > 1) - ys <- mapM isNot xs - return (Not $ foldr1 (:||:) ys) - --- generalized (works for multiple terms) -inverseDeMorganAnd :: Rule SLogic -inverseDeMorganAnd = makeSimpleRule "InvDeMorganAnd" $ \p -> do - let xs = disjunctions p - guard (length xs > 1) - ys <- mapM isNot xs - return (Not $ foldr1 (:&&:) ys) - -inverseAndOverOr :: Rule SLogic -inverseAndOverOr = makeSimpleRule "InvAndOverOr" $ \p -> do - let xs = disjunctions p - guard (length xs > 1) - do pairs <- mapM isAndHead xs - let (as, ys) = unzip pairs - guard (allSame as) - return (head as :&&: foldr1 (:||:) ys) - `mplus` do - pairs <- mapM isAndLast xs - let (ys, as) = unzip pairs - guard (allSame as) - return (foldr1 (:||:) ys :&&: head as) - -inverseOrOverAnd :: Rule SLogic -inverseOrOverAnd = makeSimpleRule "InvOrOverAnd" $ \p -> do - let xs = conjunctions p - guard (length xs > 1) - do pairs <- mapM isOrHead xs - let (as, ys) = unzip pairs - guard (allSame as) - return (head as :||: foldr1 (:&&:) ys) - `mplus` do - pairs <- mapM isOrLast xs - let (ys, as) = unzip pairs - guard (allSame as) - return (foldr1 (:&&:) ys :||: head as) - -isNot :: SLogic -> Maybe SLogic -isNot (Not p) = Just p -isNot _ = Nothing - -isAndHead, isAndLast, isOrHead, isOrLast :: SLogic -> Maybe (SLogic, SLogic) -isAndHead = useHead (:&&:) . conjunctions -isAndLast = useLast (:&&:) . conjunctions -isOrHead = useHead (:||:) . disjunctions -isOrLast = useLast (:||:) . disjunctions - -useHead, useLast :: (a -> a -> a) -> [a] -> Maybe (a, a) -useHead op (x:xs) | not (null xs) = - Just (x, foldr1 op xs) -useHead _ _ = Nothing - -useLast op = fmap (\(x, y) -> (y, x)) . useHead (flip op) . reverse - - -allSame :: Eq a => [a] -> Bool -allSame [] = True -allSame (x:xs) = all (==x) xs - ------------------------------------------------------------------------------ --- Generalized rules - -generalRuleDeMorganOr :: Rule SLogic -generalRuleDeMorganOr = makeSimpleRule "GenDeMorganOr" f - where - f (Not e) = do - let xs = disjunctions e - guard (length xs > 2) - return (foldr1 (:&&:) (map Not xs)) - f _ = Nothing - -generalRuleDeMorganAnd :: Rule SLogic -generalRuleDeMorganAnd = makeSimpleRule "GenDeMorganAnd" f - where - f (Not e) = do - let xs = conjunctions e - guard (length xs > 2) - return (foldr1 (:||:) (map Not xs)) - f _ = Nothing - -generalRuleAndOverOr :: Rule SLogic -generalRuleAndOverOr = makeSimpleRule "GenAndOverOr" f - where - f (x :&&: y) = - case (disjunctions x, disjunctions y) of - (xs, _) | length xs > 2 -> - return (foldr1 (:||:) (map (:&&: y) xs)) - (_, ys) | length ys > 2 -> - return (foldr1 (:||:) (map (x :&&:) ys)) - _ -> Nothing - f _ = Nothing - -generalRuleOrOverAnd :: Rule SLogic -generalRuleOrOverAnd = makeSimpleRule "GenOrOverAnd" f - where - f (x :||: y) = - case (conjunctions x, conjunctions y) of - (xs, _) | length xs > 2 -> - return (foldr1 (:&&:) (map (:||: y) xs)) - (_, ys) | length ys > 2 -> - return (foldr1 (:&&:) (map (x :||:) ys)) - _ -> Nothing +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Generalized rules, and inverse rules, for De Morgan and distributivity +-- +----------------------------------------------------------------------------- +module Domain.Logic.GeneralizedRules + ( generalRuleDeMorganOr, generalRuleDeMorganAnd + , generalRuleAndOverOr, generalRuleOrOverAnd + , inverseDeMorganOr, inverseDeMorganAnd + , inverseAndOverOr, inverseOrOverAnd + ) where + +-- Note: the generalized rules do not take AC-unification into account, +-- and perhaps they should. +import Common.Algebra.Boolean +import Common.Transformation (Rule) +import Control.Monad +import Domain.Logic.Formula +import qualified Common.Transformation as Rule + +makeSimpleRule :: String -> (a -> Maybe a) -> Rule a +makeSimpleRule s = Rule.makeSimpleRule ("logic.propositional." ++ s) + +----------------------------------------------------------------------------- +-- Inverse rules + +-- generalized (works for multiple terms) +inverseDeMorganOr :: Rule SLogic +inverseDeMorganOr = makeSimpleRule "InvDeMorganOr" $ \p -> do + let xs = conjunctions p + guard (length xs > 1) + ys <- mapM isNot xs + return (Not $ ors ys) + +-- generalized (works for multiple terms) +inverseDeMorganAnd :: Rule SLogic +inverseDeMorganAnd = makeSimpleRule "InvDeMorganAnd" $ \p -> do + let xs = disjunctions p + guard (length xs > 1) + ys <- mapM isNot xs + return (Not $ ands ys) + +inverseAndOverOr :: Rule SLogic +inverseAndOverOr = makeSimpleRule "InvAndOverOr" $ \p -> do + let xs = disjunctions p + guard (length xs > 1) + do pairs <- mapM isAndHead xs + let (as, ys) = unzip pairs + guard (allSame as) + return (head as :&&: ors ys) + `mplus` do + pairs <- mapM isAndLast xs + let (ys, as) = unzip pairs + guard (allSame as) + return (ors ys :&&: head as) + +inverseOrOverAnd :: Rule SLogic +inverseOrOverAnd = makeSimpleRule "InvOrOverAnd" $ \p -> do + let xs = conjunctions p + guard (length xs > 1) + do pairs <- mapM isOrHead xs + let (as, ys) = unzip pairs + guard (allSame as) + return (head as :||: ands ys) + `mplus` do + pairs <- mapM isOrLast xs + let (ys, as) = unzip pairs + guard (allSame as) + return (ands ys :||: head as) + +isNot :: SLogic -> Maybe SLogic +isNot (Not p) = Just p +isNot _ = Nothing + +isAndHead, isAndLast, isOrHead, isOrLast :: SLogic -> Maybe (SLogic, SLogic) +isAndHead = useHead (:&&:) . conjunctions +isAndLast = useLast (:&&:) . conjunctions +isOrHead = useHead (:||:) . disjunctions +isOrLast = useLast (:||:) . disjunctions + +useHead, useLast :: (a -> a -> a) -> [a] -> Maybe (a, a) +useHead op (x:xs) | not (null xs) = + Just (x, foldr1 op xs) +useHead _ _ = Nothing + +useLast op = fmap (\(x, y) -> (y, x)) . useHead (flip op) . reverse + +allSame :: Eq a => [a] -> Bool +allSame [] = True +allSame (x:xs) = all (==x) xs + +----------------------------------------------------------------------------- +-- Generalized rules + +generalRuleDeMorganOr :: Rule SLogic +generalRuleDeMorganOr = makeSimpleRule "GenDeMorganOr" f + where + f (Not e) = do + let xs = disjunctions e + guard (length xs > 2) + return (ands (map Not xs)) + f _ = Nothing + +generalRuleDeMorganAnd :: Rule SLogic +generalRuleDeMorganAnd = makeSimpleRule "GenDeMorganAnd" f + where + f (Not e) = do + let xs = conjunctions e + guard (length xs > 2) + return (ors (map Not xs)) + f _ = Nothing + +generalRuleAndOverOr :: Rule SLogic +generalRuleAndOverOr = makeSimpleRule "GenAndOverOr" f + where + f (x :&&: y) = + case (disjunctions x, disjunctions y) of + (xs, _) | length xs > 2 -> + return (ors (map (:&&: y) xs)) + (_, ys) | length ys > 2 -> + return (ors (map (x :&&:) ys)) + _ -> Nothing + f _ = Nothing + +generalRuleOrOverAnd :: Rule SLogic +generalRuleOrOverAnd = makeSimpleRule "GenOrOverAnd" f + where + f (x :||: y) = + case (conjunctions x, conjunctions y) of + (xs, _) | length xs > 2 -> + return (ands (map (:||: y) xs)) + (_, ys) | length ys > 2 -> + return (ands (map (x :||:) ys)) + _ -> Nothing f _ = Nothing diff --git a/src/Domain/Logic/Generator.hs b/src/Domain/Logic/Generator.hs --- a/src/Domain/Logic/Generator.hs +++ b/src/Domain/Logic/Generator.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,55 +11,60 @@ -- ----------------------------------------------------------------------------- module Domain.Logic.Generator - ( generateLogic, generateLevel, equalLogicA, Level(..) + ( generateLogic, generateLevel, equalLogicA, equalLogicACI ) where +import Common.Algebra.Boolean +import Common.Exercise import Common.Utils (ShowString(..)) -import Domain.Logic.Formula +import Common.Utils.Uniplate import Control.Monad import Data.Char +import Data.List +import Domain.Logic.Formula import Test.QuickCheck -import Common.Rewriting -import Common.Uniplate -import Common.View ------------------------------------------------------------- --- Code that doesn't belong here, but the arbitrary instance --- is needed for the Rewrite instance. - -instance Rewrite SLogic where - operators = logicOperators +-- Code that doesn't belong here -- | Equality modulo associativity of operators -equalLogicA:: SLogic -> SLogic -> Bool +equalLogicA :: Eq a => Logic a -> Logic a -> Bool equalLogicA p q = rec p == rec q where - make = simplifyWith (map rec) . magmaListView rec a = case a of - _ :&&: _ -> make andMonoid a - _ :||: _ -> make orMonoid a + _ :&&: _ -> ands (map rec (conjunctions a)) + _ :||: _ -> ors (map rec (disjunctions a)) _ -> descend rec a +-- | Equality modulo associativity/commutativity/idempotency of operators, +-- and there units/absorbing elements +equalLogicACI :: Ord a => Logic a -> Logic a -> Bool +equalLogicACI p q = rec p == rec q + where + rec a@(_ :&&: _) = + let xs = filter (/=T) $ nub $ sort $ conjunctions a + in if F `elem` xs then F else ands (map rec xs) + rec a@(_ :||: _) = + let xs = filter (/=F) $ nub $ sort $ disjunctions a + in if T `elem` xs then T else ors (map rec xs) + rec a = descend rec a + ----------------------------------------------------------- -- Logic generator -data Level = Easy | Normal | Difficult - deriving Show - generateLogic :: Gen SLogic generateLogic = normalGenerator -generateLevel :: Level -> (Gen SLogic, (Int, Int)) -generateLevel level = - case level of - Easy -> (easyGenerator, (3, 6)) - Normal -> (normalGenerator, (4, 12)) - Difficult -> (difficultGenerator, (7, 18)) +generateLevel :: Difficulty -> (Gen SLogic, (Int, Int)) +generateLevel dif + | dif <= Easy = (easyGenerator, (3, 6)) + | dif >= Difficult = (difficultGenerator, (7, 18)) + | otherwise = (normalGenerator, (4, 12)) -- Use the propositions with 3-6 steps -easyGenerator :: Gen SLogic +easyGenerator :: Gen SLogic easyGenerator = do - n <- oneof [return 2, return 4] -- , return 8] + n <- elements [2, 4] -- , return 8] sizedGen True varGen n -- Use the propositions with 4-12 steps @@ -73,7 +78,7 @@ difficultGenerator :: Gen SLogic difficultGenerator = do let vs = ShowString "s" : varList - p0 <- sizedGen False (oneof $ map return vs) 4 + p0 <- sizedGen False (elements vs) 4 p1 <- preventSameVar vs p0 return (removePartsInDNF p1) @@ -81,16 +86,16 @@ varList = map ShowString ["p", "q", "r"] varGen :: Gen ShowString -varGen = oneof $ map return varList +varGen = elements varList sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a) -sizedGen constants gen = go +sizedGen constants gen = go where go n | n > 0 = let rec = go (n `div` 2) op2 f = liftM2 f rec rec - in frequency + in frequency [ (2, go 0) , (2, op2 (:->:)) , (1, op2 (:<->:)) @@ -106,11 +111,11 @@ -- Simple tricks for creating for "nice" logic propositions preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a) -preventSameVar xs = rec +preventSameVar xs = rec where rec p = case holes p of [(Var a, _), (Var b, update)] | a==b -> do - c <- oneof $ map return $ filter (/=a) xs + c <- elements $ filter (/=a) xs return $ update (Var c) _ -> descendM rec p @@ -119,11 +124,11 @@ where buildOr [] = T buildOr xs = foldl1 (:||:) xs - + simple = all f . conjunctions where f (Not p) = null (children p) - f p = null (children p) + f p = null (children p) ----------------------------------------------------------- --- QuickCheck generator @@ -132,13 +137,10 @@ arbitrary = sized (\i -> sizedGen True varGen (i `min` 4)) instance CoArbitrary SLogic where - coarbitrary logic = - case logic of - Var x -> variant (0 :: Int) . coarbitrary (map ord (fromShowString x)) - p :->: q -> variant (1 :: Int) . coarbitrary p . coarbitrary q - p :<->: q -> variant (2 :: Int) . coarbitrary p . coarbitrary q - p :&&: q -> variant (3 :: Int) . coarbitrary p . coarbitrary q - p :||: q -> variant (4 :: Int) . coarbitrary p . coarbitrary q - Not p -> variant (5 :: Int) . coarbitrary p - T -> variant (6 :: Int) - F -> variant (7 :: Int) + coarbitrary = foldLogic + (var, bin 1, bin 2, bin 3, bin 4, un 5, con 6, con 7) + where + con = variant :: Int -> Gen a -> Gen a + var = un 0 . coarbitrary . map ord . fromShowString + un n a = con n . a + bin n a b = con n . a . b diff --git a/src/Domain/Logic/Parser.hs b/src/Domain/Logic/Parser.hs --- a/src/Domain/Logic/Parser.hs +++ b/src/Domain/Logic/Parser.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -10,129 +10,100 @@ -- ----------------------------------------------------------------------------- module Domain.Logic.Parser - ( parseLogic, parseLogicPars, parseLogicUnicodePars, parseLogicProof + ( parseLogic, parseLogicPars, parseLogicUnicodePars -- , parseLogicProof , ppLogicPars, ppLogicUnicodePars ) where +import Common.Algebra.Boolean import Common.Utils (ShowString(..)) -import Control.Monad.Error (liftM2) -import Text.Parsing -import Control.Arrow import Domain.Logic.Formula - -logicScanner :: Scanner -logicScanner = (specialSymbols "~" defaultScanner) - { keywords = ["T", "F"] - , keywordOperators = "~" : concatMap (map fst . snd) operatorTable - } - -logicUnicodeScanner :: Scanner -logicUnicodeScanner = (specialSymbols (concat unicodeSyms) defaultScanner) - { keywords = ["T", "F"] - , keywordOperators = unicodeSyms - } - -operatorTable :: OperatorTable SLogic -operatorTable = - [ (RightAssociative, [("<->", (:<->:))]) - , (RightAssociative, [("||", (:||:))]) - , (RightAssociative, [("/\\", (:&&:))]) - , (RightAssociative, [("->", (:->:))]) - ] +import Text.Parsing +import qualified Text.ParserCombinators.Parsec.Token as P ----------------------------------------------------------- --- Parser --- | Parser for logic formulas that respects all associativity and priority laws --- | of the constructors parseLogic :: String -> Either String SLogic -parseLogic = analyseAndParse pLogic . scanWith logicScanner - where - pLogic = pOperators operatorTable (basicWithPos pLogic) - --- | Parser for logic formulas that insists on more parentheses: "and" and "or" are associative, --- | but implication and equivalence are not. Priorities of the operators are unknown, and thus --- | parentheses have to be written explicitly. No parentheses are needed for Not (Not p). Superfluous --- | parentheses are permitted +parseLogic = parseBalanced (parserSLogic False False) + +parseLogicUnicode :: String -> Either String SLogic +parseLogicUnicode = parseBalanced (parserSLogic True False) + parseLogicPars :: String -> Either String SLogic -parseLogicPars s - = either Left suspiciousVariable - $ left (ambiguousOperators parseLogic s) - $ analyseAndParse (pLogicGen asciiTuple) - $ scanWith logicScanner s +parseLogicPars input = + either (Left . ambiguousOperators parseLogic input) suspiciousVariable + $ parseBalanced (parserSLogic False True) input parseLogicUnicodePars :: String -> Either String SLogic -parseLogicUnicodePars s - = either Left suspiciousVariable - $ left (ambiguousOperators (parseLogic . concatMap f) s) - $ analyseAndParse (pLogicGen unicodeTuple) - $ scanWith logicUnicodeScanner s - where - -- quick fix (since we only need to know whether the parser succeeds) - f c | [c] == andUSym = andASym - | [c] == orUSym = orASym - | [c] == notUSym = notASym - | [c] == implUSym = implASym - | [c] == equivUSym = equivASym - | otherwise = [c] +parseLogicUnicodePars input = + either (Left . ambiguousOperators parseLogicUnicode input) suspiciousVariable + $ parseBalanced (parserSLogic True True) input -pLogicGen :: SymbolTuple -> TokenParser SLogic -pLogicGen (impl, equiv, conj, disj, neg, tr, fl) = pLogic +parseBalanced :: Parser a -> String -> Either String a +parseBalanced p input = + maybe (parseSimple p input) (Left . show) (balanced [('(', ')')] input) + +-- generalized parser +parserSLogic :: Bool -> Bool -> Parser SLogic +parserSLogic unicode extraPars = pLogic where - pLogic = flip ($) <$> basic <*> optional composed id - basic = basicWithPosGen (neg, tr, fl) pLogic - composed = flip (:<->:) <$ pKey equiv <*> basic - <|> flip (:->:) <$ pKey impl <*> basic - <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey conj *> basic) - <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey disj *> basic) - -basicWithPos :: TokenParser SLogic -> TokenParser SLogic -basicWithPos = basicWithPosGen ("~", "T", "F") + pLogic + | extraPars = atom <**> option id composed + | otherwise = buildExpressionParser table atom -basicWithPosGen :: (String, String, String) -> TokenParser SLogic -> TokenParser SLogic -basicWithPosGen t@(nt, tr, fl) p = - (Var . ShowString) <$> pVarid - <|> pParens p - <|> T <$ pKey tr - <|> F <$ pKey fl - <|> Not <$ pKey nt <*> basicWithPosGen t p + composed = choice + [ flip (:->:) <$ reservedOp implSym <*> atom + , flip (:<->:) <$ reservedOp equivSym <*> atom + , (\xs x -> ors (x:xs)) <$> many1 (reservedOp disjSym >> atom) + , (\xs x -> ands (x:xs)) <$> many1 (reservedOp conjSym >> atom) + ] -parseLogicProof :: String -> Either String (SLogic, SLogic) -parseLogicProof s - = either Left susp - $ left (ambiguousOperators parseLogic s) - $ analyseAndParse pProof - $ scanWith extScanner s - where - pProof = (,) <$> pLogicGen asciiTuple <* pKey "==" <*> pLogicGen asciiTuple - susp (p, q) = liftM2 (,) (suspiciousVariable p) (suspiciousVariable q) - extScanner = logicScanner - {keywordOperators = "==" : keywordOperators logicScanner} + atom = choice + [ T <$ P.reserved lexer trSym + , F <$ P.reserved lexer flSym + , Var . ShowString <$> P.identifier lexer + , P.parens lexer pLogic + , Not <$ reservedOp negSym <*> atom + ] + table = + [ [Infix ((:->:) <$ reservedOp implSym) AssocRight ] + , [Infix ((:&&:) <$ reservedOp conjSym) AssocRight ] + , [Infix ((:||:) <$ reservedOp disjSym) AssocRight ] + , [Infix ((:<->:) <$ reservedOp equivSym) AssocRight ] + ] + + (implSym, equivSym, conjSym, disjSym, negSym, trSym, flSym) + | unicode = unicodeTuple + | otherwise = asciiTuple + +lexer :: P.TokenParser a +lexer = P.makeTokenParser $ emptyDef + { reservedNames = ["T", "F"] + , reservedOpNames = ["~", "<->", "->", "||", "/\\"] + , identStart = lower + , identLetter = lower + , opStart = fail "" + , opLetter = fail "" + } + +reservedOp :: String -> Parser () +reservedOp = P.reservedOp lexer + ----------------------------------------------------------- --- Helper-functions for syntax warnings --- analyze parentheses -analyseAndParse :: TokenParser a -> [Token] -> Either String a -analyseAndParse p ts = - case checkParentheses ts of - Just err -> Left (show err) - Nothing -> either (Left . f) Right (parse p ts) - where - f (Just t) = show (tokenPosition t) ++ ": Unexpected " ++ show t - f Nothing = "Syntax error" - ambiguousOperators :: (String -> Either a b) -> String -> String -> String ambiguousOperators p s err = - let msg = "Ambiguous use of operators (write parentheses)" + let msg = "Syntax error: ambiguous use of operators (write parentheses)" in either (const err) (const msg) (p s) --- Report variables +-- Report variables suspiciousVariable :: SLogic -> Either String SLogic suspiciousVariable r = case filter p (map fromShowString (varsLogic r)) of v:_ -> Left $ "Unexpected variable " ++ v - ++ ". Did you forget an operator?" + ++ ". Did you forget an operator?" _ -> Right r where p xs = length xs > 1 && all (`elem` "pqrst") xs @@ -149,15 +120,15 @@ ppLogicUnicodePars = ppLogicParsGen unicodeTuple ppLogicParsGen :: SymbolTuple -> SLogic -> String -ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) = +ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) = (\f -> f 0 "") . foldLogic alg where alg = ( pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 conj , binop 2 disj, nott, pp tr, pp fl ) binop :: Int -> String -> (Int -> String -> String) -> (Int -> String -> String) -> Int -> String -> String - binop prio op p q n = - parIf (n/=0 && (n==3 || prio/=n)) + binop prio op p q n = + parIf (n/=0 && (n==3 || prio/=n)) (p prio . ((" "++op++" ")++) . q prio) pp s = const (s++) nott p _ = (neg++) . p 3 @@ -177,12 +148,9 @@ andASym = "/\\" orASym = "||" notASym = "~" - + ----------------------------------------------------------- --- Unicode symbols - -unicodeSyms :: [String] -unicodeSyms = [implUSym, equivUSym, andUSym, orUSym, notUSym] unicodeTuple :: SymbolTuple unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F") diff --git a/src/Domain/Logic/Proofs.hs b/src/Domain/Logic/Proofs.hs deleted file mode 100644 --- a/src/Domain/Logic/Proofs.hs +++ /dev/null @@ -1,319 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Exercise for the logic domain: to prove two propositions equivalent --- ------------------------------------------------------------------------------ -module Domain.Logic.Proofs (proofExercise) where - -import Prelude hiding (repeat) -import Common.Context -import Common.Rewriting -import Common.Rewriting.AC -import Common.Strategy hiding (fail, not) -import Common.Exercise -import Common.Utils -import Common.View -import Common.Transformation -import Common.Navigator -import Data.List hiding (repeat) -import Control.Monad -import Data.Maybe -import Domain.Logic.Formula -import Domain.Logic.Generator (equalLogicA) -import Domain.Logic.Parser -import Domain.Logic.Rules -import Domain.Logic.GeneralizedRules -import Domain.Logic.Strategies (somewhereOr) -import Domain.Logic.Examples -import Domain.Math.Expr () -import Common.Uniplate - -see :: Int -> IO () -see n = printDerivation proofExercise (examples proofExercise !! n) - --- Currently, we use the DWA strategy -proofExercise :: Exercise [(SLogic, SLogic)] -proofExercise = makeExercise - { exerciseId = describe "Prove two propositions equivalent" $ - newId "logic.proof" - , status = Experimental --- , parser = parseLogicProof - , prettyPrinter = let f (p, q) = ppLogicPars p ++ " == " ++ ppLogicPars q - in commaList . map f --- , equivalence = \(p, _) (r, s) -> eqLogic p r && eqLogic r s --- , similarity = \(p, q) (r, s) -> equalLogicA p r && equalLogicA q s - , isSuitable = all (uncurry eqLogic) - , isReady = all (uncurry equalLogicA) - , strategy = proofStrategy - , navigation = termNavigator - , examples = map return $ exampleProofs ++ - let p = Var (ShowString "p") - q = Var (ShowString "q") - in [(q :&&: p, p :&&: (q :||: q))] - } - -instance (IsTerm a, IsTerm b) => IsTerm (a, b) where - toTerm (a, b) = binary tupleSymbol (toTerm a) (toTerm b) - fromTerm term = do - (a, b) <- isBinary tupleSymbol term - liftM2 (,) (fromTerm a) (fromTerm b) - -tupleSymbol :: Symbol -tupleSymbol = newSymbol "basic.tuple" - -proofStrategy :: LabeledStrategy (Context [(SLogic, SLogic)]) -proofStrategy = label "proof equivalent" $ - repeat ( - somewhere (useC commonExprAtom) - |> somewhere splitTop - |> somewhere rest - ) <*> - repeat (somewhere (use normLogicRule)) - where - splitTop = use topIsNot <|> use topIsAnd <|> use topIsOr - <|> use topIsImpl <|> use topIsEquiv - rest = use notDNF <*> mapRulesS useC (repeat dnfStrategyDWA) - <|> simpler - - simpler :: Strategy (Context [(SLogic, SLogic)]) - simpler = - use tautologyOr <|> use idempotencyAnd <|> use contradictionAnd - <|> use absorptionSubset <|> use fakeAbsorption <|> use fakeAbsorptionNot - <|> alternatives (map use list) - - list = [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr - , ruleAbsorpOr, ruleComplOr - ] - - notDNF :: Rule SLogic - notDNF = minorRule $ makeSimpleRule "not-dnf" $ \p -> - if isDNF p then Nothing else Just p - ------------------------------------------------------------------------------ --- To DNF, with priorities (the "DWA" approach) - -dnfStrategyDWA :: Strategy (Context SLogic) -dnfStrategyDWA = - toplevel <|> somewhereOr - ( label "Simplify" simplify - |> label "Eliminate implications/equivalences" eliminateImplEquiv - |> label "Eliminate nots" eliminateNots - |> label "Move ors to top" orToTop - ) - where - toplevel = useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr - , ruleAbsorpOr, ruleComplOr - ] - simplify = somewhere $ useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd - , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse - , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd - , ruleComplOr, ruleComplAnd - ] - eliminateImplEquiv = somewhere $ useRules - [ ruleDefImpl, ruleDefEquiv - ] - eliminateNots = somewhere $ useRules - [ generalRuleDeMorganAnd, generalRuleDeMorganOr - , ruleDeMorganAnd, ruleDeMorganOr - ] - orToTop = somewhere $ useRules - [ generalRuleAndOverOr, ruleAndOverOr ] - -useRules :: [Rule SLogic] -> Strategy (Context SLogic) -useRules = alternatives . map liftToContext - -onceLeft :: IsStrategy f => f (Context a) -> Strategy (Context a) -onceLeft s = ruleMoveDown <*> s <*> ruleMoveUp - where - ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 1) - ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" safeUp - - safeUp a = Just (fromMaybe a (up a)) - -onceRight :: IsStrategy f => f (Context a) -> Strategy (Context a) -onceRight s = ruleMoveDown <*> s <*> ruleMoveUp - where - ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 2) - ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" safeUp - - safeUp a = Just (fromMaybe a (up a)) - -testje :: Rule (Context SLogic) -testje = makeSimpleRule "testje" $ \a -> error $ show a - -go n = printDerivation proofExercise [exampleProofs !! n] --(p :||: Not p, Not F) - --where p = Var (ShowString "p") - -normLogicRule :: Rule (SLogic, SLogic) -normLogicRule = makeSimpleRule "Normalize" $ \tuple@(p, q) -> do - guard (p /= q) - let xs = sort (varsLogic p `union` varsLogic q) - new = (normLogicWith xs p, normLogicWith xs q) - guard (tuple /= new) - return new - --- Find a common subexpression that can be treated as a box -commonExprAtom :: Rule (Context (SLogic, SLogic)) -commonExprAtom = makeSimpleRule "commonExprAtom" $ withCM $ \(p, q) -> do - let f = filter same . filter ok . nub . sort . universe - xs = f p `intersect` f q -- todo: only largest common sub expr - ok (Var _) = False - ok T = False - ok F = False - ok (Not a) = ok a - ok _ = True - same cse = eqLogic (sub cse p) (sub cse q) - new = head (logicVars \\ (varsLogic p `union` varsLogic q)) - sub a this - | a == this = Var new - | otherwise = descend (sub a) this - case xs of - hd:_ -> do modifyVar substVar ((show new, show hd):) - return (sub hd p, sub hd q) - _ -> fail "not applicable" - -substVar :: Var [(String, String)] -substVar = newVar "subst" [] - -logicVars :: [ShowString] -logicVars = [ ShowString [c] | c <- ['a'..] ] - -normLogic :: Ord a => Logic a -> Logic a -normLogic p = normLogicWith (sort (varsLogic p)) p - -normLogicWith :: Eq a => [a] -> Logic a -> Logic a -normLogicWith xs p = make (filter keep (subsets xs)) - where - keep ys = evalLogic (`elem` ys) p - make = makeOrs . map atoms - atoms ys = makeAnds [ f (x `elem` ys) (Var x) | x <- xs ] - f b = if b then id else Not - -makeOrs xs = if null xs then F else foldr1 (:||:) xs -makeAnds xs = if null xs then T else foldr1 (:&&:) xs - - --- p \/ q \/ ~p ~> T (propageren) -tautologyOr :: Rule SLogic -tautologyOr = makeSimpleRule "tautologyOr" $ \p -> do - let xs = disjunctions p - guard (any (\x -> Not x `elem` xs) xs) - return T - --- p /\ q /\ p ~> p /\ q -idempotencyAnd :: Rule SLogic -idempotencyAnd = makeSimpleRule "idempotencyAnd" $ \p -> do - let xs = conjunctions p - ys = nub xs - guard (length ys < length xs) - return (makeAnds ys) - --- p /\ q /\ ~p ~> F (propageren) -contradictionAnd :: Rule SLogic -contradictionAnd = makeSimpleRule "contradictionAnd" $ \p -> do - let xs = conjunctions p - guard (any (\x -> Not x `elem` xs) xs) - return F - --- (p /\ q) \/ ... \/ (p /\ q /\ r) ~> (p /\ q) \/ ... --- (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes) -absorptionSubset :: Rule SLogic -absorptionSubset = makeSimpleRule "absorptionSubset" $ \p -> do - let xss = map conjunctions (disjunctions p) - yss = nub $ filter (\xs -> all (ok xs) xss) xss - ok xs ys = not (ys `isSubsetOf` xs) || xs == ys - guard (length yss < length xss) - return $ makeOrs (map makeAnds yss) - --- p \/ ... \/ (~p /\ q /\ r) ~> p \/ ... \/ (q /\ r) --- (p is hier een losse variabele) -fakeAbsorption :: Rule SLogic -fakeAbsorption = makeSimpleRuleList "fakeAbsorption" $ \p -> do - let xs = disjunctions p - v <- [ a | a@(Var _) <- xs ] - let ys = map (makeAnds . filter (/= Not v) . conjunctions) xs - new = makeOrs ys - guard (p /= new) - return new - --- ~p \/ ... \/ (p /\ q /\ r) ~> ~p \/ ... \/ (q /\ r) --- (p is hier een losse variabele) -fakeAbsorptionNot :: Rule SLogic -fakeAbsorptionNot = makeSimpleRuleList "fakeAbsorptionNot" $ \p -> do - let xs = disjunctions p - v <- [ a | Not a@(Var _) <- xs ] - let ys = map (makeAnds . filter (/= v) . conjunctions) xs - new = makeOrs ys - guard (p /= new) - return new - -topIsNot :: Rule (SLogic, SLogic) -topIsNot = makeSimpleRule "top-is-not" f - where - f (Not p, Not q) = Just (p, q) - f _ = Nothing - -acTopRuleFor :: IsId a => a -> BinaryOp SLogic -> Rule [(SLogic, SLogic)] -acTopRuleFor s op = makeSimpleRuleList s f - where - f [(lhs, rhs)] = do - let myView = magmaListView (semiGroup op) - make = build myView - xs <- matchM myView lhs - ys <- matchM myView rhs - guard (length xs > 1 && length ys > 1) - list <- liftM (map (make *** make)) (pairingsAC False xs ys) - guard (all (uncurry eqLogic) list) - return list - f _ = [] - -topIsAnd :: Rule [(SLogic, SLogic)] -topIsAnd = acTopRuleFor "top-is-and" andOperator - -topIsOr :: Rule [(SLogic, SLogic)] -topIsOr = acTopRuleFor "top-is-or" orOperator - -topIsEquiv :: Rule [(SLogic, SLogic)] -topIsEquiv = acTopRuleFor "top-is-equiv" equivOperator - -topIsImpl :: Rule [(SLogic, SLogic)] -topIsImpl = makeSimpleRule "top-is-impl" f - where - f [(p :->: q, r :->: s)] = do - guard (eqLogic p r && eqLogic q s) - return [(p, r), (q, s)] - f _ = Nothing - -{- Strategie voor sterke(?) normalisatie - -(prioritering) - -1. p \/ q \/ ~p ~> T (propageren) - p /\ q /\ p ~> p /\ q - p /\ q /\ ~p ~> F (propageren) - -2. (p /\ q) \/ ... \/ (p /\ q /\ r) ~> (p /\ q) \/ ... - (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes) - p \/ ... \/ (~p /\ q /\ r) ~> p \/ ... \/ (q /\ r) - (p is hier een losse variabele) - ~p \/ ... \/ (p /\ q /\ r) ~> ~p \/ ... \/ (q /\ r) - (p is hier een losse variabele) - -3. a) elimineren wat aan een kant helemaal niet voorkomt (zie regel hieronder) - b) rijtjes sorteren - c) rijtjes aanvullen - -Twijfelachtige regel bij stap 3: samennemen in plaats van aanvullen: - (p /\ q /\ r) \/ ... \/ (~p /\ q /\ r) ~> q /\ r - (p is hier een losse variable) --} diff --git a/src/Domain/Logic/Rules.hs b/src/Domain/Logic/Rules.hs --- a/src/Domain/Logic/Rules.hs +++ b/src/Domain/Logic/Rules.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -8,92 +8,57 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Rewrite rules in the logic domain (including all the rules from the +-- Rewrite rules in the logic domain (including all the rules from the -- DWA course) -- ----------------------------------------------------------------------------- -module Domain.Logic.Rules where +module Domain.Logic.Rules + ( extraLogicRules, ruleAbsorpAnd, ruleAbsorpOr, ruleAndOverOr + , ruleComplAnd, ruleComplOr, ruleDeMorganAnd, ruleDeMorganOr + , ruleDefEquiv, ruleDefImpl, ruleFalseInEquiv, ruleFalseInImpl + , ruleFalseZeroAnd, ruleFalseZeroOr, ruleIdempAnd, ruleIdempOr + , ruleNotFalse, ruleNotNot, ruleNotTrue, ruleTrueInEquiv + , ruleTrueInImpl, ruleTrueZeroAnd, ruleTrueZeroOr + ) where -import Domain.Logic.Formula import Common.Id -import Common.Transformation (Rule, addRuleToGroup, minorRule) import Common.Rewriting -import Domain.Logic.Generator() +import Common.Transformation (Rule, minorRule) +import Domain.Logic.Formula import Domain.Logic.GeneralizedRules +import Domain.Logic.Generator() import qualified Common.Transformation as Rule - -logicRules :: [Rule SLogic] -logicRules = concatMap snd - [ groupCommutativity, groupAssociativity, groupIdempotency - , groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation - , groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, groupAdditional - , groupDistributionOrOverAnd, groupDistributionAndOverOr - , groupInverseDeMorgan,groupInverseDistr + +extraLogicRules :: [Rule SLogic] +extraLogicRules = + [ ruleCommOr, ruleCommAnd, ruleAssocOr, ruleAssocAnd + , ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl + , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame + , generalRuleOrOverAnd, ruleOrOverAnd + , inverseDeMorganOr, inverseDeMorganAnd + , inverseAndOverOr, inverseOrOverAnd ] logic :: IsId a => a -> Id -logic = ( # ) "logic.propositional" +logic = ( # ) "logic.propositional" -rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +rule :: RuleBuilder f a => String -> f -> Rule a rule = Rule.rule . logic -ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +ruleList :: RuleBuilder f a => String -> [f] -> Rule a ruleList = Rule.ruleList . logic ----------------------------------------------------------------------------- --- Grouping DWA rules - -makeGroup :: String -> [Rule SLogic] -> (Id, [Rule SLogic]) -makeGroup s rs = - let a = logic s - in (a, map (addRuleToGroup a) rs) - -groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, - groupDistributionAndOverOr,groupIdempotency, groupAbsorption, - groupTrueProperties, groupFalseProperties, groupDoubleNegation, - groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, - groupInverseDeMorgan, groupInverseDistr :: (Id, [Rule SLogic]) - -groupCommutativity = makeGroup "Commutativity" - [ruleCommOr, ruleCommAnd] -groupAssociativity = makeGroup "Associativity" - [ruleAssocOr, ruleAssocAnd] -groupIdempotency = makeGroup "Idempotency" - [ruleIdempOr, ruleIdempAnd] -groupAbsorption = makeGroup "Absorption" - [ruleAbsorpOr, ruleAbsorpAnd] -groupTrueProperties = makeGroup "True Properties" - [ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue] -groupFalseProperties = makeGroup "False Properties" - [ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse] -groupDoubleNegation = makeGroup "Double Negation" - [ruleNotNot] -groupDeMorgan = makeGroup "De Morgan" - [ruleDeMorganOr, ruleDeMorganAnd, generalRuleDeMorganOr, generalRuleDeMorganAnd ] -groupImplicationEliminatinon = makeGroup "Implication Elimination" - [ruleDefImpl] -groupEquivalenceElimination = makeGroup "Equivalence Elimination" - [ruleDefEquiv] -groupDistributionOrOverAnd = makeGroup "DistributionOrOverAnd" - [generalRuleOrOverAnd, ruleOrOverAnd ] -groupDistributionAndOverOr = makeGroup "DistributionAndOverOr" - [generalRuleAndOverOr, ruleAndOverOr ] -groupInverseDeMorgan = makeGroup "InverseDeMorgan" - [inverseDeMorganOr, inverseDeMorganAnd] -groupInverseDistr = makeGroup "InverseDistr" - [inverseAndOverOr, inverseOrOverAnd] - ------------------------------------------------------------------------------ -- Commutativity -ruleCommOr :: Rule SLogic +ruleCommOr :: Rule SLogic ruleCommOr = rule "CommOr" $ \x y -> x :||: y :~> y :||: x -ruleCommAnd :: Rule SLogic +ruleCommAnd :: Rule SLogic ruleCommAnd = rule "CommAnd" $ \x y -> x :&&: y :~> y :&&: x - + ----------------------------------------------------------------------------- -- Associativity (implicit) @@ -104,27 +69,27 @@ ruleAssocAnd :: Rule SLogic ruleAssocAnd = minorRule $ rule "AssocAnd" $ \x y z -> (x :&&: y) :&&: z :~> x :&&: (y :&&: z) - + ----------------------------------------------------------------------------- -- Distributivity -ruleAndOverOr :: Rule SLogic +ruleAndOverOr :: Rule SLogic ruleAndOverOr = ruleList "AndOverOr" [ \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: (x :&&: z) , \x y z -> (x :||: y) :&&: z :~> (x :&&: z) :||: (y :&&: z) ] -ruleOrOverAnd :: Rule SLogic +ruleOrOverAnd :: Rule SLogic ruleOrOverAnd = ruleList "OrOverAnd" [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: (x :||: z) , \x y z -> (x :&&: y) :||: z :~> (x :||: z) :&&: (y :||: z) ] - + ----------------------------------------------------------------------------- -- Idempotency -ruleIdempOr, ruleIdempAnd :: Rule SLogic +ruleIdempOr, ruleIdempAnd :: Rule SLogic ruleIdempOr = rule "IdempOr" $ \x -> x :||: x :~> x @@ -135,26 +100,26 @@ ----------------------------------------------------------------------------- -- Absorption -ruleAbsorpOr, ruleAbsorpAnd :: Rule SLogic +ruleAbsorpOr, ruleAbsorpAnd :: Rule SLogic -ruleAbsorpOr = ruleList "AbsorpOr" +ruleAbsorpOr = ruleList "AbsorpOr" [ \x y -> x :||: (x :&&: y) :~> x , \x y -> x :||: (y :&&: x) :~> x , \x y -> (x :&&: y) :||: x :~> x , \x y -> (y :&&: x) :||: x :~> x ] - + ruleAbsorpAnd = ruleList "AbsorpAnd" - [ \x y -> x :&&: (x :||: y) :~> x - , \x y -> x :&&: (y :||: x) :~> x - , \x y -> (x :||: y) :&&: x :~> x - , \x y -> (y :||: x) :&&: x :~> x + [ \x y -> x :&&: (x :||: y) :~> x + , \x y -> x :&&: (y :||: x) :~> x + , \x y -> (x :||: y) :&&: x :~> x + , \x y -> (y :||: x) :&&: x :~> x ] ----------------------------------------------------------------------------- -- True-properties -ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue :: Rule SLogic +ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue :: Rule SLogic ruleTrueZeroOr = ruleList "TrueZeroOr" [ \x -> T :||: x :~> T @@ -164,8 +129,8 @@ ruleTrueZeroAnd = ruleList "TrueZeroAnd" [ \x -> T :&&: x :~> x , \x -> x :&&: T :~> x - ] - + ] + ruleComplOr = ruleList "ComplOr" [ \x -> x :||: Not x :~> T , \x -> Not x :||: x :~> T @@ -173,22 +138,22 @@ ruleNotTrue = rule "NotTrue" $ Not T :~> F - + ----------------------------------------------------------------------------- -- False-properties -ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse :: Rule SLogic +ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse :: Rule SLogic ruleFalseZeroOr = ruleList "FalseZeroOr" [ \x -> F :||: x :~> x , \x -> x :||: F :~> x ] - + ruleFalseZeroAnd = ruleList "FalseZeroAnd" [ \x -> F :&&: x :~> F , \x -> x :&&: F :~> F ] - + ruleComplAnd = ruleList "ComplAnd" [ \x -> x :&&: Not x :~> F , \x -> Not x :&&: x :~> F @@ -200,80 +165,74 @@ ----------------------------------------------------------------------------- -- Double negation -ruleNotNot :: Rule SLogic +ruleNotNot :: Rule SLogic ruleNotNot = rule "NotNot" $ \x -> Not (Not x) :~> x - + ----------------------------------------------------------------------------- -- De Morgan -ruleDeMorganOr :: Rule SLogic +ruleDeMorganOr :: Rule SLogic ruleDeMorganOr = rule "DeMorganOr" $ \x y -> Not (x :||: y) :~> Not x :&&: Not y -ruleDeMorganAnd :: Rule SLogic +ruleDeMorganAnd :: Rule SLogic ruleDeMorganAnd = rule "DeMorganAnd" $ \x y -> Not (x :&&: y) :~> Not x :||: Not y - + ----------------------------------------------------------------------------- -- Implication elimination -ruleDefImpl :: Rule SLogic +ruleDefImpl :: Rule SLogic ruleDefImpl = rule "DefImpl" $ \x y -> x :->: y :~> Not x :||: y - + ----------------------------------------------------------------------------- -- Equivalence elimination -ruleDefEquiv :: Rule SLogic +ruleDefEquiv :: Rule SLogic ruleDefEquiv = rule "DefEquiv" $ \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&: Not y) ----------------------------------------------------------------------------- -- Additional rules, not in the DWA course -groupAdditional :: (Id, [Rule SLogic]) -groupAdditional = makeGroup "Additional rules" - [ ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl - , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame - ] - -ruleFalseInEquiv :: Rule SLogic +ruleFalseInEquiv :: Rule SLogic ruleFalseInEquiv = ruleList "FalseInEquiv" [ \x -> F :<->: x :~> Not x , \x -> x :<->: F :~> Not x ] - -ruleTrueInEquiv :: Rule SLogic + +ruleTrueInEquiv :: Rule SLogic ruleTrueInEquiv = ruleList "TrueInEquiv" [ \x -> T :<->: x :~> x , \x -> x :<->: T :~> x ] -ruleFalseInImpl :: Rule SLogic +ruleFalseInImpl :: Rule SLogic ruleFalseInImpl = ruleList "FalseInImpl" [ \x -> F :->: x :~> T , \x -> x :->: F :~> Not x ] - -ruleTrueInImpl :: Rule SLogic + +ruleTrueInImpl :: Rule SLogic ruleTrueInImpl = ruleList "TrueInImpl" [ \x -> T :->: x :~> x , \x -> x :->: T :~> T ] - -ruleCommEquiv :: Rule SLogic + +ruleCommEquiv :: Rule SLogic ruleCommEquiv = rule "CommEquiv" $ \x y -> x :<->: y :~> y :<->: x -ruleDefEquivImpls :: Rule SLogic +ruleDefEquivImpls :: Rule SLogic ruleDefEquivImpls = rule "DefEquivImpls" $ \x y -> x :<->: y :~> (x :->: y) :&&: (y :->: x) -ruleEquivSame :: Rule SLogic +ruleEquivSame :: Rule SLogic ruleEquivSame = rule "EquivSame" $ \x -> x :<->: x :~> T -ruleImplSame :: Rule SLogic +ruleImplSame :: Rule SLogic ruleImplSame = rule "ImplSame" $ \x -> x :->: (x::SLogic) :~> T 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,103 +1,98 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Logic.Strategies - ( dnfStrategy, dnfStrategyDWA, somewhereOr - ) where - -import Prelude hiding (repeat) -import Domain.Logic.Rules -import Domain.Logic.GeneralizedRules -import Domain.Logic.Formula -import Common.Context (Context, liftToContext) -import Common.Transformation -import Common.Strategy -import Common.Navigator - ------------------------------------------------------------------------------ --- To DNF, with priorities (the "DWA" approach) - -dnfStrategyDWA :: LabeledStrategy (Context SLogic) -dnfStrategyDWA = label "Bring to dnf (DWA)" $ - repeat $ toplevel <|> somewhereOr - ( label "Simplify" simplify - |> label "Eliminate implications/equivalences" eliminateImplEquiv - |> label "Eliminate nots" eliminateNots - |> label "Move ors to top" orToTop - ) - where - toplevel = useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr - , ruleAbsorpOr, ruleComplOr - ] - simplify = somewhere $ useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd - , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse - , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd - , ruleComplOr, ruleComplAnd - ] - eliminateImplEquiv = somewhere $ useRules - [ ruleDefImpl, ruleDefEquiv - ] - eliminateNots = somewhere $ useRules - [ generalRuleDeMorganAnd, generalRuleDeMorganOr - , ruleDeMorganAnd, ruleDeMorganOr - ] - orToTop = somewhere $ useRules - [ generalRuleAndOverOr, ruleAndOverOr ] - --- A specialized variant of the somewhere traversal combinator. Apply --- the strategy only at (top-level) disjuncts -somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic) -somewhereOr s = - let isOr a = case current a of - Just (_ :||: _) -> True - _ -> False - in fix $ \this -> check (Prelude.not . isOr) <*> s - <|> check isOr <*> once this - ---check1, check2 :: (a -> Bool) -> Rule a ---check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing ---check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing - - ------------------------------------------------------------------------------ --- To DNF, in four steps - -dnfStrategy :: LabeledStrategy (Context SLogic) -dnfStrategy = label "Bring to dnf" - $ label "Eliminate constants" eliminateConstants - <*> label "Eliminate implications/equivalences" eliminateImplEquiv - <*> label "Eliminate nots" eliminateNots - <*> label "Move ors to top" orToTop - where - eliminateConstants = repeat $ topDown $ useRules - [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd - , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv - , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl - ] - eliminateImplEquiv = repeat $ bottomUp $ useRules - [ ruleDefImpl, ruleDefEquiv - ] - eliminateNots = repeat $ topDown $ - useRules - [ generalRuleDeMorganAnd, generalRuleDeMorganOr ] - |> useRules - [ ruleDeMorganAnd, ruleDeMorganOr - , ruleNotNot - ] - orToTop = repeat $ somewhere $ - liftToContext generalRuleAndOverOr |> - liftToContext ruleAndOverOr - --- local helper function -useRules :: [Rule SLogic] -> Strategy (Context SLogic) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Strategies + ( dnfStrategy, dnfStrategyDWA, somewhereOr + ) where + +import Common.Library +import Domain.Logic.Formula +import Domain.Logic.GeneralizedRules +import Domain.Logic.Rules + +----------------------------------------------------------------------------- +-- To DNF, with priorities (the "DWA" approach) + +dnfStrategyDWA :: LabeledStrategy (Context SLogic) +dnfStrategyDWA = label "Bring to dnf (DWA)" $ + repeatS $ toplevel <|> somewhereOr + ( label "Simplify" simpl + |> label "Eliminate implications/equivalences" eliminateImplEquiv + |> label "Eliminate nots" eliminateNots + |> label "Move ors to top" orToTop + ) + where + toplevel = useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr + , ruleAbsorpOr, ruleComplOr + ] + simpl = somewhere $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse + , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd + , ruleComplOr, ruleComplAnd + ] + eliminateImplEquiv = somewhere $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = somewhere $ useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr + , ruleDeMorganAnd, ruleDeMorganOr + ] + orToTop = somewhere $ useRules + [ generalRuleAndOverOr, ruleAndOverOr ] + +-- A specialized variant of the somewhere traversal combinator. Apply +-- the strategy only at (top-level) disjuncts +somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic) +somewhereOr s = + let isOr a = case current a of + Just (_ :||: _) -> True + _ -> False + in fix $ \this -> check (Prelude.not . isOr) <*> s + <|> check isOr <*> once this + +--check1, check2 :: (a -> Bool) -> Rule a +--check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing +--check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing + +----------------------------------------------------------------------------- +-- To DNF, in four steps + +dnfStrategy :: LabeledStrategy (Context SLogic) +dnfStrategy = label "Bring to dnf" + $ label "Eliminate constants" eliminateConstants + <*> label "Eliminate implications/equivalences" eliminateImplEquiv + <*> label "Eliminate nots" eliminateNots + <*> label "Move ors to top" orToTop + where + eliminateConstants = repeatS $ topDown $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv + , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl + ] + eliminateImplEquiv = repeatS $ bottomUp $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = repeatS $ topDown $ + useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr ] + |> useRules + [ ruleDeMorganAnd, ruleDeMorganOr + , ruleNotNot + ] + orToTop = repeatS $ somewhere $ + liftToContext generalRuleAndOverOr |> + liftToContext ruleAndOverOr + +-- local helper function +useRules :: [Rule SLogic] -> Strategy (Context SLogic) useRules = alternatives . map liftToContext diff --git a/src/Domain/Logic/Views.hs b/src/Domain/Logic/Views.hs --- a/src/Domain/Logic/Views.hs +++ b/src/Domain/Logic/Views.hs @@ -1,96 +1,100 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Logic.Views where - -import Common.View -import Domain.Logic.Formula - ------------------------------------------------------------- --- Smart constructors - -infixr 2 .<->. -infixr 3 .->. -infixr 4 .||. -infixr 5 .&&. - -(.<->.) :: Logic a -> Logic a -> Logic a -T .<->. q = q -F .<->. q = nott q -p .<->. T = p -p .<->. F = nott p -p .<->. q = p :<->: q - -(.->.) :: Logic a -> Logic a -> Logic a -T .->. q = q -F .->. _ = T -_ .->. T = T -p .->. F = nott p -p .->. q = p :->: q - -(.||.) :: Logic a -> Logic a -> Logic a -T .||. _ = T -F .||. q = q -_ .||. T = T -p .||. F = p -p .||. q = p :||: q - -(.&&.) :: Logic a -> Logic a -> Logic a -T .&&. q = q -F .&&. _ = F -p .&&. T = p -_ .&&. F = F -p .&&. q = p :&&: q - -nott :: Logic a -> Logic a -nott (Not p) = p -nott p = Not p - -------------------------------------------------- --- Views and transformations - -simplify :: Logic a -> Logic a -simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F) - -pushNotWith :: (a -> Logic a) -> Logic a -> Logic a -pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F) - where - rec logic = - case logic of - Not p :<->: q -> p .<->. q - p :<->: Not q -> p .<->. q - p :<->: q -> rec p .<->. q - p :->: q -> p .&&. rec q - p :||: q -> rec p .&&. rec q - p :&&: q -> rec p .||. rec q - Not p -> p - T -> F - F -> T - Var a -> f a - -pushNot :: Logic a -> Logic a -pushNot = pushNotWith (nott . Var) - -orView :: View (Logic a) [a] -orView = newView "logic.orView" (($ []) . f) (foldr ((.||.). Var) F) - where - f (p :||: q) = (>>= f p) . f q - f (Var a) = return . (a:) - f F = return - f _ = const Nothing - -andView :: View (Logic a) [a] -andView = newView "logic.andView" (($ []) . f) (foldr ((.&&.). Var) T) - where - f (p :&&: q) = (>>= f p) . f q - f (Var a) = return . (a:) - f T = return +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Views + ( (.<->.), (.->.), (.&&.), (.||.) + , simplify, pushNot, pushNotWith + , orView, andView + ) where + +import Common.Algebra.CoBoolean +import Common.Id +import Common.View hiding (simplify) +import Domain.Logic.Formula + +------------------------------------------------------------ +-- Smart constructors + +infixr 2 .<->. +infixr 3 .->. + +(.<->.) :: Logic a -> Logic a -> Logic a +T .<->. q = q +F .<->. q = nott q +p .<->. T = p +p .<->. F = nott p +p .<->. q = p :<->: q + +(.->.) :: Logic a -> Logic a -> Logic a +T .->. q = q +F .->. _ = T +_ .->. T = T +p .->. F = nott p +p .->. q = p :->: q + +{- (.||.) :: Logic a -> Logic a -> Logic a +T .||. _ = T +F .||. q = q +_ .||. T = T +p .||. F = p +p .||. q = p :||: q + +(.&&.) :: Logic a -> Logic a -> Logic a +T .&&. q = q +F .&&. _ = F +p .&&. T = p +_ .&&. F = F +p .&&. q = p :&&: q -} + +nott :: Logic a -> Logic a +nott (Not p) = p +nott p = Not p + +------------------------------------------------- +-- Views and transformations + +simplify :: Logic a -> Logic a +simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F) + +pushNotWith :: (a -> Logic a) -> Logic a -> Logic a +pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F) + where + rec logic = + case logic of + Not p :<->: q -> p .<->. q + p :<->: Not q -> p .<->. q + p :<->: q -> rec p .<->. q + p :->: q -> p .&&. rec q + p :||: q -> rec p .&&. rec q + p :&&: q -> rec p .||. rec q + Not p -> p + T -> F + F -> T + Var a -> f a + +pushNot :: Logic a -> Logic a +pushNot = pushNotWith (nott . Var) + +orView :: View (Logic a) [a] +orView = "logic.orView" @> makeView (($ []) . f) (foldr ((.||.) . Var) F) + where + f (p :||: q) = (>>= f p) . f q + f (Var a) = return . (a:) + f F = return + f _ = const Nothing + +andView :: View (Logic a) [a] +andView = "logic.andView" @> makeView (($ []) . f) (foldr ((.&&.) . Var) T) + where + f (p :&&: q) = (>>= f p) . f q + f (Var a) = return . (a:) + f T = return f _ = const Nothing diff --git a/src/Domain/Math/Approximation.hs b/src/Domain/Math/Approximation.hs --- a/src/Domain/Math/Approximation.hs +++ b/src/Domain/Math/Approximation.hs @@ -1,84 +1,84 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Selection of numerical algorithms for approximations --- ------------------------------------------------------------------------------ -module Domain.Math.Approximation where - -import Data.List - -type Function = Double -> Double - -type Approximation = [Double] - ------------------------------------------------------------- --- Precision of a floating-point number - -precision :: Int -> Double -> Double -precision n = (/a) . fromInteger . round . (*a) - where a = 10 Prelude.^ max 0 n - ------------------------------------------------------------- --- Stop criteria - -within :: Double -> Approximation -> Double -within _ [] = error "within []" -within _ [x] = x -within d (x:xs@(y:_)) - | abs (x-y) <= d = x - | otherwise = within d xs - -relative :: Double -> Approximation -> Double -relative _ [] = error "relative []" -relative _ [x] = x -relative d (x:xs@(y:_)) - | abs (x-y) <= d*abs y = x - | otherwise = relative d xs - ------------------------------------------------------------- --- Root-finding algorithms - --- http://en.wikipedia.org/wiki/Bisection_method -bisection :: Function -> [Double] -> Approximation -bisection f ds = - case partition ((<= 0) . f) ds of - (lo:_, hi:_) -> run hi lo - _ -> [] - where - run hi lo - | fm <= 0 = mid : run hi mid - | otherwise = mid : run mid lo - where - mid = (hi+lo) / 2 - fm = f mid - --- http://en.wikipedia.org/wiki/Newton's_method -newton :: Function -> Function -> Double -> Approximation -newton f df x0 = iterate next x0 - where - next a - | dfa == 0 = a - | otherwise = a - f a / dfa - where - dfa = df a - ------------------------------------------------------------- --- Finding the derivative of a function - -derivative :: Double -> Function -> Function -derivative delta f x = (f (x+delta) - f (x-delta)) / (2*delta) - --- Test code -{- -same f g = sum [ abs (f x - g x) | x <- [0,0.01..6] ] - -test1 = same (derivative 0.01 sin) cos +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Selection of numerical algorithms for approximations +-- +----------------------------------------------------------------------------- +module Domain.Math.Approximation where + +import Data.List + +type Function = Double -> Double + +type Approximation = [Double] + +------------------------------------------------------------ +-- Precision of a floating-point number + +precision :: Int -> Double -> Double +precision n = (/a) . fromInteger . round . (*a) + where a = 10 Prelude.^ max 0 n + +------------------------------------------------------------ +-- Stop criteria + +within :: Double -> Approximation -> Double +within _ [] = error "within []" +within _ [x] = x +within d (x:xs@(y:_)) + | abs (x-y) <= d = x + | otherwise = within d xs + +relative :: Double -> Approximation -> Double +relative _ [] = error "relative []" +relative _ [x] = x +relative d (x:xs@(y:_)) + | abs (x-y) <= d*abs y = x + | otherwise = relative d xs + +------------------------------------------------------------ +-- Root-finding algorithms + +-- http://en.wikipedia.org/wiki/Bisection_method +bisection :: Function -> [Double] -> Approximation +bisection f ds = + case partition ((<= 0) . f) ds of + (lo:_, hi:_) -> run hi lo + _ -> [] + where + run hi lo + | fm <= 0 = mid : run hi mid + | otherwise = mid : run mid lo + where + mid = (hi+lo) / 2 + fm = f mid + +-- http://en.wikipedia.org/wiki/Newton's_method +newton :: Function -> Function -> Double -> Approximation +newton f df x0 = iterate next x0 + where + next a + | dfa == 0 = a + | otherwise = a - f a / dfa + where + dfa = df a + +------------------------------------------------------------ +-- Finding the derivative of a function + +derivative :: Double -> Function -> Function +derivative delta f x = (f (x+delta) - f (x-delta)) / (2*delta) + +-- Test code +{- +same f g = sum [ abs (f x - g x) | x <- [0,0.01..6] ] + +test1 = same (derivative 0.01 sin) cos test2 = same (derivative 0.01 cos) (negate . sin) -} diff --git a/src/Domain/Math/CleanUp.hs b/src/Domain/Math/CleanUp.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/CleanUp.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.CleanUp + ( cleanUpRelations, cleanUpRelation, cleanUpExpr + , cleanUpSimple, cleanUpView, cleanUpACView + , assocExpr, acExpr, smart, assocPlus, assocTimes + ) where + +import Common.Classes +import Common.Utils (fixpoint) +import Common.Utils.Uniplate +import Common.View +import Control.Monad +import Data.Foldable (foldMap) +import Data.List +import Data.Maybe +import Data.Ord +import Data.Ratio +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Data.SquareRoot (fromSquareRoot) +import Domain.Math.Expr +import Domain.Math.Numeric.Views (rationalView, integerView) +import Domain.Math.Power.OldViews (powerFactorViewWith) +import Domain.Math.SquareRoot.Views (squareRootViewWith) +import Prelude hiding ((^), recip) +import qualified Prelude + +---------------------------------------------------------------------- +-- Root simplification + +simplerRoot :: Rational -> Integer -> Expr +simplerRoot a b + | b < 0 = 1 ./. simplerRoot a (abs b) + | a < 0 && odd b = neg (simplerRoot (abs a) b) + | otherwise = f (numerator a) b ./. f (denominator a) b + where + f x y + | x == 0 = 0 + | y == 0 || x <= 0 = root (fromIntegral x) (fromIntegral y) + | e Prelude.^ y == x = fromIntegral e + | otherwise = root (fromIntegral x) (fromIntegral y) + where + e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y)) + +------------------------------------------------------------ +-- Cleaning up + +cleanUpSimple :: Expr -> Expr +cleanUpSimple = fixpoint (transform (smart . f)) + where + f = simplifyWith (assocPlus rationalView) sumView + +cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr) +cleanUpRelations = noDuplicates . foldMap cleanUpRelation + +cleanUpRelation :: Relation Expr -> OrList (Relation Expr) +cleanUpRelation = f . fmap cleanUpBU + where + f rel + | any falsity (universe a ++ universe b) = false + | a == b = fromBool (relationType rel `elem` equals) + | otherwise = + case (match rationalView a, match rationalView b) of + (Just r, Just s) -> fromBool (eval (relationType rel) r s) + _ -> singleton rel + where + (a, b) = (leftHandSide rel, rightHandSide rel) + + equals = + [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately] + + falsity :: Expr -> Bool + falsity (Sqrt e) = maybe False (<0) (match rationalView e) + falsity (_ :/: e) = maybe False (==0) (match rationalView e) + falsity _ = False + +-- also simplify square roots +cleanUpExpr :: Expr -> Expr +cleanUpExpr = fixpoint $ + cleanUpBU . transform (simplify (squareRootViewWith rationalView)) + +cleanUpView, cleanUpACView :: View Expr Expr +cleanUpView = makeView (return . cleanUpExpr) id +cleanUpACView = makeView (return . acExpr . cleanUpExpr) id + +-- normalize expr with associativity and commutative rules for + and * +assocExpr, acExpr :: Expr -> Expr +assocExpr = normExpr id +acExpr = normExpr sort + +normExpr :: ([Expr] -> [Expr]) -> Expr -> Expr +normExpr f = rec + where + rec expr = + case (from sumView expr, from productView expr) of + (xs, _) | length xs > 1 -> + to sumView $ f $ map rec xs + (_, (b, xs)) | length xs > 1 -> + to productView (b, f $ map rec xs) + _ -> + descend rec expr + +------------------------------------------------------------ +-- Associativity + +assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr] +assocPlus = assocOp (+) +assocTimes = assocOp (*) + +assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr] +assocOp op v = rec . map (simplify v) + where + rec (x:y:zs) = + case canonical v (op x y) of + Just a -> rec (a:zs) + Nothing -> x:rec (y:zs) + rec xs = xs + +------------------------------------------------------------ +-- Fixpoint of a bottom-up traversal + +cleanUpBU :: Expr -> Expr +cleanUpBU = {- fixpoint $ -} transform $ \e -> + simplify myView $ + fromMaybe (smart e) $ + canonical rationalView e + `mplus` + liftM (transform smart) (canonical specialSqrtOrder e) + -- Just simplify order of terms with square roots for now + `mplus` do + let f xs | length xs > 1 = return (assocPlus rationalView xs) + f _ = Nothing + canonicalWithM f sumView e + `mplus` + canonical myView e + `mplus` do + let f (b, xs) | length xs > 1 = return (b, assocTimes rationalView xs) + f _ = Nothing + canonicalWithM f simpleProductView e + where + myView = powerFactorViewWith rationalView + +specialSqrtOrder :: View Expr [Expr] +specialSqrtOrder = toView sumView >>> makeView f id + where + make = match (squareRootViewWith rationalView) + g = isNothing . fromSquareRoot . snd + f xs = do + ys <- mapM make xs + return $ map fst $ sortBy (comparing g) $ zip xs ys + +smart :: Expr -> Expr +smart (a :*: b) = a .*. b +smart (a :/: b) = a ./. b +smart expr@(Sym s [x, y]) + | isPowerSymbol s = x .^. y + | isRootSymbol s = fromMaybe expr $ + liftM2 simplerRoot (match rationalView x) (match integerView y) +smart (Negate a) = neg a +smart (a :+: b) = a .+. b +smart (a :-: b) = a .-. b +smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2 +smart e = e diff --git a/src/Domain/Math/Clipboard.hs b/src/Domain/Math/Clipboard.hs deleted file mode 100644 --- a/src/Domain/Math/Clipboard.hs +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Support for a clipboard, on which expressions can be placed. The clipboard --- is part of the environment (terms that are placed in a context) --- ------------------------------------------------------------------------------ -module Domain.Math.Clipboard - ( addToClipboard, addListToClipboard - , lookupClipboard, lookupListClipboard, removeClipboard - -- generalized interface - , addToClipboardG, addListToClipboardG - , lookupClipboardG, lookupListClipboardG - , maybeOnClipboardG - ) where - -import Common.Context -import Control.Monad -import Common.Rewriting -import Data.Maybe -import Domain.Math.Data.Relation -import Domain.Math.Expr -import qualified Data.Map as M - ---------------------------------------------------------------------- --- Expression variables (internal) - -newtype ExprVar a = ExprVar (Var Term) - -exprVar :: (Show a, IsTerm a) => String -> a -> ExprVar a -exprVar s a = ExprVar (makeVar showF readF s (toTerm a)) - where - showF = show . toExpr -- pretty-print as an Expr - readF = either (fail . show) (return . toTerm) . parseExpr - -readExprVar :: IsTerm a => ExprVar a -> ContextMonad a -readExprVar (ExprVar var) = do - term <- readVar var - maybeCM (fromTerm term) - -modifyExprVar :: IsTerm a => ExprVar a -> (a -> a) -> ContextMonad () -modifyExprVar (ExprVar var) f = - let safe h a = fromMaybe a (h a) - g = fmap (toTerm . f) . fromTerm - in modifyVar var (safe g) - ---------------------------------------------------------------------- --- Clipboard variable - -newtype Key = Key String deriving (Show, Eq, Ord) - -instance (IsTerm k, Ord k, IsTerm a) => IsTerm (M.Map k a) where - toTerm = toTerm . map (\(k, a) -> toTerm k :==: toTerm a) . M.toList - fromTerm term = do - eqs <- fromTerm term - xs <- forM eqs $ \(a :==: b) -> - liftM2 (,) (fromTerm a) (fromTerm b) - return (M.fromList xs) - -instance IsTerm Key where - toTerm (Key s) = variable s - fromTerm = liftM Key . getVariable - -clipboard :: ExprVar (M.Map Key Expr) -clipboard = exprVar "clipboard" M.empty - ---------------------------------------------------------------------- --- Interface to work with clipboard - -addToClipboard :: String -> Expr -> ContextMonad () -addToClipboard = addToClipboardG - -addListToClipboard :: [String] -> [Expr] -> ContextMonad () -addListToClipboard = addListToClipboardG - -lookupClipboard :: String -> ContextMonad Expr -lookupClipboard = lookupClipboardG - -lookupListClipboard :: [String] -> ContextMonad [Expr] -lookupListClipboard = lookupListClipboardG - -removeClipboard :: String -> ContextMonad () -removeClipboard s = - modifyExprVar clipboard (M.delete (Key s)) - ---------------------------------------------------------------------- --- Generalized interface to work with clipboard - -addToClipboardG :: IsTerm a => String -> a -> ContextMonad () -addToClipboardG s a = modifyExprVar clipboard (M.insert (Key s) (toExpr a)) - -addListToClipboardG :: IsTerm a => [String] -> [a] -> ContextMonad () -addListToClipboardG = zipWithM_ addToClipboardG - -lookupClipboardG :: IsTerm a => String -> ContextMonad a -lookupClipboardG s = do - m <- readExprVar clipboard - expr <- maybeCM (M.lookup (Key s) m) - fromExpr expr - -maybeOnClipboardG :: IsTerm a => String -> ContextMonad (Maybe a) -maybeOnClipboardG s = do - m <- readExprVar clipboard - return (M.lookup (Key s) m >>= fromExpr) - -lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a] -lookupListClipboardG = mapM lookupClipboardG diff --git a/src/Domain/Math/Data/DecimalFraction.hs b/src/Domain/Math/Data/DecimalFraction.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/DecimalFraction.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Decimal fractions: the denominator of such a fraction must a power of 10. +-- Division in the Fractional type class is not safe. +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.DecimalFraction + ( DecimalFraction, fromDouble, validDivisor, digits + ) where + +import Control.Monad +import Data.Maybe +import Data.Ratio +import Domain.Math.Safe + +-- |Data type for decimal fractions +newtype DecimalFraction = DF Rational -- Invariant: denominator is valid + deriving (Eq, Ord, Num, Real) + +instance Show DecimalFraction where + show d@(DF r) = show x ++ "." ++ replicate extra '0' ++ show y + where + digs = digits d + base = 10^digs + n = numerator (r * fromInteger base) + (x, y) = n `divMod` base + extra = digs - length (show y) + +instance Fractional DecimalFraction where + a/b = fromMaybe (error "invalid divisor") (safeDiv a b) + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + +instance SafeDiv DecimalFraction where + safeDiv (DF a) (DF b) = do + guard (validDivisor (DF b)) + liftM DF (a `safeDiv` b) + +instance SafePower DecimalFraction where + safePower x (DF r) + | denominator r /= 1 = Nothing + | y >= 0 = Just a + | otherwise = safeDiv 1 a + where + y = numerator r + a = x Prelude.^ abs y + safeRoot x y = safeRecip y >>= safePower x + +-- | Approximation of a double, with a precision of 8 digits +fromDouble :: Double -> DecimalFraction +fromDouble d = DF (fromInteger base / 10^digs) + where + digs = 8 :: Int -- maximum number of digits + base = round (d * 10^digs) :: Integer + +-- |Tests whether it is safe to divide by this fraction: it is safe to divide +-- if its numerator(!) is a product of two's and five's. +validDivisor :: DecimalFraction -> Bool +validDivisor (DF a) = validDenominator (abs (numerator a)) + +-- |number of decimal digits +digits :: DecimalFraction -> Int +digits (DF r) = head $ filter p [0..] + where + p i = 10^i `mod` denominator r == 0 + +-- local helper +validDenominator :: Integer -> Bool +validDenominator n + | n == 0 = False + | even n = validDenominator (n `div` 2) + | n `mod` 5 == 0 = validDenominator (n `div` 5) + | otherwise = n == 1 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 @@ -1,364 +1,309 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Support for mathematical intervals (open, closed, unbounded). @Intervals@ --- is a normalized (and sorted) list of intervals that supports testing for --- equality. --- ------------------------------------------------------------------------------ -module Domain.Math.Data.Interval - ( -- Data types - Intervals, Interval - -- Interval constructors - , empty, singleton, unbounded, open, closed - , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo - , lessThan, lessThanOrEqualTo - -- Inspecing an interval - , isEmpty, leftPoint, rightPoint, Endpoint(..) - -- Making intervals - , except, toList, fromList - , union, intersect, complement - , isIn, isInInterval - -- QuickChecks - , testMe - ) where - -import Common.TestSuite -import Common.Utils (commaList) -import Control.Monad -import Data.Maybe -import Test.QuickCheck - --------------------------------------------------------------------- --- Data declarations - -newtype Intervals a = IS [Interval a] - deriving Eq - -data Interval a = Empty | I (Endpoint a) (Endpoint a) - deriving Eq - -data Endpoint a = Excluding a | Including a | Unbounded - deriving Eq - -instance Show a => Show (Intervals a) where - show xs = "{ " ++ commaList (map show (toList xs)) ++ " }" - -instance Show a => Show (Interval a) where - show interval = - case interval of - Empty -> "{}" - I a b -> showLeft a ++ "," ++ showRight b - -instance Functor Endpoint where - fmap f (Excluding a) = Excluding (f a) - fmap f (Including a) = Including (f a) - fmap _ Unbounded = Unbounded - -instance Functor Interval where - fmap _ Empty = Empty - fmap f (I a b) = I (fmap f a) (fmap f b) -- function should not change order - -instance Functor Intervals where - fmap f (IS xs) = IS (map (fmap f) xs) - -showLeft, showRight :: Show a => Endpoint a -> String -showLeft (Excluding a) = '(' : show a -showLeft (Including a) = '[' : show a -showLeft Unbounded = "(-inf" -showRight (Excluding a) = show a ++ ")" -showRight (Including a) = show a ++ "]" -showRight Unbounded = "inf)" - --------------------------------------------------------------------- --- Interval constructors - -empty :: Interval a -empty = Empty - -singleton :: Ord a => a -> Interval a -singleton a = closed a a - -unbounded :: Ord a => Interval a -unbounded = makeInterval Unbounded Unbounded - -open :: Ord a => a -> a -> Interval a -open a b = makeInterval (Excluding a) (Excluding b) - -closed :: Ord a => a -> a -> Interval a -closed a b = makeInterval (Including a) (Including b) - -leftOpen :: Ord a => a -> a -> Interval a -leftOpen a b = makeInterval (Excluding a) (Including b) - -rightOpen :: Ord a => a -> a -> Interval a -rightOpen a b = makeInterval (Including a) (Excluding b) - -greaterThan :: Ord a => a -> Interval a -greaterThan a = makeInterval (Excluding a) Unbounded - -greaterThanOrEqualTo :: Ord a => a -> Interval a -greaterThanOrEqualTo a = makeInterval (Including a) Unbounded - -lessThan :: Ord a => a -> Interval a -lessThan a = makeInterval Unbounded (Excluding a) - -lessThanOrEqualTo :: Ord a => a -> Interval a -lessThanOrEqualTo a = makeInterval Unbounded (Including a) - --- local constructor -makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a -makeInterval pl pr = - case liftM2 compare (getPoint pl) (getPoint pr) of - Just LT -> I pl pr - Just EQ - | isIncluding pl && isIncluding pr -> I pl pr - | otherwise -> Empty - Just GT -> Empty - Nothing -> I pl pr - -isIncluding :: Endpoint a -> Bool -isIncluding (Including _) = True -isIncluding _ = False - -isExcluding :: Endpoint a -> Bool -isExcluding (Excluding _) = True -isExcluding _ = False - --------------------------------------------------------------------- --- Inspecting an interval - -isEmpty :: Interval a -> Bool -isEmpty Empty = True -isEmpty _ = False - -leftPoint, rightPoint :: Interval a -> Endpoint a -leftPoint (I a _) = a -leftPoint Empty = error "leftPoint Empty" -rightPoint (I _ a) = a -rightPoint Empty = error "rightPoint Empty" - --------------------------------------------------------------------- --- Combining multiple intervals - -except :: Ord a => a -> Intervals a -except a = fromList [lessThan a, greaterThan a] - -toList :: Intervals a -> [Interval a] -toList (IS xs) = xs - -fromList :: Ord a => [Interval a] -> Intervals a -fromList = foldr insert (IS []) - -insert :: Ord a => Interval a -> Intervals a -> Intervals a -insert Empty xs = xs -insert iv@(I l _) (IS xs) = rec xs - where - rec [] = IS [iv] - rec (hd:rest) = - case (hd, merge iv hd) of - (Empty, _) -> rec rest - (_, Just new) -> insert new (IS rest) - (I a _, Nothing) - | minPointLeft a l == a -> let IS tl = rec rest in IS (hd:tl) - | otherwise -> IS (iv:hd:rest) - -union :: Ord a => Intervals a -> Intervals a -> Intervals a -union xs = foldr insert xs . toList - -intersect :: Ord a => Intervals a -> Intervals a -> Intervals a -intersect (IS xs) (IS ys) = fromList (f xs ys) - where - f (a@(I _ ar):as) (b@(I _ br):bs) = inBoth a b : rest - where - rest | maxPointRight ar br == ar = f (a:as) bs - | otherwise = f as (b:bs) - f _ _ = [] - -complement :: Ord a => Intervals a -> Intervals a -complement (IS xs) = fromList (left ++ zipWith f xs (drop 1 xs) ++ right) - where - f (I _ a) (I b _) = fromMaybe Empty (liftM2 I (g a) (g b)) - f _ _ = Empty - - g (Including a) = Just (Excluding a) - g (Excluding a) = Just (Including a) - g Unbounded = Nothing - - left = case xs of - I al _:_ -> maybe [] (return . I Unbounded) (g al) - _ -> [unbounded] - right = case reverse xs of - I _ ar:_ -> maybe [] (return . flip I Unbounded) (g ar) - _ -> [unbounded] - -isIn :: Ord a => a -> Intervals a -> Bool -isIn a (IS xs) = any (isInInterval a) xs - -isInInterval :: Ord a => a -> Interval a -> Bool -isInInterval _ Empty = False -isInInterval a (I x y) = f GT x && f LT y - where - f value b = - let g c = (c==EQ && isIncluding b) || c==value - in maybe True (g . compare a) (getPoint b) - ---------------------------------------------------------------------- --- Local helper functions - -getPoint :: Endpoint a -> Maybe a -getPoint (Including a) = Just a -getPoint (Excluding a) = Just a -getPoint Unbounded = Nothing - -merge :: Ord a => Interval a -> Interval a -> Maybe (Interval a) -merge a Empty = Just a -merge Empty b = Just b -merge ia@(I al ar) ib@(I bl br) - | minPointLeft al bl /= al = merge ib ia - | otherwise = - case liftM2 compare (getPoint ar) (getPoint bl) of - Just LT -> Nothing - Just EQ - | isIncluding ar || isIncluding bl -> ok - | otherwise -> Nothing - Just GT -> ok - Nothing -> ok - where - ok = Just (I al (maxPointRight ar br)) - -inBoth :: Ord a => Interval a -> Interval a -> Interval a -inBoth _ Empty = Empty -inBoth Empty _ = Empty -inBoth (I al ar) (I bl br) = makeInterval (maxPointLeft al bl) (minPointRight ar br) - -minPointLeft, minPointRight, maxPointLeft, maxPointRight - :: Ord a => Endpoint a -> Endpoint a -> Endpoint a -minPointLeft = compareEndpoint True True -minPointRight = compareEndpoint True False -maxPointLeft = compareEndpoint False False -maxPointRight = compareEndpoint False True - -compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a -compareEndpoint b1 b2 a b = - case liftM2 compare (getPoint a) (getPoint b) of - Just LT -> x - Just EQ | p a -> x - | otherwise -> y - Just GT -> y - Nothing | b2 -> Unbounded - | x==Unbounded -> y - | otherwise -> x - where - p = if b1==b2 then isIncluding else isExcluding - (x, y) = if b1 then (a, b) else (b, a) - ---------------------------------------------------------------------- --- QuickCheck - -instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where - arbitrary = frequency - [ (2, liftM Excluding arbitrary) - , (2, liftM Including arbitrary) - , (1, return Unbounded) - ] -instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where - coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a - coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a - coarbitrary Unbounded = variant (2 :: Int) - -instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where - arbitrary = frequency - [ (1, return Empty) - , (5, liftM2 makeInterval arbitrary arbitrary) - ] -instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where - coarbitrary Empty = variant (0 :: Int) - coarbitrary (I a b) = variant (1 :: Int) . coarbitrary a . coarbitrary b - -instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where - arbitrary = do - n <- choose (0, 100) - xs <- replicateM n arbitrary - return (fromList xs) -instance (CoArbitrary a, Ord a) => CoArbitrary (Intervals a) where - coarbitrary (IS xs) = coarbitrary xs - -testMe :: TestSuite -testMe = suite "Intervals" $ do - - suite "Constructor functions" $ do - addProperty "empty" $ op0 empty (const False) - addProperty "unbounded" $ op0 unbounded (const True) - - addProperty "greater than" $ op1 greaterThan (>) - addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=) - addProperty "less than" $ op1 lessThan (<) - addProperty "less than or equal to" $ op1 lessThanOrEqualTo (<=) - addProperty "singleton" $ op1 singleton (==) - - addProperty "open" $ op2 open (<) (<) - addProperty "closed" $ op2 closed (<=) (<=) - addProperty "left open" $ op2 leftOpen (<) (<=) - addProperty "right open" $ op2 rightOpen (<=) (<) - - suite "From/to lists" $ do - addProperty "" fromTo1 - addProperty "" fromTo2 - - suite "Combinators" $ do - addProperty "except" defExcept - addProperty "union" defUnion - addProperty "intersect" defIntersect - addProperty "complement" defComplement - - suite "Combinator properties" $ do - addProperty "inverse complement" $ selfInverse complement - addProperty "transitive union" $ transitive union - addProperty "commutative union" $ commutative union - addProperty "absorption union" $ absorption union - addProperty "transitive intersect" $ transitive intersect - addProperty "commutative intersect" $ commutative intersect - addProperty "absorption intersect" $ absorption intersect - -fromTo1, fromTo2 :: Intervals Int -> Bool -fromTo1 a = fromList (toList a) == a -fromTo2 a = fromList (reverse (toList a)) == a - -defExcept :: Int -> Int -> Bool -defExcept a b = isIn a (except b) == (a/=b) - -defUnion, defIntersect :: Int -> Intervals Int -> Intervals Int -> Bool -defUnion a b c = isIn a (b `union` c) == (isIn a b || isIn a c) -defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c) - -defComplement :: Int -> Intervals Int -> Bool -defComplement a b = isIn a (complement b) == not (isIn a b) - -op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool -op0 g p a = isInInterval a g == p a - -op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool -op1 g op a b = isInInterval a (g b) == (a `op` b) - -op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool -op2 g opl opr a b c = isInInterval a (g b c) == (b `opl` a && a `opr` c) - -transitive :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Intervals Int -> Bool -transitive op a b c = op a (op b c) == op (op a b) c - -commutative :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Bool -commutative op a b = op a b == op b a - -absorption :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Bool -absorption op a = op a a == a - -selfInverse :: (Intervals Int -> Intervals Int) -> Intervals Int -> Bool -selfInverse op a = op (op a) == a +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for mathematical intervals (open, closed, unbounded). @Interval@ +-- is a normalized (and sorted) list of intervals that supports testing for +-- equality (provided that there is a valid ordering on the elements). +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.Interval + ( -- * Data types + Interval, Endpoint(..) + -- * Interval constructors + , empty, point, unbounded, open, closed + , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo + , lessThan, lessThanOrEqualTo, true, false + -- * Interval combinators + , except, union, intersect, complement + -- * Inspecing an interval + , segments, isIn + -- * QuickChecks + , testMe + ) where + +import Common.Algebra.Boolean +import Common.Algebra.Law +import Common.Utils (commaList) +import Common.Utils.TestSuite +import Control.Monad +import Data.Maybe +import Test.QuickCheck + +-------------------------------------------------------------------- +-- Data declarations + +newtype Interval a = I [Segment a] + deriving Eq + +data Segment a = S (Endpoint a) (Endpoint a) + deriving Eq + +data Endpoint a = Excluding a | Including a | Unbounded + deriving Eq + +instance Ord a => BoolValue (Interval a) where + fromBool b = if b then unbounded else empty + isTrue = (==true) + isFalse = (==false) + +instance Ord a => Boolean (Interval a) where + (<&&>) = intersect + (<||>) = union + complement = complementIntervals + +instance Show a => Show (Interval a) where + show (I xs) = "{ " ++ commaList (map show xs) ++ " }" + +instance Show a => Show (Segment a) where + show (S a b) = showLeft a ++ "," ++ showRight b + +instance Functor Endpoint where + fmap f (Excluding a) = Excluding (f a) + fmap f (Including a) = Including (f a) + fmap _ Unbounded = Unbounded + +showLeft, showRight :: Show a => Endpoint a -> String +showLeft (Excluding a) = '(' : show a +showLeft (Including a) = '[' : show a +showLeft Unbounded = "(-inf" +showRight (Excluding a) = show a ++ ")" +showRight (Including a) = show a ++ "]" +showRight Unbounded = "inf)" + +-------------------------------------------------------------------- +-- Interval constructors + +empty :: Interval a +empty = I [] + +point :: a -> Interval a +point a = I [S (Including a) (Including a)] + +unbounded :: Ord a => Interval a +unbounded = makeInterval Unbounded Unbounded + +open :: Ord a => a -> a -> Interval a +open a b = makeInterval (Excluding a) (Excluding b) + +closed :: Ord a => a -> a -> Interval a +closed a b = makeInterval (Including a) (Including b) + +leftOpen :: Ord a => a -> a -> Interval a +leftOpen a b = makeInterval (Excluding a) (Including b) + +rightOpen :: Ord a => a -> a -> Interval a +rightOpen a b = makeInterval (Including a) (Excluding b) + +greaterThan :: Ord a => a -> Interval a +greaterThan a = makeInterval (Excluding a) Unbounded + +greaterThanOrEqualTo :: Ord a => a -> Interval a +greaterThanOrEqualTo a = makeInterval (Including a) Unbounded + +lessThan :: Ord a => a -> Interval a +lessThan a = makeInterval Unbounded (Excluding a) + +lessThanOrEqualTo :: Ord a => a -> Interval a +lessThanOrEqualTo a = makeInterval Unbounded (Including a) + +-- local constructor +makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a +makeInterval pl pr = maybe empty (I . return) (makeSegment pl pr) + +makeSegment :: Ord a => Endpoint a -> Endpoint a -> Maybe (Segment a) +makeSegment pl pr = + case liftM2 compare (getPoint pl) (getPoint pr) of + Just EQ + | isExcluding pl -> Nothing + | isExcluding pr -> Nothing + Just GT -> Nothing + _ -> Just (S pl pr) + +isIncluding :: Endpoint a -> Bool +isIncluding (Including _) = True +isIncluding _ = False + +isExcluding :: Endpoint a -> Bool +isExcluding (Excluding _) = True +isExcluding _ = False + +-------------------------------------------------------------------- +-- Inspecting an interval + +segments :: Interval a -> [(Endpoint a, Endpoint a)] +segments (I xs) = [ (a, b) | S a b <- xs ] + +-------------------------------------------------------------------- +-- Combining multiple intervals + +except :: Ord a => a -> Interval a +except a = lessThan a <||> greaterThan a + +insert :: Ord a => Segment a -> Interval a -> Interval a +insert ia (I xs) = I (rec ia xs) + where + rec iv [] = [iv] + rec iv@(S a _) (hd@(S b _):rest) = + case merge iv hd of + Just new -> rec new rest + Nothing + | minPointLeft b a == b -> hd:rec iv rest + | otherwise -> iv:hd:rest + +union :: Ord a => Interval a -> Interval a -> Interval a +union xs (I ys) = foldr insert xs ys + +intersect :: Ord a => Interval a -> Interval a -> Interval a +intersect (I xs) (I ys) = I (f xs ys) + where + f (a@(S _ ar):as) (b@(S _ br):bs) = + let cond = maxPointRight ar br == ar + rest | cond = f (a:as) bs + | otherwise = f as (b:bs) + in maybe id (:) (inBoth a b) rest + f _ _ = [] + +complementIntervals :: Ord a => Interval a -> Interval a +complementIntervals (I xs) + | null xs = unbounded + | otherwise = I $ catMaybes $ + left (head xs) : zipWith f xs (drop 1 xs) ++ [right (last xs)] + where + f (S _ a) (S b _) = liftM2 S (g a) (g b) + + g (Including a) = Just (Excluding a) + g (Excluding a) = Just (Including a) + g Unbounded = Nothing + + left (S al _) = fmap (S Unbounded) (g al) + right (S _ ar) = fmap (flip S Unbounded) (g ar) + +isIn :: Ord a => a -> Interval a -> Bool +isIn a (I xs) = any p xs + where + p (S x y) = f GT x && f LT y + f value b = + let g c = (c==EQ && isIncluding b) || c==value + in maybe True (g . compare a) (getPoint b) + +--------------------------------------------------------------------- +-- Local helper functions + +getPoint :: Endpoint a -> Maybe a +getPoint (Including a) = Just a +getPoint (Excluding a) = Just a +getPoint Unbounded = Nothing + +merge :: Ord a => Segment a -> Segment a -> Maybe (Segment a) +merge ia@(S al ar) ib@(S bl br) + | minPointLeft al bl /= al = merge ib ia + | otherwise = + case liftM2 compare (getPoint ar) (getPoint bl) of + Just LT -> Nothing + Just EQ | isExcluding ar && isExcluding bl -> Nothing + _ -> Just (S al (maxPointRight ar br)) + +inBoth :: Ord a => Segment a -> Segment a -> Maybe (Segment a) +inBoth (S al ar) (S bl br) = + makeSegment (maxPointLeft al bl) (minPointRight ar br) + +minPointLeft, minPointRight, maxPointLeft, maxPointRight + :: Ord a => Endpoint a -> Endpoint a -> Endpoint a +minPointLeft = compareEndpoint True True +minPointRight = compareEndpoint True False +maxPointLeft = compareEndpoint False False +maxPointRight = compareEndpoint False True + +compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a +compareEndpoint b1 b2 a b = + case liftM2 compare (getPoint a) (getPoint b) of + Just LT -> x + Just EQ | p a -> x + | otherwise -> y + Just GT -> y + Nothing | b2 -> Unbounded + | x==Unbounded -> y + | otherwise -> x + where + p = if b1==b2 then isIncluding else isExcluding + (x, y) = if b1 then (a, b) else (b, a) + +--------------------------------------------------------------------- +-- QuickCheck + +instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where + arbitrary = frequency + [ (2, liftM Excluding arbitrary) + , (2, liftM Including arbitrary) + , (1, return Unbounded) + ] +instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where + coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a + coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a + coarbitrary Unbounded = variant (2 :: Int) + +instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where + arbitrary = do + n <- choose (0, 100) + xs <- replicateM n (liftM2 makeInterval arbitrary arbitrary) + return (ors xs) + +instance (CoArbitrary a, Ord a) => CoArbitrary (Segment a) where + coarbitrary (S a b) = coarbitrary a . coarbitrary b + +instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where + coarbitrary (I xs) = coarbitrary xs + +testMe :: TestSuite +testMe = suite "Intervals" $ do + + suite "Constructor functions" $ do + addProperty "empty" $ op0 empty (const False) + addProperty "unbounded" $ op0 unbounded (const True) + + addProperty "greater than" $ op1 greaterThan (>) + addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=) + addProperty "less than" $ op1 lessThan (<) + addProperty "less than or equal to" $ op1 lessThanOrEqualTo (<=) + addProperty "point " $ op1 point (==) + + addProperty "open" $ op2 open (<) (<) + addProperty "closed" $ op2 closed (<=) (<=) + addProperty "left open" $ op2 leftOpen (<) (<=) + addProperty "right open" $ op2 rightOpen (<=) (<) + + suite "Combinators" $ do + addProperty "except" defExcept + addProperty "union" defUnion + addProperty "intersect" defIntersect + addProperty "complement" defComplement + + suite "Boolean algebra" $ + forM_ (booleanLaws :: [Law (Interval Int)]) $ \p -> + addProperty (show p) p + +defExcept :: Int -> Int -> Bool +defExcept a b = isIn a (except b) == (a/=b) + +defUnion, defIntersect :: Int -> Interval Int -> Interval Int -> Bool +defUnion a b c = isIn a (b `union` c) == (isIn a b || isIn a c) +defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c) + +defComplement :: Int -> Interval Int -> Bool +defComplement a b = isIn a (complement b) == not (isIn a b) + +op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool +op0 g p a = isIn a g == p a + +op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool +op1 g op a b = isIn a (g b) == (a `op` b) + +op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool +op2 g opl opr a b c = isIn a (g b c) == (b `opl` a && a `opr` c) diff --git a/src/Domain/Math/Data/MixedFraction.hs b/src/Domain/Math/Data/MixedFraction.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/MixedFraction.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Signed mixed fractions (also known as mixed numbers): +-- for example, 5[1/4] or -3[2/5] +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.MixedFraction + ( MixedFraction, wholeNumber, fractionPart, numerator, denominator + ) where + +import qualified Data.Ratio as R + +newtype MixedFraction = MF { unMF :: Rational } + deriving (Eq, Ord, Num, Fractional, Real, RealFrac) + +instance Show MixedFraction where + show mf + | b == 0 = sign ++ show a + | a == 0 = sign ++ show b ++ "/" ++ show c + | otherwise = sign ++ show a ++ "[" ++ show b ++ "/" ++ show c ++ "]" + where + (a, b, c) = (wholeNumber mf, numerator mf, denominator mf) + sign = if mf < 0 then "-" else "" + +-- | Always positive +wholeNumber :: MixedFraction -> Integer +wholeNumber = fst . properMF + +-- | Always positive +fractionPart :: MixedFraction -> Rational +fractionPart = snd . properMF + +-- | Always positive +numerator :: MixedFraction -> Integer +numerator = R.numerator . fractionPart + +-- | Always positive +denominator :: MixedFraction -> Integer +denominator = R.denominator . fractionPart + +-- local helper +properMF :: MixedFraction -> (Integer, Rational) +properMF = properFraction . abs . unMF diff --git a/src/Domain/Math/Data/OrList.hs b/src/Domain/Math/Data/OrList.hs --- a/src/Domain/Math/Data/OrList.hs +++ b/src/Domain/Math/Data/OrList.hs @@ -1,138 +1,146 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Data.OrList - ( OrList - , orList, (\/), true, false - , isTrue, isFalse - , disjunctions, normalize, idempotent, fromBool - , oneDisjunct, orListView - ) where - -import Common.View -import Control.Monad -import Common.Classes -import Common.Rewriting -import qualified Domain.Logic.Formula as Logic -import Domain.Logic.Formula (Logic((:||:))) -import Test.QuickCheck -import Data.List (intersperse, nub, sort) - ------------------------------------------------------------- --- Data type - -data OrList a = T | OrList [a] - deriving (Ord, Eq) - ------------------------------------------------------------- --- Functions - -orList :: [a] -> OrList a -orList = OrList - -true, false :: OrList a -true = T -false = OrList [] - -isTrue :: OrList a -> Bool -isTrue T = Prelude.True -isTrue _ = False - -isFalse :: OrList a -> Bool -isFalse (OrList []) = True -isFalse _ = False - -disjunctions :: OrList a -> Maybe [a] -disjunctions T = Nothing -disjunctions (OrList xs) = Just xs - -(\/) :: OrList a -> OrList a -> OrList a -p \/ q = maybe T orList (liftM2 (++) (disjunctions p) (disjunctions q)) - --- | Sort the propositions and remove duplicates -normalize :: Ord a => OrList a -> OrList a -normalize T = T -normalize (OrList xs) = OrList (nub $ sort xs) - --- | Remove duplicates -idempotent :: Eq a => OrList a -> OrList a -idempotent T = T -idempotent (OrList xs) = OrList (nub xs) - -oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a) -oneDisjunct f xs = - case disjunctions xs of - Just [a] -> f a - _ -> fail "oneDisjunct" - -fromBool :: Bool -> OrList a -fromBool b = if b then true else false - ------------------------------------------------------------- --- Instances - --- local helper -joinOr :: OrList (OrList a) -> OrList a -joinOr = maybe T (foldr (\/) false) . disjunctions - -instance Rewrite a => Rewrite (OrList a) - -instance Functor OrList where - fmap _ T = T - fmap f (OrList xs) = OrList (map f xs) - -instance Monad OrList where - return = OrList . return - m >>= f = joinOr (fmap f m) - -instance Switch OrList where - switch T = return T - switch (OrList xs) = liftM orList (sequence xs) - -instance Crush OrList where - crush T = [] - crush (OrList xs) = xs - -instance IsTerm a => IsTerm (OrList a) where - toTerm = toTerm . build orListView - fromTerm expr = fromTerm expr >>= matchM orListView - -instance Arbitrary a => Arbitrary (OrList a) where - arbitrary = do - n <- choose (1, 3) - xs <- vector n - return (OrList xs) -instance CoArbitrary a => CoArbitrary (OrList a) where - coarbitrary T = variant (0 :: Int) - coarbitrary (OrList xs) = variant (1 :: Int) . coarbitrary xs - -instance Show a => Show (OrList a) where - show T = "true" - show (OrList xs) - | null xs = "false" - | otherwise = unwords (intersperse "or" (map show xs)) - ------------------------------------------------------------- --- View to the logic data type - -orListView :: View (Logic a) (OrList a) -orListView = makeView f g - where - f p = case p of - Logic.Var a -> return (return a) - Logic.T -> return true - Logic.F -> return false - a :||: b -> liftM2 (\/) (f a) (f b) - _ -> Nothing - g xs = case disjunctions xs of - Nothing -> Logic.T - Just [] -> Logic.F - Just ys -> foldr1 (:||:) (map Logic.Var ys) +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.OrList + ( OrList, OrSet, true, false, (<>) + , isTrue, isFalse, fromBool, toOrList + , noDuplicates, catOrList + , oneDisjunct, orListView, orSetView + ) where + +import Common.Algebra.Boolean +import Common.Algebra.CoGroup +import Common.Algebra.Group +import Common.Classes +import Common.Rewriting +import Common.View +import Control.Applicative +import Control.Monad (liftM2) +import Data.Foldable (Foldable, foldMap, toList) +import Data.List +import Data.Traversable (Traversable, traverse) +import Domain.Logic.Formula (Logic((:||:))) +import Test.QuickCheck +import qualified Data.Set as S +import qualified Domain.Logic.Formula as Logic + +instance Functor OrList where + fmap f (OrList a) = OrList (fmap (map f) a) + +instance Foldable OrList where + foldMap f (OrList a) = maybe mempty (foldMap f) (fromWithZero a) + +instance Traversable OrList where + traverse f (OrList a) = + maybe (pure mzero) (liftA toOrList . traverse f) (fromWithZero a) + +------------------------------------------------------------ +-- OrList data type + +newtype OrList a = OrList (WithZero [a]) deriving + (Eq, Ord, Monoid, MonoidZero, CoMonoid, CoMonoidZero) + +instance BoolValue (OrList a) where + fromBool b = if b then mzero else mempty + isTrue = isMonoidZero + isFalse = isEmpty + +instance Container OrList where + singleton = OrList . pure . singleton + getSingleton (OrList a) = fromWithZero a >>= getSingleton + +instance IsTerm a => IsTerm (OrList a) where + toTerm = toTerm . build orListView + fromTerm expr = fromTerm expr >>= matchM orListView + +instance Arbitrary a => Arbitrary (OrList a) where + arbitrary = do + n <- choose (1, 3) + xs <- vector n + return (toOrList xs) + +instance Show a => Show (OrList a) where + show xs | isTrue xs = "true" + | isFalse xs = "false" + | otherwise = f xs + where + f = unwords . intersperse "or" . map show . toList + +------------------------------------------------------------ +-- Functions + +-- | Remove duplicates +noDuplicates :: Eq a => OrList a -> OrList a +noDuplicates (OrList a) = OrList (fmap nub a) + +oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a) +oneDisjunct f (OrList a) = + case fromWithZero a of + Just [x] -> f x + _ -> fail "oneDisjunct" + +------------------------------------------------------------ +-- OrSet data type + +newtype OrSet a = OrSet (WithZero (S.Set a)) deriving + (Eq, Ord, Monoid, MonoidZero, CoMonoid, CoMonoidZero) + +instance (Show a, Ord a) => Show (OrSet a) where + show = show . build orSetView + +instance Ord a => BoolValue (OrSet a) where + fromBool b = if b then mzero else mempty + isTrue = isMonoidZero + isFalse = isEmpty + +instance Container OrSet where + singleton = OrSet . pure . singleton + getSingleton (OrSet a) = fromWithZero a >>= getSingleton + +------------------------------------------------------------ +-- View to the logic data type + +toOrList :: [a] -> OrList a +toOrList = mconcat . map singleton + +orListView :: View (Logic a) (OrList a) +orListView = makeView f g + where + f p = case p of + Logic.Var a -> return (singleton a) + Logic.T -> return true + Logic.F -> return false + a :||: b -> liftM2 mappend (f a) (f b) + _ -> Nothing + g = fromOr . foldOrListWith (Or . Logic.Var) + +orSetView :: Ord a => View (OrList a) (OrSet a) +orSetView = makeView (Just . f) g + where + f (OrList xs) = OrSet (fmap S.fromList xs) + g (OrSet xs) = OrList (fmap S.toList xs) + +foldOrList :: MonoidZero a => OrList a -> a +foldOrList xs + | isTrue xs = mzero + | isFalse xs = mempty + | otherwise = foldr1 (<>) (toList xs) + +foldOrListWith :: MonoidZero b => (a -> b) -> OrList a -> b +foldOrListWith f = foldOrList . fmap f + +{- +foldOrListF :: (MonoidZero (f a), Container f) => OrList a -> f a +foldOrListF = foldOrListWith to -} + +catOrList :: OrList (OrList a) -> OrList a +catOrList = foldOrList diff --git a/src/Domain/Math/Data/Polynomial.hs b/src/Domain/Math/Data/Polynomial.hs --- a/src/Domain/Math/Data/Polynomial.hs +++ b/src/Domain/Math/Data/Polynomial.hs @@ -1,216 +1,253 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Data.Polynomial - ( Polynomial, var, con, raise, power, scale - , degree, lowestDegree, coefficient, terms - , isMonic, toMonic, isRoot, positiveRoots, negativeRoots - , derivative, eval, division, longDivision, polynomialGCD - , factorize - ) where - -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.Char -import Control.Monad -import Common.Classes -import Data.List (nub) -import Data.Ratio (approxRational) -import Domain.Math.Approximation (newton, within) - --- Invariants: all keys are non-negative, all values are non-zero -newtype Polynomial a = P (IM.IntMap a) deriving Eq - -instance Num a => Show (Polynomial a) where - show (P m) = - let f (n, a) = sign (one (show a ++ g n)) - g n = concat $ [ "x" | n > 0 ] ++ [ '^' : show n | n > 1 ] - one ('1':xs@('x':_)) = xs - one ('-':'1':xs@('x':_)) = xs - one xs = xs - sign ('-':xs) = " - " ++ xs - sign xs = " + " ++ xs - fix xs = case dropWhile isSpace xs of - '+':ys -> dropWhile isSpace ys - '-':ys -> '-':dropWhile isSpace ys - ys -> ys - in "f(x) = " ++ - if IM.null m then "0" else - fix (concatMap f (reverse (IM.toList m))) - --- the Functor instance does not maintain the invariant -instance Functor Polynomial where - fmap f (P m) = P (IM.map f m) - -instance Switch Polynomial where - switch (P m) = liftM P (switch m) - -instance Num a => Num (Polynomial a) where - P m1 + P m2 = P (IM.filter (/= 0) (IM.unionWith (+) m1 m2)) - p * P m2 = IM.foldWithKey op 0 m2 - where op n a m = raise n (scale a p) + m - negate = fmap negate - fromInteger n - | n == 0 = P IM.empty - | otherwise = P (IM.singleton 0 (fromInteger n)) - -- not defined for polynomials - abs = error "abs not defined for polynomials" - signum = error "signum not defined for polynomials" - --- a single variable (such as "x") -var :: Num a => Polynomial a -var = P (IM.singleton 1 1) - -con :: a -> Polynomial a -con = P . IM.singleton 0 - --- | Raise all powers by a constant (discarding negative exponents) -raise :: Int -> Polynomial a -> Polynomial a -raise i p@(P m) - | i > 0 = P $ IM.fromAscList [ (n+i, a) | (n, a) <- IM.toList m ] - | i == 0 = p - | otherwise = P $ IM.fromAscList [ (n+i, a) | (n, a) <- IM.toList m, n+i>=0 ] - -power :: Num a => Polynomial a -> Int -> Polynomial a -power _ 0 = 1 -power p n = p * power p (n-1) - -scale :: Num a => a -> Polynomial a -> Polynomial a -scale a p = if a==0 then 0 else fmap (*a) p - ------------------------------------------------- - -degree :: Polynomial a -> Int -degree (P m) - | IS.null is = 0 - | otherwise = IS.findMax is - where is = IM.keysSet m - -lowestDegree :: Polynomial a -> Int -lowestDegree (P m) - | IS.null is = 0 - | otherwise = IS.findMin is - where is = IM.keysSet m - - -coefficient :: Num a => Int -> Polynomial a -> a -coefficient n (P m) = IM.findWithDefault 0 n m - -terms :: Polynomial a -> [(a, Int)] -terms (P m) = [ (a, n) | (n, a) <- IM.toList m ] - -isMonic :: Num a => Polynomial a -> Bool -isMonic p = coefficient (degree p) p == 1 - -toMonic :: Fractional a => Polynomial a -> Polynomial a -toMonic p = scale (recip a) p - where a = coefficient (degree p) p - -isRoot :: Num a => Polynomial a -> a -> Bool -isRoot p a = eval p a == 0 - --- Returns the maximal number of positive roots (Descartes theorem) --- Multiple roots are counted separately -positiveRoots :: Num a => Polynomial a -> Int -positiveRoots (P m) = signChanges (IM.elems m) - --- Returns the maximal number of negative roots (Descartes theorem) --- Multiple roots are counted separately -negativeRoots :: Num a => Polynomial a -> Int -negativeRoots (P m) = signChanges (flipOdd (IM.elems m)) - where - flipOdd (x:y:zs) = x:negate y:flipOdd zs - flipOdd xs = xs - -signChanges :: Num a => [a] -> Int -signChanges = f . map signum - where - f (x:xs@(hd:_)) = if x==hd then f xs else 1 + f xs - f _ = 0 - ------------------------------------------------- - -derivative :: Num a => Polynomial a -> Polynomial a -derivative (P m) = P $ IM.fromAscList - [ (n-1, fromIntegral n*a) | (n, a) <- IM.toList m, n > 0 ] - -eval :: Num a => Polynomial a -> a -> a -eval (P m) x = sum [ a * x^n | (n, a) <- IM.toList m ] - --- polynomial division, no remainder -division :: Fractional a => Polynomial a -> Polynomial a -> Maybe (Polynomial a) -division p1 p2 - | degree p1 < degree p2 = Nothing - | b==0 = return a - | otherwise = Nothing - where - (a, b) = longDivision p1 p2 - --- polynomial long division -longDivision :: Fractional a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) -longDivision p1 p2 = monicLongDivision (scale (recip a) p1) (scale (recip a) p2) - where a = coefficient (degree p2) p2 - --- polynomial long division, where p2 is monic -monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) -monicLongDivision p1 p2 - | d1 >= d2 && isMonic p2 = (toP quotient, toP remainder) - | otherwise = error $ "invalid monic division" ++ show (p1, p2) - where - d1 = degree p1 - d2 = degree p2 - xs = map (`coefficient` p1) [d1, d1-1 .. 0] - ys = drop 1 $ map (negate . (`coefficient` p2)) [d2, d2-1 .. 0] - - (quotient, remainder) = rec [] xs - toP = P . IM.filter (/= 0) . IM.fromAscList . zip [0..] - - rec acc (a:as) | length as >= length ys = - rec (a:acc) (zipWith (+) (map (*a) ys ++ repeat 0) as) - rec acc as = (acc, reverse as) - --- use polynomial long division to compute the greatest common factor --- of the polynomials -polynomialGCD :: Fractional a => Polynomial a -> Polynomial a -> Polynomial a -polynomialGCD x y - | degree y > degree x = rec y x - | otherwise = rec x y - where - rec a b - | b == 0 = a - | otherwise = rec b (snd (longDivision a b)) - ------------------------- - -factorize :: Polynomial Rational -> [Polynomial Rational] -factorize p - | degree p <= 1 = [p] - | l > 0 = power var l : factorize (raise (-l) p) - | otherwise = - case pairs of - (p1,p2):_ -> factorize p1 ++ factorize p2 - [] -> [p] - where - l = snd (head (terms p)) - pairs = [ (p1, p2) - | a <- candidateRoots p - , isRoot p a - , let p1 = var - con a - , Just p2 <- [division p p1] - ] - -candidateRoots :: Polynomial Rational -> [Rational] -candidateRoots p = nub (map (`approxRational` 0.0001) xs) - where - f = eval (fmap fromRational p) - df = eval (fmap fromRational (derivative p)) - xs = nub (map (within 0.0001 . take 10 . newton f df) startList) - startList = [0, 3, -3, 10, -10, 100, -100] +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.Polynomial + ( Polynomial, var, con, raise + , degree, lowestDegree, coefficient, terms + , isMonic, toMonic, isRoot, positiveRoots, negativeRoots + , derivative, eval, longDivision, polynomialGCD + , factorize + ) where + +import Common.Classes +import Control.Applicative (Applicative, (<$>), liftA) +import Control.Monad +import Data.Char +import Data.Foldable (Foldable, foldMap) +import Data.List (nub) +import Data.Ratio (approxRational) +import Data.Traversable (Traversable, sequenceA) +import Domain.Math.Approximation (newton, within) +import Domain.Math.Safe +import Test.QuickCheck hiding (within) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +------------------------------------------------------------------ +-- Data type: +-- Invariant: all keys are non-negative, all values are non-zero +-- (note that the second part of the invariant (zero values) +-- can be violated using the functor instance) + +newtype Polynomial a = P { unsafeP :: IM.IntMap a } + +invariant :: Num a => IM.IntMap a -> IM.IntMap a +invariant = IM.filterWithKey (\n a -> n >= 0 && a /= 0) + +makeP :: Num a => IM.IntMap a -> Polynomial a +makeP = P . invariant + +unP :: Num a => Polynomial a -> IM.IntMap a +unP = invariant . unsafeP + +------------------------------------------------------------------- +-- Instances + +instance Num a => Eq (Polynomial a) where + p1 == p2 = unP p1 == unP p2 + +instance Num a => Show (Polynomial a) where + show p + | p ==0 = "f(x) = 0" + | otherwise = "f(x) = " ++ fix (concatMap f (reverse (IM.toList (unP p)))) + where + f (n, a) = sign (one (show a ++ g n)) + g n = concat $ [ "x" | n > 0 ] ++ [ '^' : show n | n > 1 ] + one ('1':xs@('x':_)) = xs + one ('-':'1':xs@('x':_)) = xs + one xs = xs + sign ('-':xs) = " - " ++ xs + sign xs = " + " ++ xs + fix xs = case dropWhile isSpace xs of + '+':ys -> dropWhile isSpace ys + '-':ys -> '-':dropWhile isSpace ys + ys -> ys + +instance Fractional a => SafeDiv (Polynomial a) where + -- polynomial division, no remainder + safeDiv p1 p2 + | p2==0 = Nothing + | degree p1 < degree p2 = Nothing + | b==0 = return a + | otherwise = Nothing + where + (a, b) = longDivision p1 p2 + +-- the Functor instance does not maintain the invariant +instance Functor Polynomial where + fmap f = P . IM.map f . unsafeP + +instance Foldable Polynomial where + foldMap f = foldMap f . unsafeP + +instance Traversable Polynomial where + sequenceA = liftA P . sequenceIntMap . unsafeP + +instance Num a => Num (Polynomial a) where + p1 + p2 = makeP $ IM.unionWith (+) (unP p1) (unP p2) + p1 * p2 = makeP $ foldr (uncurry op) IM.empty list + where + op = IM.insertWith (+) + list = [ (i+j, a*b) | (a, i) <- terms p1, (b, j) <- terms p2 ] + negate = fmap negate + fromInteger = makeP . IM.singleton 0 . fromInteger + -- not defined for polynomials + abs = error "abs not defined for polynomials" + signum = error "signum not defined for polynomials" + +instance (Arbitrary a, Num a) => Arbitrary (Polynomial a) where + arbitrary = do + d <- choose (0, 5) + let f n x = con x * var ^ n + liftM (sum . zipWith f [0::Int ..]) (vector (d+1)) + +------------------------------------------------------------------- +-- Functions on polynomials + +-- a single variable (such as "x") +var :: Num a => Polynomial a +var = makeP (IM.singleton 1 1) + +con :: Num a => a -> Polynomial a +con = makeP . IM.singleton 0 + +-- | Raise all powers by a constant (discarding negative exponents) +raise :: Num a => Int -> Polynomial a -> Polynomial a +raise i = makeP . IM.fromAscList . map (mapFirst (+i)) . IM.toList . unP + +------------------------------------------------ + +degree :: Num a => Polynomial a -> Int +degree p + | IS.null is = 0 + | otherwise = IS.findMax is + where is = IM.keysSet (unP p) + +lowestDegree :: Num a => Polynomial a -> Int +lowestDegree p + | IS.null is = 0 + | otherwise = IS.findMin is + where is = IM.keysSet (unP p) + +coefficient :: Num a => Int -> Polynomial a -> a +coefficient n = IM.findWithDefault 0 n . unP + +terms :: Num a => Polynomial a -> [(a, Int)] +terms p = [ (a, n) | (n, a) <- IM.toList (unP p) ] + +isMonic :: Num a => Polynomial a -> Bool +isMonic p = coefficient (degree p) p == 1 + +toMonic :: Fractional a => Polynomial a -> Polynomial a +toMonic p = con (recip a) * p + where a = coefficient (degree p) p + +isRoot :: Num a => Polynomial a -> a -> Bool +isRoot p a = eval p a == 0 + +-- Returns the maximal number of positive roots (Descartes theorem) +-- Multiple roots are counted separately +positiveRoots :: Num a => Polynomial a -> Int +positiveRoots = signChanges . IM.elems . unP + +-- Returns the maximal number of negative roots (Descartes theorem) +-- Multiple roots are counted separately +negativeRoots :: Num a => Polynomial a -> Int +negativeRoots = signChanges . flipOdd . IM.elems . unP + where + flipOdd (x:y:zs) = x:negate y:flipOdd zs + flipOdd xs = xs + +signChanges :: Num a => [a] -> Int +signChanges = f . map signum + where + f (x:xs@(hd:_)) = if x==hd then f xs else 1 + f xs + f _ = 0 + +------------------------------------------------ + +derivative :: Num a => Polynomial a -> Polynomial a +derivative p = makeP $ IM.fromAscList + [ (n-1, fromIntegral n*a) | (n, a) <- IM.toList (unP p) ] + +eval :: Num a => Polynomial a -> a -> a +eval p x = sum [ a * x^n | (n, a) <- IM.toList (unP p) ] + +-- polynomial long division +longDivision :: Fractional a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) +longDivision p1 p2 = monicLongDivision (f p1) (f p2) + where + f p = con (recip a) * p + a = coefficient (degree p2) p2 + +-- polynomial long division, where p2 is monic +monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) +monicLongDivision p1 p2 + | d1 >= d2 && isMonic p2 = (toP quotient, toP remainder) + | otherwise = error $ "invalid monic division" ++ show (p1, p2) + where + d1 = degree p1 + d2 = degree p2 + xs = map (`coefficient` p1) [d1, d1-1 .. 0] + ys = drop 1 $ map (negate . (`coefficient` p2)) [d2, d2-1 .. 0] + + (quotient, remainder) = rec [] xs + toP = makeP . IM.fromAscList . zip [0..] + + rec acc (a:as) | length as >= length ys = + rec (a:acc) (zipWith (+) (map (*a) ys ++ repeat 0) as) + rec acc as = (acc, reverse as) + +-- use polynomial long division to compute the greatest common factor +-- of the polynomials +polynomialGCD :: Fractional a => Polynomial a -> Polynomial a -> Polynomial a +polynomialGCD x y + | degree y > degree x = rec y x + | otherwise = rec x y + where + rec a b + | b == 0 = a + | otherwise = rec b (snd (longDivision a b)) + +------------------------ + +factorize :: Polynomial Rational -> [Polynomial Rational] +factorize p + | degree p <= 1 = [p] + | l > 0 = var ^ l : factorize (raise (-l) p) + | otherwise = + case pairs of + (p1,p2):_ -> factorize p1 ++ factorize p2 + [] -> [p] + where + l = snd (head (terms p)) + pairs = [ (p1, p2) + | a <- candidateRoots p + , isRoot p a + , let p1 = var - con a + , Just p2 <- [safeDiv p p1] + ] + +candidateRoots :: Polynomial Rational -> [Rational] +candidateRoots p = nub (map (`approxRational` 0.0001) xs) + where + f = eval (fmap fromRational p) + df = eval (fmap fromRational (derivative p)) + xs = nub (map (within 0.0001 . take 10 . newton f df) startList) + startList = [0, 3, -3, 10, -10, 100, -100] + +-- TODO: replace me by sequenceA +-- This definition is for backwards compatibility. In older versions of IntMap, +-- the instance for Traversable is lacking. +sequenceIntMap :: Applicative m => IM.IntMap (m a) -> m (IM.IntMap a) +sequenceIntMap m = IM.fromDistinctAscList <$> zip ks <$> sequenceA as + where + (ks, as) = unzip (IM.toList m) diff --git a/src/Domain/Math/Data/PrimeFactors.hs b/src/Domain/Math/Data/PrimeFactors.hs --- a/src/Domain/Math/Data/PrimeFactors.hs +++ b/src/Domain/Math/Data/PrimeFactors.hs @@ -1,176 +1,173 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Data.PrimeFactors - ( PrimeFactors - , factors, multiplicity, coprime - , square, power, splitPower - , primes, greatestPower, allPowers - ) where - -import qualified Data.IntMap as IM -import Common.Utils -import Control.Monad -import Data.Maybe - -------------------------------------------------------------- --- Representation - --- Invariants: --- * Keys in map are prime numbers only (exception: representation of 0) --- * Elements in map are positive (non-zero) --- * Zero is represented by [(0,1)] (since 0^1 equals 0) --- * The number can be negative, in which case we use the factors of --- its absolute value -data PrimeFactors = PF Integer Factors - -type Factors = IM.IntMap Int - -------------------------------------------------------------- --- Conversion to and from factors - -toFactors :: Integer -> Factors -toFactors a - | a > 0 = rec primes a - | a < 0 = rec primes (-a) - | otherwise = IM.singleton 0 1 - where - rec [] n = IM.singleton (fromIntegral n) 1 - rec (p:ps) n - | n <= 1 = IM.empty - | otherwise = f 0 n - where - p2 = fromIntegral p - f i m - | r == 0 = f (i+1) q - | i > 0 = IM.insert p i (rec ps m) - | otherwise = rec ps m - where - (q, r) = quotRem m p2 - - -fromFactors :: Factors -> Integer -fromFactors = product . map f . IM.toList - where f (a, i) = toInteger a ^ toInteger i - --- For practical reasons, the list of prime numbers is cut-off after --- 1000 elements (last primes gives 7919). -primes :: [Int] -primes = take 1000 $ rec [2..] - where - rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) - rec [] = error "PrimeFactors: empty list" - -------------------------------------------------------------- --- Type class instances - -instance Show PrimeFactors where - show (PF a m) = show a ++ " (factors = " ++ show (IM.toList m) ++ ")" - -instance Eq PrimeFactors where - PF a _ == PF b _ = a==b - -instance Ord PrimeFactors where - PF a _ `compare` PF b _ = a `compare` b - -instance Num PrimeFactors where - PF a m1 + PF b m2 - | a==0 = PF b m2 -- prevent recomputing prime factors - | b==0 = PF a m1 - | otherwise = fromInteger (a+b) - a - b = a + negate b - PF a m1 * PF b m2 - | a==0 || b==0 = 0 - | otherwise = PF (a*b) (IM.unionWith (+) m1 m2) - negate (PF a m) = PF (negate a) m - abs (PF a m) = PF (abs a) m - signum (PF a _) = fromInteger (signum a) - fromInteger n = PF n (toFactors n) - -instance Enum PrimeFactors where - toEnum = fromIntegral - fromEnum = fromIntegral . toInteger - -instance Real PrimeFactors where - toRational = toRational . toInteger - -instance Integral PrimeFactors where - toInteger (PF a _) = a - quotRem = quotRemPF - -------------------------------------------------------------- --- Utility functions - -factors :: PrimeFactors -> [(Int, Int)] -factors (PF _ m) = IM.toList m - -multiplicity :: Int -> PrimeFactors -> Int -multiplicity i (PF _ m) = IM.findWithDefault 0 i m - --- no prime in common -coprime :: PrimeFactors -> PrimeFactors -> Bool -coprime (PF _ m1) (PF _ m2) = IM.null (IM.intersection m1 m2) - -square :: PrimeFactors -> PrimeFactors -square = (`power` 2) - -power :: PrimeFactors -> Int -> PrimeFactors -power (PF a m) i = PF (a^i) (IM.map (*i) m) - -greatestPower :: Integer -> Maybe (Integer, Integer) -greatestPower n = do - guard $ n > 1 - let (as, xs) = unzip $ factors $ fromInteger n - x <- safeHead xs - guard $ allsame xs && x > 1 - return (fromIntegral (product as), fromIntegral x) - --- n == a^x with (a,x) == greatestPower n --- prop_greatestPower n = traceShow n $ --- maybe True (\(a,x) -> fromIntegral a ^ fromIntegral x == n) $ greatestPower n - -allPowers :: Integer -> [(Integer, Integer)] -allPowers n = do - (b, e) <- maybeToList $ greatestPower n - let f i = let (a, r) = e `divMod` i - in if a > 1 && r == 0 then Just (b^i, a) else Nothing - mapMaybe f [1..e] - --- prop_allPowers n = traceShow n $ --- and (map (\(a,x) -> fromIntegral a ^ fromIntegral x == n) (allPowers n)) - --- splitPower i a = (b,c) --- => b^i * c = a -splitPower :: Int -> PrimeFactors -> (PrimeFactors, PrimeFactors) -splitPower i (PF a m) = (PF b p1, PF c p2) - where - pairs = IM.map (`quotRem` i) m - p1 = IM.filter (>0) (fmap fst pairs) - p2 = IM.filter (>0) (fmap snd pairs) - b = fromFactors p1 - c = a `div` (b^i) - -quotRemPF :: PrimeFactors -> PrimeFactors -> (PrimeFactors, PrimeFactors) -quotRemPF (PF a m1) (PF b m2) - | b==0 = error "division by zero" - | a==0 = (0,0) - | otherwise = sign $ - case (IM.null up, IM.null dn) of - (True, True) -> (1, 0) - (False, True) -> (PF (fromFactors up) up, 0) - (True, False) -> (0, PF a m1) - _ -> (fromInteger qn, fromInteger rn) - where - (up, dn) = IM.partition (>0) $ IM.filter (/=0) $ IM.unionWith (+) m1 (IM.map negate m2) - (qn, rn) = fromFactors up `quotRem` fromFactors (IM.map negate dn) - sign (q, r) = ( fromInteger (signum a*signum b) * q - , fromInteger (signum a) * r +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.PrimeFactors + ( PrimeFactors + , factors, multiplicity, coprime + , square, power, splitPower + , primes, greatestPower, allPowers + ) where + +import Data.Maybe +import qualified Data.IntMap as IM + +------------------------------------------------------------- +-- Representation + +-- Invariants: +-- * Keys in map are prime numbers only (exception: representation of 0) +-- * Elements in map are positive (non-zero) +-- * Zero is represented by [(0,1)] (since 0^1 equals 0) +-- * The number can be negative, in which case we use the factors of +-- its absolute value +data PrimeFactors = PF Integer Factors + +type Factors = IM.IntMap Int + +------------------------------------------------------------- +-- Conversion to and from factors + +toFactors :: Integer -> Factors +toFactors a + | a > 0 = rec primes a + | a < 0 = rec primes (-a) + | otherwise = IM.singleton 0 1 + where + rec [] n = IM.singleton (fromIntegral n) 1 + rec (p:ps) n + | n <= 1 = IM.empty + | otherwise = f 0 n + where + p2 = fromIntegral p + f i m + | r == 0 = f (i+1) q + | i > 0 = IM.insert p i (rec ps m) + | otherwise = rec ps m + where + (q, r) = quotRem m p2 + +fromFactors :: Factors -> Integer +fromFactors = product . map f . IM.toList + where f (a, i) = toInteger a ^ toInteger i + +-- For practical reasons, the list of prime numbers is cut-off after +-- 1000 elements (last primes gives 7919). +primes :: [Int] +primes = take 1000 $ rec [2..] + where + rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) + rec [] = error "PrimeFactors: empty list" + +------------------------------------------------------------- +-- Type class instances + +instance Show PrimeFactors where + show (PF a m) = show a ++ " (factors = " ++ show (IM.toList m) ++ ")" + +instance Eq PrimeFactors where + PF a _ == PF b _ = a==b + +instance Ord PrimeFactors where + PF a _ `compare` PF b _ = a `compare` b + +instance Num PrimeFactors where + PF a m1 + PF b m2 + | a==0 = PF b m2 -- prevent recomputing prime factors + | b==0 = PF a m1 + | otherwise = fromInteger (a+b) + PF a m1 * PF b m2 + | a==0 || b==0 = 0 + | otherwise = PF (a*b) (IM.unionWith (+) m1 m2) + negate (PF a m) = PF (negate a) m + abs (PF a m) = PF (abs a) m + signum (PF a _) = fromInteger (signum a) + fromInteger n = PF n (toFactors n) + +instance Enum PrimeFactors where + toEnum = fromIntegral + fromEnum = fromIntegral . toInteger + +instance Real PrimeFactors where + toRational = toRational . toInteger + +instance Integral PrimeFactors where + toInteger (PF a _) = a + quotRem = quotRemPF + +------------------------------------------------------------- +-- Utility functions + +factors :: PrimeFactors -> [(Int, Int)] +factors (PF _ m) = IM.toList m + +multiplicity :: Int -> PrimeFactors -> Int +multiplicity i (PF _ m) = IM.findWithDefault 0 i m + +-- no prime in common +coprime :: PrimeFactors -> PrimeFactors -> Bool +coprime (PF _ m1) (PF _ m2) = IM.null (IM.intersection m1 m2) + +square :: PrimeFactors -> PrimeFactors +square = (`power` 2) + +power :: PrimeFactors -> Int -> PrimeFactors +power (PF a m) i = PF (a^i) (IM.map (*i) m) + +-- brute force, ugly +greatestPower :: Integer -> Maybe (Integer, Integer) +greatestPower n = f 2 1 + where + f b e | n == b ^ e = Just (b, e) + | b > n = Nothing + | b ^ e > n = f (b + 1) 1 + | otherwise = f b (e + 1) + +-- -- n == a^x with (a,x) == greatestPower n +-- prop_greatestPower n = traceShow n $ +-- maybe True (\(a,x) -> fromIntegral a ^ fromIntegral x == n) $ greatestPower n + +allPowers :: Integer -> [(Integer, Integer)] +allPowers n = do + (b, e) <- maybeToList $ greatestPower n + let f i = let (a, r) = e `divMod` i + in if a > 1 && r == 0 then Just (b^i, a) else Nothing + mapMaybe f [1..e] + +-- prop_allPowers n = traceShow n $ +-- and (map (\(a,x) -> fromIntegral a ^ fromIntegral x == n) (allPowers n)) + +-- splitPower i a = (b,c) +-- => b^i * c = a +splitPower :: Int -> PrimeFactors -> (PrimeFactors, PrimeFactors) +splitPower i (PF a m) = (PF b p1, PF c p2) + where + pairs = IM.map (`quotRem` i) m + p1 = IM.filter (>0) (fmap fst pairs) + p2 = IM.filter (>0) (fmap snd pairs) + b = fromFactors p1 + c = a `div` (b^i) + +quotRemPF :: PrimeFactors -> PrimeFactors -> (PrimeFactors, PrimeFactors) +quotRemPF (PF a m1) (PF b m2) + | b==0 = error "PrimeFactors: division by zero" + | a==0 = (0,0) + | otherwise = sign $ + case (IM.null up, IM.null dn) of + (True, True) -> (1, 0) + (False, True) -> (PF (fromFactors up) up, 0) + (True, False) -> (0, PF a m1) + _ -> (fromInteger qn, fromInteger rn) + where + (up, dn) = IM.partition (>0) $ IM.filter (/=0) $ IM.unionWith (+) m1 (IM.map negate m2) + (qn, rn) = fromFactors up `quotRem` fromFactors (IM.map negate dn) + sign (q, r) = ( fromInteger (signum a*signum b) * q + , fromInteger (signum a) * r ) 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 @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,9 +11,9 @@ -- Mathematical relations -- ----------------------------------------------------------------------------- -module Domain.Math.Data.Relation +module Domain.Math.Data.Relation ( -- * Type class - Relational(..), mapLeft, mapRight, updateLeft, updateRight + Relational(..) -- * Relation data type , Relation, relationType, RelationType(..), relationSymbols , notRelation, eval @@ -25,14 +25,16 @@ , Inequality(..), inequalityView ) where -import Common.View import Common.Rewriting -import Common.Classes -import Domain.Math.Expr.Symbols (openMathSymbol) -import Text.OpenMath.Dictionary.Relation1 +import Common.View +import Control.Applicative +import Control.Monad +import Data.Foldable (Foldable, foldMap, toList) import Data.Maybe +import Data.Monoid +import Data.Traversable (Traversable, sequenceA) import Test.QuickCheck -import Control.Monad +import Text.OpenMath.Dictionary.Relation1 ----------------------------------------------------------------------------- -- Type class for relations @@ -40,20 +42,12 @@ class Functor f => Relational f where leftHandSide :: f a -> a rightHandSide :: f a -> a - flipSides :: f a -> f a -- possibly also flips operator + flipSides :: f a -> f a -- possibly also flips operator constructor :: f a -> b -> b -> f b isSymmetric :: f a -> Bool -- default definitions isSymmetric _ = False -mapLeft, mapRight :: Relational f => (a -> a) -> f a -> f a -mapLeft f p = updateLeft (f (leftHandSide p)) p -mapRight f p = updateRight (f (rightHandSide p)) p - -updateLeft, updateRight :: Relational f => a -> f a -> f a -updateLeft a p = constructor p a (rightHandSide p) -updateRight a p = constructor p (leftHandSide p) a - ----------------------------------------------------------------------------- -- Relation data type @@ -61,7 +55,7 @@ deriving (Eq, Ord) -- Corresponds exactly to the symbols in the relation1 OpenMath dictionary -data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan +data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan | LessThanOrEqualTo | GreaterThanOrEqualTo | Approximately deriving (Show, Eq, Ord, Enum) @@ -71,6 +65,12 @@ instance Functor Relation where fmap f (R x rt y) = R (f x) rt (f y) +instance Foldable Relation where + foldMap = foldMapRelation + +instance Traversable Relation where + sequenceA = sequenceRelation + instance Relational Relation where leftHandSide = lhs rightHandSide = rhs @@ -79,11 +79,11 @@ isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType instance IsTerm a => IsTerm (Relation a) where - toTerm p = + toTerm p = let op = relationType p sym = maybe (newSymbol (show op)) snd (lookup op relationSymbols) in binary sym (toTerm (leftHandSide p)) (toTerm (rightHandSide p)) - fromTerm term = + fromTerm term = case getFunction term of Just (s, [a, b]) -> case [ rt | (rt, (_, t)) <- relationSymbols, s==t ] of @@ -91,17 +91,15 @@ _ -> fail "fromTerm: relation" _ -> fail "fromTerm: relation" -instance Rewrite a => Rewrite (Relation a) - relationSymbols :: [(RelationType, (String, Symbol))] relationSymbols = - [ (EqualTo, ("==", openMathSymbol eqSymbol)) - , (NotEqualTo, ("/=", openMathSymbol neqSymbol)) - , (LessThan, ("<", openMathSymbol ltSymbol)) - , (GreaterThan, (">", openMathSymbol gtSymbol)) - , (LessThanOrEqualTo, ("<=", openMathSymbol leqSymbol)) - , (GreaterThanOrEqualTo, (">=", openMathSymbol geqSymbol)) - , (Approximately, ("~=", openMathSymbol approxSymbol)) + [ (EqualTo, ("==", newSymbol eqSymbol)) + , (NotEqualTo, ("/=", newSymbol neqSymbol)) + , (LessThan, ("<", newSymbol ltSymbol)) + , (GreaterThan, (">", newSymbol gtSymbol)) + , (LessThanOrEqualTo, ("<=", newSymbol leqSymbol)) + , (GreaterThanOrEqualTo, (">=", newSymbol geqSymbol)) + , (Approximately, ("~=", newSymbol approxSymbol)) ] notRelation :: Relation a -> Relation a @@ -111,10 +109,10 @@ swap (x, y) = (y, x) xs = [ (EqualTo, NotEqualTo) , (LessThan, GreaterThanOrEqualTo) - , (LessThanOrEqualTo, GreaterThan) + , (LessThanOrEqualTo, GreaterThan) ] -eval :: Ord a => RelationType -> a -> a -> Bool +eval :: (Ord a, Num a) => RelationType -> a -> a -> Bool eval relType = case relType of EqualTo -> (==) @@ -123,9 +121,9 @@ GreaterThan -> (>) LessThanOrEqualTo -> (<=) GreaterThanOrEqualTo -> (>=) - Approximately -> (==) + Approximately -> \a b -> 1000 * abs (a-b) < 1 --- helpers +-- helpers showRelType :: RelationType -> String showRelType = fst . (? relationSymbols) @@ -138,29 +136,24 @@ (?) :: Eq a => a -> [(a, b)] -> b a ? xs = fromMaybe (error "Relation: Error in lookup") (lookup a xs) ------------------------------------------------------------------------------ --- Traversable instance declarations - -instance Switch Relation where switch = switchRelation -instance Crush Relation where crush = crushRelation +foldMapRelation :: (Relational f, Monoid m) => (a -> m) -> f a -> m +foldMapRelation f p = f (leftHandSide p) `mappend` f (rightHandSide p) -switchRelation :: (Relational f, Monad m) => f (m a) -> m (f a) -switchRelation p = - liftM2 (constructor p) (leftHandSide p) (rightHandSide p) - -crushRelation :: Relational f => f a -> [a] -crushRelation p = [leftHandSide p, rightHandSide p] +sequenceRelation :: (Relational g, Applicative f) => g (f a) -> f (g a) +sequenceRelation p = constructor p <$> leftHandSide p <*> rightHandSide p ----------------------------------------------------------------------------- -- QuickCheck generators instance Arbitrary a => Arbitrary (Relation a) where arbitrary = liftM3 R arbitrary arbitrary arbitrary + instance CoArbitrary a => CoArbitrary (Relation a) where - coarbitrary p = coarbitrary (relationType p) . coarbitrary (crush p) - + coarbitrary p = coarbitrary (relationType p) . coarbitrary (toList p) + instance Arbitrary RelationType where - arbitrary = oneof $ map return [EqualTo .. Approximately] + arbitrary = elements [EqualTo .. Approximately] + instance CoArbitrary RelationType where coarbitrary op = variant (fromEnum op) @@ -172,8 +165,8 @@ (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) :: a -> a -> Relation a (.==.) = makeType EqualTo (./=.) = makeType NotEqualTo -(.<.) = makeType LessThan -(.>.) = makeType GreaterThan +(.<.) = makeType LessThan +(.>.) = makeType GreaterThan (.<=.) = makeType LessThanOrEqualTo (.>=.) = makeType GreaterThanOrEqualTo (.~=.) = makeType Approximately @@ -197,21 +190,22 @@ instance Functor Equation where fmap f (x :==: y) = f x :==: f y -instance Zip Equation where - fzipWith f (a :==: b) (c :==: d) = f a c :==: f b d +instance Foldable Equation where + foldMap = foldMapRelation +instance Traversable Equation where + sequenceA = sequenceRelation + instance Relational Equation where leftHandSide = leftHandSide . build equationView rightHandSide = rightHandSide . build equationView - flipSides = \(x :==: y) -> y :==: x + flipSides (x :==: y) = y :==: x constructor = const (:==:) isSymmetric = const True -instance Switch Equation where switch = switchRelation -instance Crush Equation where crush = crushRelation - instance Arbitrary a => Arbitrary (Equation a) where arbitrary = liftM2 (:==:) arbitrary arbitrary + instance CoArbitrary a => CoArbitrary (Equation a) where coarbitrary = coarbitrary . build equationView @@ -219,8 +213,6 @@ toTerm = toTerm . build equationView fromTerm a = fromTerm a >>= matchM equationView -instance Rewrite a => Rewrite (Equation a) - equationView :: View (Relation a) (Equation a) equationView = makeView f g where @@ -233,34 +225,38 @@ -- Inequality (view on Relation) infix 1 :<:, :>:, :<=:, :>=: - + data Inequality a = a :<: a | a :>: a | a :<=: a | a :>=: a instance Show a => Show (Inequality a) where show = show . build inequalityView instance Functor Inequality where - fmap f ineq = + fmap f ineq = let a = leftHandSide ineq b = rightHandSide ineq in constructor ineq (f a) (f b) - + +instance Foldable Inequality where + foldMap = foldMapRelation + +instance Traversable Inequality where + sequenceA = sequenceRelation + instance Relational Inequality where leftHandSide = leftHandSide . build inequalityView rightHandSide = rightHandSide . build inequalityView - flipSides = fromMaybe (error "inequality: flipSides") . matchM inequalityView + flipSides = fromMaybe (error "inequality: flipSides") . matchM inequalityView . flipSides . build inequalityView - constructor ineq = + constructor ineq = let relType = relationType (build inequalityView ineq) in fst (relType ? inequalityTable) -instance Switch Inequality where switch = switchRelation -instance Crush Inequality where crush = crushRelation - instance Arbitrary a => Arbitrary (Inequality a) where - arbitrary = do - op <- oneof $ map (return . fst . snd) inequalityTable + arbitrary = do + op <- elements $ map (fst . snd) inequalityTable liftM2 op arbitrary arbitrary + instance CoArbitrary a => CoArbitrary (Inequality a) where coarbitrary = coarbitrary . build inequalityView @@ -268,21 +264,19 @@ toTerm = toTerm . build inequalityView fromTerm a = fromTerm a >>= matchM inequalityView -instance Rewrite a => Rewrite (Inequality a) - inequalityView :: View (Relation a) (Inequality a) inequalityView = makeView f g where f (R x op y) = fmap (\pair -> fst pair x y) (lookup op inequalityTable) g ineq = - case ineq of - x :<: y -> x .<. y + case ineq of + x :<: y -> x .<. y x :>: y -> x .>. y x :<=: y -> x .<=. y x :>=: y -> x .>=. y inequalityTable :: [(RelationType, (a -> a -> Inequality a, a -> a -> Relation a))] -inequalityTable = +inequalityTable = [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.))) , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.))) ] diff --git a/src/Domain/Math/Data/SquareRoot.hs b/src/Domain/Math/Data/SquareRoot.hs --- a/src/Domain/Math/Data/SquareRoot.hs +++ b/src/Domain/Math/Data/SquareRoot.hs @@ -1,177 +1,190 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Data.SquareRoot - ( SquareRoot - , imaginary, imaginaryUnit - , con, toList, scale, fromSquareRoot - , sqrt, sqrtRational, isqrt, eval - ) where - -import Prelude hiding (sqrt) -import Data.Ratio -import qualified Domain.Math.Data.PrimeFactors as P -import qualified Data.Map as M -import qualified Prelude -import Control.Monad - -------------------------------------------------------------- --- Representation - --- Sum of square roots (possibly imaginary) that are normalized --- --- Invariants: --- * all keys are normalized (sqrt 8 -> 2*(sqrt 2)) --- * all values are non-zero --- * We maintain the "imaginary" property since sqrt(-1)*sqrt(-1) may or may not --- be equal to sqrt(1) --- --- Note on the Ord instance: comparison does not follow the value (semantic --- interpretation); it can be used though for sorting and storing in maps - -data SquareRoot a = S - { imaginary :: Bool - , squareRootMap :: SqMap a - } deriving (Eq, Ord) - -type SqMap a = M.Map P.PrimeFactors a - -------------------------------------------------------------- --- Primitive operations on maps - --- re-establish invariants -makeMap :: Num a => SqMap a -> SqMap a -makeMap = M.filter (/=0) . M.foldWithKey f M.empty - where - f k a m - | a == 0 = m - | otherwise = M.unionWith (+) (fmap (*a) (sqrtPF k)) m - -plusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a -plusSqMap m1 m2 = M.filter (/=0) (M.unionWith (+) m1 m2) - -minusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a -minusSqMap m1 m2 = m1 `plusSqMap` negateSqMap m2 - -negateSqMap :: Num a => SqMap a -> SqMap a -negateSqMap = fmap negate - -timesSqMap :: Num a => SqMap a -> SqMap a -> SqMap a -timesSqMap m1 m2 = - case (M.toList m1, M.toList m2) of - ([], _) -> M.empty - (_, []) -> M.empty - ([(n, a)], _) | n==1 -> if a==0 then M.empty else fmap (*a) m2 - (_, [(n, a)]) | n==1 -> if a==0 then M.empty else fmap (*a) m1 - _ -> - let op n a = M.unionWith (+) (f n (fmap (a *) m1)) - f i = M.mapKeys (*i) - in makeMap (M.foldWithKey op M.empty m2) - -recipSqMap :: Fractional a => SqMap a -> SqMap a -recipSqMap m = - case M.toList m of - [] -> error "division by zero" - [(n, x)] -> M.singleton n (recip (x * fromIntegral n)) - _ -> (a .-. b) .*. recipSqMap (makeMap ((a .*. a) .-. (b .*. b))) - where - (ys, zs) = splitAt (length xs `div` 2) xs - (a, b) = (M.fromList ys, M.fromList zs) - xs = M.toList m - (.*.) = timesSqMap - (.-.) = minusSqMap - -sqrtPF :: Num a => P.PrimeFactors -> SqMap a -sqrtPF n - | n == 0 = M.empty - | otherwise = M.singleton b (fromIntegral a) - where - (a, b) = P.splitPower 2 n - -------------------------------------------------------------- --- Type class instances - -instance Num a => Show (SquareRoot a) where - show (S isNeg m) = g (map f (M.toList m)) ++ imPart - where - f (n, a) = ( signum a == -1 - , times (guard (abs a /= 1) >> Just (show (abs a))) - (guard (n /= 1) >> Just ("sqrt(" ++ show (toInteger n) ++ ")")) - ) - imPart = if isNeg then " (imaginary number)" else "" - g [] = "0" - g ((b,x):xs) = (if b then "-" else "") ++ x ++ concatMap h xs - h (b, x) = (if b then " - " else " + ") ++ x - - times (Just a) (Just b) = a ++ "*" ++ b - times (Just a) Nothing = a - times Nothing (Just b) = b - times Nothing Nothing = "1" - --- the Functor instance does not maintain the invariant (non-zero) -instance Functor SquareRoot where - fmap f (S b m) = S b (M.map f m) - -instance Num a => Num (SquareRoot a) where - S b1 m1 + S b2 m2 = S (b1 || b2) (plusSqMap m1 m2) - S b1 m1 - S b2 m2 = S (b1 || b2) (minusSqMap m1 m2) - S b1 m1 * S b2 m2 = S (b1 || b2) (timesSqMap m1 m2) - negate (S b m) = S b (negateSqMap m) - fromInteger = con . fromInteger - - -- not defined for square roots - abs = error "abs not defined for square roots" - signum = error "signum not defined for square roots" - -instance Fractional a => Fractional (SquareRoot a) where - recip (S b m) = S b (recipSqMap m) - fromRational = con . fromRational - -------------------------------------------------------------- --- Utility functions - -imaginaryUnit :: Num a => SquareRoot a -imaginaryUnit = S True (M.singleton (-1) 1) - -toList :: SquareRoot a -> [(a, Integer)] -toList = map (\(k, r) -> (r, toInteger k)) . M.toList . squareRootMap - -fromSquareRoot :: Num a => SquareRoot a -> Maybe a -fromSquareRoot a = - case toList a of - [(b, n)] | n==1 -> Just b - [] -> Just 0 - _ -> Nothing - -con :: Num a => a -> SquareRoot a -con a = S False (if a==0 then M.empty else M.singleton 1 a) - -sqrt :: Num a => Integer -> SquareRoot a -sqrt n - | n < 0 = S True (M.mapKeys negate m) - | otherwise = S False m - where - m = sqrtPF (fromIntegral (abs n)) - -scale :: Num a => a -> SquareRoot a -> SquareRoot a -scale a sr = if a==0 then 0 else fmap (*a) sr - -isqrt :: Integer -> Integer -isqrt = (floor :: Double -> Integer) . Prelude.sqrt . fromInteger - -sqrtRational :: Fractional a => Rational -> SquareRoot a -sqrtRational r = scale (1/fromIntegral b) (sqrt (a*b)) - where - (a, b) = (numerator r, denominator r) - -eval :: Floating a => SquareRoot a -> a -eval (S _ m) = M.foldWithKey f 0 m +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.SquareRoot + ( SquareRoot + , imaginary, imaginaryUnit + , con, toList, scale, fromSquareRoot + , sqrt, sqrtRational, isqrt, eval + ) where + +import Control.Monad +import Data.Ratio +import Domain.Math.Safe +import Prelude hiding (sqrt) +import Test.QuickCheck +import qualified Data.Map as M +import qualified Domain.Math.Data.PrimeFactors as P +import qualified Prelude + +------------------------------------------------------------- +-- Representation + +-- Sum of square roots (possibly imaginary) that are normalized +-- +-- Invariants: +-- * all keys are normalized (sqrt 8 -> 2*(sqrt 2)) +-- * all values are non-zero +-- * We maintain the "imaginary" property since sqrt(-1)*sqrt(-1) may or may not +-- be equal to sqrt(1) +-- +-- Note on the Ord instance: comparison does not follow the value (semantic +-- interpretation); it can be used though for sorting and storing in maps + +data SquareRoot a = S + { imaginary :: Bool + , squareRootMap :: SqMap a + } deriving (Eq, Ord) + +type SqMap a = M.Map P.PrimeFactors a + +------------------------------------------------------------- +-- Primitive operations on maps + +-- re-establish invariants +makeMap :: Num a => SqMap a -> SqMap a +makeMap = M.filter (/=0) . M.foldWithKey f M.empty + where + f k a m + | a == 0 = m + | otherwise = M.unionWith (+) (fmap (*a) (sqrtPF k)) m + +plusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a +plusSqMap m1 m2 = M.filter (/=0) (M.unionWith (+) m1 m2) + +minusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a +minusSqMap m1 m2 = m1 `plusSqMap` negateSqMap m2 + +negateSqMap :: Num a => SqMap a -> SqMap a +negateSqMap = fmap negate + +timesSqMap :: Num a => SqMap a -> SqMap a -> SqMap a +timesSqMap m1 m2 = + case (M.toList m1, M.toList m2) of + ([], _) -> M.empty + (_, []) -> M.empty + ([(n, a)], _) | n==1 -> if a==0 then M.empty else fmap (*a) m2 + (_, [(n, a)]) | n==1 -> if a==0 then M.empty else fmap (*a) m1 + _ -> + let op n a = M.unionWith (+) (f n (fmap (a *) m1)) + f i = M.mapKeys (*i) + in makeMap (M.foldWithKey op M.empty m2) + +recipSqMap :: Fractional a => SqMap a -> SqMap a +recipSqMap m = + case M.toList m of + [] -> error "SquareRoot: division by zero" + [(n, x)] -> M.singleton n (recip (x * fromIntegral n)) + _ -> (a .-. b) .*. recipSqMap (makeMap ((a .*. a) .-. (b .*. b))) + where + (ys, zs) = splitAt (length xs `div` 2) xs + (a, b) = (M.fromList ys, M.fromList zs) + xs = M.toList m + (.*.) = timesSqMap + (.-.) = minusSqMap + +sqrtPF :: Num a => P.PrimeFactors -> SqMap a +sqrtPF n + | n == 0 = M.empty + | otherwise = M.singleton b (fromIntegral a) + where + (a, b) = P.splitPower 2 n + +------------------------------------------------------------- +-- Type class instances + +instance Num a => Show (SquareRoot a) where + show (S isNeg m) = g (map f (M.toList m)) ++ imPart + where + f (n, a) = ( signum a == -1 + , times (guard (abs a /= 1) >> Just (show (abs a))) + (guard (n /= 1) >> Just ("sqrt(" ++ show (toInteger n) ++ ")")) + ) + imPart = if isNeg then " (imaginary number)" else "" + g [] = "0" + g ((b,x):xs) = (if b then "-" else "") ++ x ++ concatMap h xs + h (b, x) = (if b then " - " else " + ") ++ x + + times (Just a) (Just b) = a ++ "*" ++ b + times (Just a) Nothing = a + times Nothing (Just b) = b + times Nothing Nothing = "1" + +-- the Functor instance does not maintain the invariant (non-zero) +instance Functor SquareRoot where + fmap f (S b m) = S b (M.map f m) + +instance Num a => Num (SquareRoot a) where + S b1 m1 + S b2 m2 = S (b1 || b2) (plusSqMap m1 m2) + S b1 m1 - S b2 m2 = S (b1 || b2) (minusSqMap m1 m2) + S b1 m1 * S b2 m2 = S (b1 || b2) (timesSqMap m1 m2) + negate (S b m) = S b (negateSqMap m) + fromInteger = con . fromInteger + + -- not defined for square roots + abs = error "abs not defined for square roots" + signum = error "signum not defined for square roots" + +instance Fractional a => SafeDiv (SquareRoot a) where + safeDiv x y + | y == 0 = Nothing + | otherwise = Just (x/y) + +instance Fractional a => Fractional (SquareRoot a) where + recip (S b m) = S b (recipSqMap m) + fromRational = con . fromRational + +instance Fractional a => Arbitrary (SquareRoot a) where + arbitrary = do + n <- choose (0, 10) + let f (a, b) = fromRational a * sqrtRational (fromRational (abs b)) + liftM (sum . map f) (vector n) + +------------------------------------------------------------- +-- Utility functions + +imaginaryUnit :: Num a => SquareRoot a +imaginaryUnit = S True (M.singleton (-1) 1) + +toList :: SquareRoot a -> [(a, Integer)] +toList = map (\(k, r) -> (r, toInteger k)) . M.toList . squareRootMap + +fromSquareRoot :: Num a => SquareRoot a -> Maybe a +fromSquareRoot a = + case toList a of + [(b, n)] | n==1 -> Just b + [] -> Just 0 + _ -> Nothing + +con :: Num a => a -> SquareRoot a +con a = S False (if a==0 then M.empty else M.singleton 1 a) + +sqrt :: Num a => Integer -> SquareRoot a +sqrt n + | n < 0 = S True (M.mapKeys negate m) + | otherwise = S False m + where + m = sqrtPF (fromIntegral (abs n)) + +scale :: Num a => a -> SquareRoot a -> SquareRoot a +scale a sr = if a==0 then 0 else fmap (*a) sr + +isqrt :: Integer -> Integer +isqrt = (floor :: Double -> Integer) . Prelude.sqrt . fromInteger + +sqrtRational :: Fractional a => Rational -> SquareRoot a +sqrtRational r = scale (1/fromIntegral b) (sqrt (a*b)) + where + (a, b) = (numerator r, denominator r) + +eval :: Floating a => SquareRoot a -> a +eval (S _ m) = M.foldWithKey f 0 m where f n a b = a * Prelude.sqrt (fromIntegral n) + b diff --git a/src/Domain/Math/Data/WithBool.hs b/src/Domain/Math/Data/WithBool.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/WithBool.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Values extended with boolean constants +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.WithBool + ( WithBool, fromWithBool, join + ) where + +import Common.Algebra.Boolean +import Common.Classes +import Common.Rewriting +import Control.Applicative +import Control.Monad +import Data.Char (toLower) +import Data.Foldable +import Data.Traversable +import Domain.Logic.Formula + +------------------------------------------------------------------- +-- Abstract data type and instances + +newtype WithBool a = WB { fromWithBool :: Either Bool a } + deriving (Eq, Ord, Functor) + +instance Show a => Show (WithBool a) where + show = either (map toLower . show) show . fromWithBool + +instance BoolValue (WithBool a) where + fromBool = WB . Left + isTrue = either id (const False) . fromWithBool + isFalse = either not (const False) . fromWithBool + +instance Container WithBool where + singleton = WB . Right + getSingleton = either (const Nothing) Just . fromWithBool + +instance Monad WithBool where + return = singleton + m >>= f = either fromBool f (fromWithBool m) + +instance Foldable WithBool where + foldMap = foldMapDefault + +instance Traversable WithBool where + traverse _ (WB (Left b)) = pure (WB (Left b)) + traverse f (WB (Right a)) = (WB . Right) <$> f a + +instance IsTerm a => IsTerm (WithBool a) where + toTerm = either f toTerm . fromWithBool + where + f True = symbol trueSymbol + f False = symbol falseSymbol + fromTerm term + | isSymbol trueSymbol term = return true + | isSymbol falseSymbol term = return false + | otherwise = liftM singleton (fromTerm term) diff --git a/src/Domain/Math/Derivative/Examples.hs b/src/Domain/Math/Derivative/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Derivative/Examples.hs @@ -0,0 +1,168 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Derivative.Examples + ( diffSet1, diffSet2, diffSet3, diffSet4 + , diffSet5, diffSet6, diffSet7, diffSet8 + ) where + +import Common.Rewriting +import Data.Maybe +import Domain.Math.Expr +import Prelude hiding ((^)) + +differentiateLists :: [[Expr]] -> [[Expr]] +differentiateLists = map (map differentiate) + +differentiate :: Expr -> Expr +differentiate a = + let x = fromMaybe "x" (selectVar a) + in unary diffSymbol $ binary lambdaSymbol (Var x) a + +---------------------------------------------------------- +-- HAVO B applets + +-- Hoofdstuk 6, differentieer +-- Bereken de afgeleide +diffSet1 :: [[Expr]] +diffSet1 = differentiateLists $ + let x = Var "x" in + let p = Var "p" in + let q = Var "q" in + let r = Var "r" in + [ [ 3*x^4 - 7*x^2, -x^3-5*x, 1/2*x^6-5*x^2+4, -1/3*x^3+(3/2)*x^2-x+1] + , [ -x^5+5*x+23, -2*p^4+5*p-12, 3/5*q^5-q^3+4*q, -2/3*r^6+1/4*r^4-3*r+7] + , -- werk eerst de haakjes weg + [ (x-2)^2, -(1-3*x)^2, (x-1)*(2*x+5), -(1-3*x)*(2*x+7)] + -- differentieer + , [x^3-x*(x+5), -2*(p+1)*(p-12), q*(q^5-q^3)+3*q^2+4, -3*r*(r-1)*(r+2)] + ] + +---------------------------------------------------------- +-- VWO A/C applets + +-- Hoofdstuk 7, differentieer +diffSet2 :: [[Expr]] +diffSet2 = differentiateLists $ + let x = Var "x" in + [ [ 5*x^2, -4*x^2, 10*x^2-8, -8*x^2+7] + , [ 3*x^2+4*x, -0.5*x^2-2*x, -8*x^2+7*x-3, -0.25*x^2+x-1] + , [ (x+2)^2, (5*x+7)*(4-3*x), (3*x+6)^2-8*x + , 5*(x-3)^2+5*x, 5*(x-3)^2+5*(2*x-1), -3*(x-1)*(5-9*x)-8*(x-7) ] + ] + +-- Hoofdstuk 7, bereken de afgeleide: zelfde als Havo B applet + +---------------------------------------------------------- +-- VWO B applets + +-- Hoofdstuk 3, differentieren: zelfde als Havo B applet + +-- Hoofdstuk 7 +-- Gebruik de productregel +diffSet3 :: [[Expr]] +diffSet3 = differentiateLists $ + let x = Var "x" in + [ [ (x^2+2*x)*(3*x+5), (2*x^2-3*x)*(4*x+1), (3*x^3+4*x)*(x^2-2) + , (4*x^3-x)*(3*x^2+7*x), (x^2+2*x)*(x^3-4*x^2+3), (5*x-7)*(2*x^3-3*x+1) + , (3*x^2+2)*(5*x^3+4*x^2-7*x), (4*x+1)*(3*x^3-x^2+2*x) + ] + , [ (3*x+1)^2, (5*x-2)^2, (2*x+7)^2, (4*x-3)^2 + , (2*x^2-3*x)^2, (3*x^2+2)^2, 2*x^3-3*x^2, (5*x^3+7*x)^2 + ] + ] + +-- Gebruik de quotientregel +diffSet4 :: [[Expr]] +diffSet4 = differentiateLists $ + let x = Var "x" in + [ [ 5/(x-1), 3/(x+2), (-2)/(x-3), (-3)/(x+4), 3/(2*x-1) + , 2/(3*x+4), (-4)/(3*x-1), (-2)/(4*x+3) + ] + , [ (x+1)/(x-2), (x-3)/(x+4), (x+5)/(x-1), (x-2)/(x+1) + , (2*x+3)/(4*x-1), (3*x-1)/(2*x+1), (4*x+3)/(3*x-2), (5*x-2)/(3*x+4) + ] + , [ (3*x^2)/(2*x^3+4), (2*x^3)/(3*x^2-1), (x^2)/(4*x^3-2) + , (3*x^3)/(5*x^2+7), (1-x^3)/(x+4), (x+3)/(2-x^2) + , (1-2*x^3)/(x+1), (x+5)/(2-3*x^2) + ] + , [ (2-x)/(x^2+1)+2*x^3, (x^3-3)/(4-x)+x^2 + , (3-2*x)/(2*x^2-3)+x^3, (2*x^3-4)/(6-5*x)+4*x^2 + ] + ] + +-- differentieer x^n (n geheel), noteer zonder negatieve exponent +diffSet5 :: [[Expr]] +diffSet5 = differentiateLists $ + let x = Var "x" in + [ [ 4/x^2, 5/x^3, 2/x^4, 3/x^5, 1/9*x^2, 1/7*x^3, 1/5*x^4, 1/8*x^5 ] + , [ 3*x^2-4/(x^2), 7*x^3-2/(x^3), 2*x^4-5/(x^4), 2*x^5-6/(x^5) + , (3*x+2)/(x^3), (2*x^2-4)/x^5, (4*x-3)/x^2, (6*x^2+5)/x^4 + ] + , -- herleid de afgeleide tot 1 breuk + [ (2*x^4+3)/x^2, (2*x^5-5)/x^3, (4*x^5-1)/x^2, (4*x^4+3)/x^3 + , (3*x-1)/(7*x^2), (2*x^3+1)/(3*x^4), (x^2-2)/(3*x^3), (x+5)/(6*x^3) + ] + ] + +-- differentieer x^r (r uit R), noteer zonder negatieve en gebroken exponent +diffSet6 :: [[Expr]] +diffSet6 = differentiateLists $ + let x = Var "x" in + [ [ x*root x 3, x^3*sqrt x, x*root x 5, x^4*sqrt x, 1/(x*root x 3) + , 1/(x^3*sqrt x), 1/(x*root x 5), 1/(x^4*sqrt x) + ] + , [ x^2*root (x^2) 3, x*root (x^3) 4, x^3*root (x^2) 5, x^2*root (x^3) 5 + , (x^3+1)*(2+sqrt x), (3+x^2)*(1+root x 3), (x^2+1)*(root x 3+2) + , (3+x^3)*(sqrt x+1) + ] + , [ (sqrt x + 1)^2, (x*sqrt x-3)^2, (sqrt x-2)^2, (x*sqrt x+1)^2 + , (x+2)/sqrt x, (x-3)/sqrt x, (x-4)/sqrt x, (x+5)/sqrt x + ] + , [ (x-2)/(x*sqrt x), (x+3)/(x*sqrt x), (x+4)/(x*sqrt x), (x-5)/(x*sqrt x) + , (x^2+2)/(3*sqrt x), (x^2-3)/(4*sqrt x) + , (x^2+4)/(2*sqrt x), (x^2-6)/(3*sqrt x) + ] + , [ (x+3)/(x^2*sqrt x), (x-1)/(x^3*sqrt x), (x-2)/(x^2*sqrt x) + , (x+4)/(x^3*sqrt x), (sqrt x-2)/x^2, (2*sqrt x+1)/x^2 + , (1-sqrt x)/x, (3*sqrt x+2)/x + ] + ] + +-- differentieren met de kettingregel +diffSet7 :: [[Expr]] +diffSet7 = differentiateLists $ + let x = Var "x" in + [ [ 2*(x^2+3*x)^5, 3*(x^3-4*x)^6, -6*(x^2+2*x)^4, -5*(x^3-3*x^2)^3] + , [ -(2/(x^2+3*x)^5),-(3/(x^3-4*x)^6), 6/(x^2+2*x)^4, 5/(x^3-3*x^2)^3] + , [ sqrt (3*x^4-x), sqrt (x^3+5*x^2), sqrt (6*x^2+x), sqrt (7*x^3-3*x^2)] + , [ 1/sqrt (3*x-2), 1/sqrt (8*x+5), 1/sqrt (3*x-4), 1/sqrt (5*x-2)] + , [ (2*x-1)^2*sqrt (2*x-1), (3*x^2+2)*sqrt (3*x^2+2) + , (3*x+5)^3*sqrt (3*x+5), (4*x^3-7)*sqrt (4*x^3-7) + ] + ] + +-- differentieren met de kettingregel gecombineerd +diffSet8 :: [[Expr]] +diffSet8 = differentiateLists $ + let x = Var "x" in + [ [ 2*x*sqrt (4*x+3), 3*x*sqrt (2*x-5), 4*x*sqrt (3*x+2), 2*x*sqrt (5*x-3)] + , [ x^2*(4*x^2-2)^3, x^3*(3*x-4)^3, x^4*(3*x^2+1)^5, x^5*(4*x+3)^4] + , [ (x+3)/sqrt (2*x-1), (x+7)/sqrt (4*x+3) + , (x-2)/sqrt (3*x+1), (x-7)/sqrt (5*x-4) + ] + , [ sqrt (2*x^2-1)/(x+3), sqrt (4*x^2+3)/(x+7) + , sqrt (3*x^2+1)/(x-2), sqrt (5*x^2-4)/(x-7) + ] + ] diff --git a/src/Domain/Math/Derivative/Exercises.hs b/src/Domain/Math/Derivative/Exercises.hs --- a/src/Domain/Math/Derivative/Exercises.hs +++ b/src/Domain/Math/Derivative/Exercises.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,24 +9,25 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Math.Derivative.Exercises +module Domain.Math.Derivative.Exercises ( derivativeExercise, derivativePolyExercise , derivativeProductExercise, derivativeQuotientExercise , derivativePowerExercise ) where import Common.Library -import Common.Uniplate +import Common.Utils.Uniplate import Control.Monad +import Data.Function import Data.List import Data.Maybe import Data.Ord +import Domain.Math.CleanUp +import Domain.Math.Derivative.Examples import Domain.Math.Derivative.Rules import Domain.Math.Derivative.Strategies -import Domain.Math.Examples.DWO5 import Domain.Math.Expr import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp import Domain.Math.Polynomial.Generators import Domain.Math.Polynomial.RationalExercises import Domain.Math.Polynomial.Views @@ -41,69 +42,70 @@ { exerciseId = diffId # "polynomial" , status = Provisional , parser = parseExpr - , isReady = (`belongsTo` polyNormalForm rationalView) - , isSuitable = isPolyDiff - , equivalence = eqPolyDiff - , similarity = simPolyDiff + , ready = predicateView (polyNormalForm rationalView) + , suitable = predicate isPolyDiff + , equivalence = withoutContext eqPolyDiff + , similarity = withoutContext (viewEquivalent cleanUpACView) , strategy = derivativePolyStrategy , navigation = navigator - , examples = concat (diffSet1 ++ diffSet2 ++ diffSet3) - , testGenerator = Just $ liftM (diff . lambda (Var "x")) $ + , examples = level Medium $ concat (diffSet1 ++ diffSet2 ++ diffSet3) + , testGenerator = Just $ liftM (diff . lambda "x") $ sized quadraticGen } derivativeProductExercise :: Exercise Expr derivativeProductExercise = describe "Use the product-rule to find the derivative of a polynomial. Keep \ - \the parentheses in your answer." $ + \the parentheses in your answer." $ derivativePolyExercise { exerciseId = diffId # "product" - , isReady = noDiff + , ready = predicate noDiff , strategy = derivativeProductStrategy - , examples = concat diffSet3 + , examples = level Medium $ concat diffSet3 } derivativeQuotientExercise :: Exercise Expr derivativeQuotientExercise = describe "Use the quotient-rule to find the derivative of a polynomial. Only \ - \remove parentheses in the numerator." $ + \remove parentheses in the numerator." $ derivativePolyExercise { exerciseId = diffId # "quotient" - , isReady = readyQuotientDiff - , isSuitable = isQuotientDiff - , equivalence = eqQuotientDiff + , ready = predicate readyQuotientDiff + , suitable = predicate isQuotientDiff + , equivalence = withoutContext eqQuotientDiff , strategy = derivativeQuotientStrategy , ruleOrdering = ruleOrderingWithId [ruleDerivQuotient] - , examples = concat diffSet4 + , examples = level Medium $ concat diffSet4 , testGenerator = Nothing } derivativePowerExercise :: Exercise Expr derivativePowerExercise = describe "First write as a power, then find the derivative. Rewrite negative or \ - \rational exponents." $ + \rational exponents." $ derivativePolyExercise { exerciseId = diffId # "power" , status = Experimental - , isReady = \a -> noDiff a && onlyNatPower a - , isSuitable = const True + , ready = predicate noDiff <&&> predicate onlyNatPower + -- , isSuitable = const True , equivalence = \_ _ -> True -- \x y -> eqApprox (evalDiff x) (evalDiff y) , strategy = derivativePowerStrategy - , examples = concat (diffSet5 ++ diffSet6) + , examples = level Medium $ concat (diffSet5 ++ diffSet6) , testGenerator = Nothing } derivativeExercise :: Exercise Expr derivativeExercise = makeExercise { exerciseId = describe "Derivative" diffId - , status = Experimental + , status = Provisional , parser = parseExpr - , isReady = noDiff + , ready = predicate noDiff , strategy = derivativeStrategy , ruleOrdering = derivativeOrdering + , equivalence = withoutContext eqQuotientDiff , navigation = navigator - , examples = concat (diffSet3++diffSet4++ - diffSet5++diffSet6++diffSet7++diffSet8) + , examples = level Medium $ concat $ diffSet3++diffSet4++diffSet5 + {- diffSet6 -- ++diffSet7++diffSet8 -} } derivativeOrdering :: Rule a -> Rule a -> Ordering @@ -126,20 +128,10 @@ return (all isp ys) eqPolyDiff :: Expr -> Expr -> Bool -eqPolyDiff x y = - let f a = fromMaybe (descend f a) (apply ruleDerivPolynomial a) - in viewEquivalent (polyViewWith rationalView) (f x) (f y) +eqPolyDiff = viewEquivalent (polyViewWith rationalView) `on` evalDiff eqQuotientDiff :: Expr -> Expr -> Bool -eqQuotientDiff a b = eqSimplifyRational (make a) (make b) - where - make = inContext derivativeQuotientExercise . f - rs = [ ruleDerivPolynomial, ruleDerivQuotient, ruleDerivProduct - , ruleDerivNegate, ruleDerivPlus, ruleDerivMin - ] - f x = case mapMaybe (`apply` x) rs of - hd:_ -> f hd - [] -> descend f x +eqQuotientDiff = eqSimplifyRational `on` (cleanUpExpr . evalDiff) readyQuotientDiff :: Expr -> Bool readyQuotientDiff expr = fromMaybe False $ do @@ -150,70 +142,39 @@ nfp = (`belongsTo` polyNormalForm rationalView) return (all nfp ys && all isp zs) -simPolyDiff :: Expr -> Expr -> Bool -simPolyDiff x y = - let f = acExpr . cleanUpExpr - in f x == f y - noDiff :: Expr -> Bool -noDiff e = null [ () | Sym s _ <- universe e, isDiffSymbol s ] +noDiff e = all (not . isDiffSymbol) [ s | Sym s _ <- universe e] onlyNatPower :: Expr -> Bool -onlyNatPower e = and [ isNat a | Sym s [_, a] <- universe e, isPowerSymbol s ] +onlyNatPower e = all isNat [ a | Sym s [_, a] <- universe e, isPowerSymbol s ] where isNat (Nat _) = True isNat _ = False -{- evalDiff :: Expr -> Expr -evalDiff expr - | isDiff expr = - case concatMap (`applyAll` expr) list of - hd:_ -> evalDiff hd - _ -> expr - | otherwise = descend evalDiff expr - where - list = [ ruleDerivPolynomial, ruleDerivPowerFactor - , ruleDerivPlus, ruleDerivMin, ruleDerivNegate - , ruleDerivProduct, ruleDerivQuotient - , ruleDerivPowerChain, ruleDerivSqrtChain, ruleDerivRoot - ] - -go = checkExercise derivativePowerExercise - -raar i = printDerivation derivativePowerExercise expr - where - expr = examples derivativePowerExercise !! i - -eqApprox :: Expr -> Expr -> Bool -eqApprox a b = rec 5 doubleList +evalDiff da = + case da of + Sym d [Sym l [Var x, expr]] | isDiffSymbol d && isLambdaSymbol l -> + cleanUpExpr (rec x expr) + _ -> descend evalDiff da where - vs = nub (collectVars a ++ collectVars b) - - rec 0 = const True - rec n = rec2 n 10 - - rec2 _ 0 ds = undefined -- a==b - rec2 n m ds = case eqApproxWith f a b of - Just b -> b && rec (n-1) ys - Nothing -> rec2 n (m-1) ys + rec x expr = + case expr of + _ | withoutVar x expr -> 0 + Var y | x==y -> 1 + a :+: b -> rec x a + rec x b + a :-: b -> rec x a - rec x b + Negate a -> -rec x a + a :*: b -> rec x a*b + a*rec x b + a :/: b -> (b*rec x a - a*rec x b) / b^2 + Sqrt a -> rec x (a^(1/2)) + Sym s [a, b] + | isPowerSymbol s -> + case match rationalView b of + Just n -> fromRational n * a^fromRational (n-1) * rec x a + Nothing -> diffExpr + | isRootSymbol s -> + rec x (a^(1/b)) + _ -> diffExpr where - (xs, ys) = splitAt (length vs) ds - f = (xs !!) . fromMaybe 0 . (`elemIndex` vs) - -eqApproxWith :: (String -> Double) -> Expr -> Expr -> Maybe Bool -eqApproxWith f a b = do - d1 <- match doubleView (subst a) - d2 <- match doubleView (subst b) - return $ abs (d1 - d2) < 1e-9 -- 11 is still ok for example set - where - subst (Var s) = Number (f s) - subst expr = descend subst expr - -doubleList :: [Double] -- between -20 and 20 -doubleList = iterate next (pi*exp 1) - where - next :: Double -> Double - next a = if b > 20 then b-20 else b - where - b = a + exp 3 * log 2 -} + diffExpr = diff (lambda x expr) diff --git a/src/Domain/Math/Derivative/Rules.hs b/src/Domain/Math/Derivative/Rules.hs --- a/src/Domain/Math/Derivative/Rules.hs +++ b/src/Domain/Math/Derivative/Rules.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,25 +11,20 @@ ----------------------------------------------------------------------------- module Domain.Math.Derivative.Rules where -import Prelude hiding ((^)) -import Common.Transformation -import Common.View +import Common.Library hiding (root) import Control.Monad -import Domain.Math.Expr -import Common.Id -import Common.Rewriting import Data.Maybe -import Domain.Math.Polynomial.Views -import Domain.Math.Numeric.Views import Domain.Math.Data.Polynomial +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Views import Domain.Math.Power.Views -import Domain.Math.Power.Utils ( (<&>) ) - +import Prelude hiding ((^)) derivativeRules :: [Rule Expr] derivativeRules = [ ruleDerivCon, ruleDerivPlus, ruleDerivMin, ruleDerivNegate - , ruleDerivMultiple, ruleDerivPower, ruleDerivVar + , ruleDerivMultiple, ruleDerivPower, ruleDerivVar , ruleDerivProduct, ruleDerivQuotient, ruleDerivPowerChain , ruleSine, ruleLog, ruleDerivSqrt, ruleDerivSqrtChain ] @@ -40,8 +35,8 @@ ln :: Expr -> Expr ln = unary lnSymbol -lambda :: Expr -> Expr -> Expr -lambda = binary lambdaSymbol +lambda :: String -> Expr -> Expr +lambda = binary lambdaSymbol . Var diffId :: Id diffId = newId "calculus.differentiation" @@ -54,13 +49,13 @@ -- Rules for Diffs ruleSine :: Rule Expr -ruleSine = rule (diffId, "sine") $ - \x -> diff (lambda x (sin x)) :~> cos x +ruleSine = rule (diffId, "sine") $ + \x -> diff (lambda x (sin (Var x))) :~> cos (Var x) ruleLog :: Rule Expr ruleLog = rule (diffId, "logarithmic") $ - \x -> diff (lambda x (ln x)) :~> 1/x - + \x -> diff (lambda x (ln (Var x))) :~> 1 / Var x + ruleDerivPlus :: Rule Expr ruleDerivPlus = rule (diffId, "plus") $ \x f g -> diff (lambda x (f + g)) :~> diff (lambda x f) + diff (lambda x g) @@ -75,7 +70,7 @@ ruleDerivVar :: Rule Expr ruleDerivVar = rule (diffId, "var") $ - \x -> diff (lambda x x) :~> 1 + \x -> diff (lambda x (Var x)) :~> 1 ruleDerivProduct :: Rule Expr ruleDerivProduct = rule (diffId, "product") $ @@ -85,7 +80,7 @@ -- up an expression will typically put the negate in front of the division: this -- makes sure the rule is triggered anyway. ruleDerivQuotient :: Rule Expr -ruleDerivQuotient = ruleList (diffId, "quotient") +ruleDerivQuotient = ruleList (diffId, "quotient") [ \x f g -> diff (lambda x (f/g)) :~> (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2) , \x f g -> diff (lambda x (-f/g)) :~> (g*diff (lambda x (-f)) - (-f)*diff (lambda x g)) / (g^2) ] @@ -93,7 +88,7 @@ ruleDerivPolynomial :: Rule Expr ruleDerivPolynomial = describe "This rule returns the derivative for all \ \expressions that can be turned into a polynomial (of rational numbers). \ - \The polynomial does not have to be in standard form." $ + \The polynomial does not have to be in standard form." $ makeSimpleRule (diffId, "deriv-of-poly") f where f (Sym d [Sym l [Var v, expr]]) | isDiffSymbol d && isLambdaSymbol l = do @@ -102,60 +97,60 @@ guard (s==v) return (build myView (s, derivative p)) f _ = Nothing - + ----------------------------------- -- Special rules (not defined with unification) ruleDerivCon :: Rule Expr ruleDerivCon = makeSimpleRule (diffId, "constant") f - where - f (Sym d [Sym l [Var v, e]]) - | isDiffSymbol d && isLambdaSymbol l && withoutVar v e = return 0 + where + f (Sym d [Sym l [Var x, e]]) + | isDiffSymbol d && isLambdaSymbol l && withoutVar x e = return 0 f _ = Nothing - + ruleDerivMultiple :: Rule Expr ruleDerivMultiple = makeSimpleRule (diffId, "constant-multiple") f - where - f (Sym d [Sym l [x@(Var v), n :*: e]]) - | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = + where + f (Sym d [Sym l [Var x, n :*: e]]) + | isDiffSymbol d && isLambdaSymbol l && withoutVar x n = return $ n * diff (lambda x e) - f (Sym d [Sym l [x@(Var v), e :*: n]]) - | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = + f (Sym d [Sym l [Var x, e :*: n]]) + | isDiffSymbol d && isLambdaSymbol l && withoutVar x n = return $ n * diff (lambda x e) - f _ = Nothing + f _ = Nothing ruleDerivPower :: Rule Expr ruleDerivPower = makeSimpleRule (diffId, "power") f - where - f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) - | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && x==x1 && withoutVar v n = - return $ n * (x ^ (n-1)) + where + f (Sym d [Sym l [Var x, Sym p [x1, n]]]) + | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && Var x==x1 && withoutVar x n = + return $ n * (Var x ^ (n-1)) f _ = Nothing ruleDerivPowerChain :: Rule Expr -ruleDerivPowerChain = makeSimpleRule (diffId, "chain-power") f - where - f (Sym d [Sym l [x@(Var v), Sym p [a, n]]]) - | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar v n = +ruleDerivPowerChain = makeSimpleRule (diffId, "chain-power") f + where + f (Sym d [Sym l [Var x, Sym p [a, n]]]) + | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar x n = return $ n * (a ^ (n-1)) * diff (lambda x a) f _ = Nothing - + ruleDerivSqrt :: Rule Expr ruleDerivSqrt = makeSimpleRule (diffId, "sqrt") f where - f (Sym d [Sym l [x@(Var _), Sqrt x1]]) - | isDiffSymbol d && isLambdaSymbol l && x==x1 = - return $ 1 / (2 * sqrt x) - f _ = Nothing - + f (Sym d [Sym l [Var x, Sqrt x1]]) + | isDiffSymbol d && isLambdaSymbol l && Var x==x1 = + return $ 1 / (2 * sqrt (Var x)) + f _ = Nothing + ruleDerivSqrtChain :: Rule Expr ruleDerivSqrtChain = makeSimpleRule (diffId, "chain-sqrt") f where - f (Sym d [Sym l [x@(Var _), Sqrt a]]) + f (Sym d [Sym l [Var x, Sqrt a]]) | isDiffSymbol d && isLambdaSymbol l = return $ (1 / (2 * sqrt a)) * diff (lambda x a) - f _ = Nothing - + f _ = Nothing + ruleDefRoot :: Rule Expr ruleDefRoot = rule (diffId, "def-root") $ \a b -> root a b :~> a ^ (1/b) @@ -163,20 +158,20 @@ ruleDerivRoot :: Rule Expr ruleDerivRoot = rule (diffId, "def-root") $ \a b x -> diff (lambda x (root a b)) :~> diff (lambda x (a ^ (1/b))) - + ruleDerivPowerFactor :: Rule Expr ruleDerivPowerFactor = makeSimpleRule (diffId, "power-factor") $ \de -> do expr <- getDiffExpr de (a, x, r) <- match myPowerView expr return $ build myPowerView (a*fromRational r, x, r-1) - + -- (a+b)/c ~> a/c + b/c ruleSplitRational :: Rule Expr ruleSplitRational = makeSimpleRule (diffId, "split-rational") $ \expr -> do - (up, c) <- match divView expr - (a, b) <- match plusView up + (upper, c) <- match divView expr + (a, b) <- match plusView upper return (a/c + b/c) - + myPowerView :: View Expr (Expr, String, Rational) myPowerView = makeView f g where @@ -192,19 +187,16 @@ Nothing -> do (x, r) <- match powView expr return (1, x, r) - g (a, x, r) = a .*. (Var x .^. fromRational r) - - powView = (powerView <&> noPowerView) >>> myVarView *** rationalView - myVarView = makeView isVar Var + g (a, x, r) = a .*. (Var x .^. fromRational r) + + powView = (matcher powerView <+> matcher noPowerView) + >>> matcher (variableView *** rationalView) noPowerView = makeView (\expr -> Just (expr, 1)) (build powerView) - - isVar (Var x) = Just x - isVar _ = Nothing - + isDiff :: Expr -> Bool isDiff = isJust . getDiffExpr getDiffExpr :: Expr -> Maybe Expr -getDiffExpr (Sym d [Sym l [Var _, expr]]) | +getDiffExpr (Sym d [Sym l [Var _, expr]]) | isDiffSymbol d && isLambdaSymbol l = Just expr getDiffExpr _ = Nothing diff --git a/src/Domain/Math/Derivative/Strategies.hs b/src/Domain/Math/Derivative/Strategies.hs --- a/src/Domain/Math/Derivative/Strategies.hs +++ b/src/Domain/Math/Derivative/Strategies.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Math.Derivative.Strategies +module Domain.Math.Derivative.Strategies ( derivativeStrategy, derivativePolyStrategy , derivativeProductStrategy, derivativeQuotientStrategy , derivativePowerStrategy, getDiffExpr @@ -17,20 +17,20 @@ import Common.Library import Data.Maybe -import Domain.Math.Derivative.Rules +import Domain.Math.CleanUp +import Domain.Math.Derivative.Rules import Domain.Math.Expr -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Views -import Domain.Math.Polynomial.Rules import Domain.Math.Numeric.Views -import Domain.Math.Power.Strategies +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Views import Domain.Math.Power.Rules +import Domain.Math.Power.Strategies import Prelude hiding ((^)) derivativeStrategy :: LabeledStrategy (Context Expr) -derivativeStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ - label "Derivative" $ repeatS $ somewhere $ +derivativeStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $ + label "Derivative" $ repeatS $ somewhere $ alternatives (map liftToContext derivativeRules) <|> derivativePolyStepStrategy <|> check isDiffC <*> once (once (liftToContext ruleDefRoot)) @@ -38,44 +38,46 @@ isDiffC = maybe False isDiff . current derivativePolyStrategy :: LabeledStrategy (Context Expr) -derivativePolyStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ +derivativePolyStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $ label "derivative-polynomial" $ - repeatS (somewhere (alternatives (map liftToContext rulesPolyNF))) + repeatS (somewhere (alternatives rulesPolyNF)) <*> derivativePolyStepStrategy -rulesPolyNF :: [Rule Expr] +rulesPolyNF :: [Rule (Context Expr)] rulesPolyNF = + distributeDivisionMulti : + map liftToContext [ distributionSquare, distributeTimes, merge - , distributeDivision, noDivisionConstant + , noDivisionConstant ] derivativeProductStrategy :: LabeledStrategy (Context Expr) -derivativeProductStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ +derivativeProductStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $ label "derivative-product" $ repeatS (somewhere (derivativePolyStepStrategy |> alternatives list)) where - list = map liftToContext - [ distributeDivision, noDivisionConstant + list = distributeDivisionMulti : map liftToContext + [ noDivisionConstant , ruleDerivProduct, defPowerNat , ruleDerivNegate, ruleDerivPlus, ruleDerivMin ] derivativeQuotientStrategy :: LabeledStrategy (Context Expr) -derivativeQuotientStrategy = cleanUpStrategy (applyTop cleanUpExpr) $ +derivativeQuotientStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $ label "derivative-quotient" $ repeatS (somewhere (derivativePolyStepStrategy |> alternatives list)) - <*> repeatS (exceptLowerDiv (alternatives (map liftToContext rulesPolyNF))) + <*> repeatS (exceptLowerDiv (alternatives rulesPolyNF)) where list = map liftToContext [ ruleDerivQuotient, ruleDerivPlus, ruleDerivMin, ruleDerivNegate ] - + derivativePowerStrategy :: LabeledStrategy (Context Expr) -derivativePowerStrategy = label "derivative-power" $ - cleanUpStrategy (applyTop cleanUpExpr) (label "split-rational" +derivativePowerStrategy = label "derivative-power" $ + cleanUpStrategyAfter (applyTop cleanUpExpr) (label "split-rational" (repeatS (somewhere (liftToContext ruleSplitRational)))) <*> - configure mycfg powerOfStrategy <*> - repeatS (distr <*> configure mycfg powerOfStrategy) <*> - cleanUpStrategy (applyTop cleanUpExpr) (label "use-derivative-rules" + configure mycfg simplifyPowerStrategy <*> + repeatS (distr <*> configure mycfg simplifyPowerStrategy) <*> + cleanUpStrategyAfter (applyTop cleanUpExpr) (label "use-derivative-rules" (repeatS (somewhere (alternatives list)))) <*> configure mycfg nonNegBrokenExpStrategy where @@ -83,9 +85,9 @@ [ ruleDerivPlus, ruleDerivMin, ruleDerivNegate, ruleDerivPowerFactor , ruleDerivCon ] mycfg = [(byName myFractionTimes, Remove)] - distr = cleanUpStrategy (applyTop cleanUpExpr) $ - label "distr" (somewhere (alternatives (map liftToContext rulesPolyNF))) - + distr = cleanUpStrategyAfter (applyTop cleanUpExpr) $ + label "distr" (somewhere (alternatives rulesPolyNF)) + derivativePolyStepStrategy :: LabeledStrategy (Context Expr) derivativePolyStepStrategy = label "derivative-poly-step" $ check polyDiff <*> liftToContext ruleDerivPolynomial @@ -94,9 +96,9 @@ nfPoly = (`belongsTo` polyNormalForm rationalView) exceptLowerDiv :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr) -exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> +exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> if isDivC a then [0] else [0 .. arity a-1] - where + where isDivC = maybe False isDiv . current isDiv (_ :/: _) = True isDiv _ = False diff --git a/src/Domain/Math/Equation/BalanceRules.hs b/src/Domain/Math/Equation/BalanceRules.hs --- a/src/Domain/Math/Equation/BalanceRules.hs +++ b/src/Domain/Math/Equation/BalanceRules.hs @@ -1,37 +1,37 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Equation.BalanceRules - ( plusT, minusT, timesT, divisionT - ) where - -import Common.Transformation -import Common.View -import Control.Monad -import Domain.Math.Data.Relation -import Domain.Math.Numeric.Views -import Domain.Math.Expr - -plusT, minusT :: Functor f => Expr -> Transformation (f Expr) -plusT e = makeTrans $ return . fmap (:+: e) -minusT e = makeTrans $ return . fmap (:-: e) - -timesT :: Functor f => Expr -> Transformation (f Expr) -timesT e = makeTrans $ unlessZero e . fmap (e :*:) - -divisionT :: Expr -> Transformation (Equation Expr) -divisionT e = makeTrans $ unlessZero e . fmap (:/: e) - -unlessZero :: MonadPlus m => Expr -> a -> m a -unlessZero e a = do - r <- matchM rationalView e - guard (r /= 0) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.BalanceRules + ( plusT, minusT, timesT, divisionT + ) where + +import Common.Transformation +import Common.View +import Control.Monad +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views + +plusT, minusT :: Functor f => Expr -> Transformation (f Expr) +plusT e = makeTrans $ return . fmap (:+: e) +minusT e = makeTrans $ return . fmap (:-: e) + +timesT :: Functor f => Expr -> Transformation (f Expr) +timesT e = makeTrans $ unlessZero e . fmap (e :*:) + +divisionT :: Expr -> Transformation (Equation Expr) +divisionT e = makeTrans $ unlessZero e . fmap (:/: e) + +unlessZero :: MonadPlus m => Expr -> a -> m a +unlessZero e a = do + r <- matchM rationalView e + guard (r /= 0) return a diff --git a/src/Domain/Math/Equation/CoverUpExercise.hs b/src/Domain/Math/Equation/CoverUpExercise.hs --- a/src/Domain/Math/Equation/CoverUpExercise.hs +++ b/src/Domain/Math/Equation/CoverUpExercise.hs @@ -1,88 +1,59 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Equation.CoverUpExercise - ( coverUpExercise, coverUpStrategy - ) where - -import Common.Context -import Common.Exercise -import Common.Strategy hiding (replicate) -import Control.Monad -import Domain.Math.Data.Relation -import Domain.Math.Data.OrList -import Domain.Math.Equation.CoverUpRules -import Domain.Math.Equation.Views -import Domain.Math.Examples.DWO1 -import Domain.Math.Expr -import Prelude hiding (repeat) - ------------------------------------------------------------- --- Exercise - -coverUpExercise :: Exercise (OrList (Equation Expr)) -coverUpExercise = makeExercise - { exerciseId = describe "solve an equation by covering up" $ - newId "algebra.equations.coverup" - , status = Provisional - , parser = parseExprWith (pOrList (pEquation pExpr)) - -- , equivalence = \_ _ -> True - , isReady = solvedEquations - , extraRules = coverUpRulesOr - , strategy = coverUpStrategy - , navigation = termNavigator - , examples = map (orList . return) (concat (fillInResult ++ coverUpEquations)) - } - ------------------------------------------------------------- --- Strategy and rules - -coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) -coverUpStrategy = label "Cover-up" $ - repeat $ somewhere $ alternatives coverUpRulesOr - -{- -cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr)) -cleanUp = doAfter $ fmap $ fmap cleanUpExpr - -cleanUpExpr :: Expr -> Expr -cleanUpExpr = transform (simplify (makeView f fromRational)) - where - f (Negate a) = liftM negate (f a) - f (Sqrt a) = match rationalView a >>= rootedRational 2 - f (Sym s [Nat n, a]) | isRootSymbol s = - match rationalView a >>= rootedRational n - f e = match rationalView e - -rootedInt :: Integer -> Integer -> Maybe Integer -rootedInt a b = do - guard (a > 0) - let d = fromInteger b ** Prelude.recip (fromInteger a) :: Double - n = round d :: Integer - guard (n Prelude.^ a == b) - return n - -rootedRational :: Integer -> Rational -> Maybe Rational -rootedRational a r = do - x <- rootedInt a (numerator r) - y <- rootedInt a (denominator r) - return (fromInteger x / fromInteger y) --} ------------------------------------------------------------- --- Testing - -{- -main = map test (concat (fillInResult ++ coverUpEquations)) - -test e = case apply coverUpStrategy (inContext (OrList [e])) of - Just a | solvedList (fromContext a) -> True - | otherwise -> error (show (e, a)) - _ -> error (show e) -} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.CoverUpExercise + ( coverUpExercise, coverUpStrategy + ) where + +import Common.Library +import Data.Maybe +import Domain.Math.CleanUp (cleanUpExpr, cleanUpView) +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Equation.Examples +import Domain.Math.Equation.Views +import Domain.Math.Expr + +------------------------------------------------------------ +-- Exercise + +coverUpExercise :: Exercise (OrList (Equation Expr)) +coverUpExercise = makeExercise + { exerciseId = describe "solve an equation by covering up" $ + newId "algebra.equations.coverup" + , status = Provisional + , parser = parseOrsEqExpr + , equivalence = withoutContext eqCoverUp + , similarity = withoutContext myEq + , ready = predicateView equationsSolvedForm + , extraRules = coverUpRulesOr + , strategy = coverUpStrategy + , navigation = termNavigator + , examples = level Medium $ map singleton (concat (fillInResult ++ coverUpEquations)) + } + +------------------------------------------------------------ +-- Strategy and rules + +coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +coverUpStrategy = cleanUpStrategyAfter (applyTop $ fmap $ fmap cleanUpExpr) $ + label "Cover-up" $ + repeatS $ somewhere $ alternatives coverUpRulesOr + +eqCoverUp :: OrList (Equation Expr) -> OrList (Equation Expr) -> Bool +eqCoverUp a b = myEq (f a) (f b) + where + inc = inContext coverUpExercise + f x = fromMaybe x $ fromContext $ applyD coverUpStrategy $ inc x + +myEq :: OrList (Equation Expr) -> OrList (Equation Expr) -> Bool +myEq = viewEquivalent (traverseView (traverseView cleanUpView)) diff --git a/src/Domain/Math/Equation/CoverUpRules.hs b/src/Domain/Math/Equation/CoverUpRules.hs --- a/src/Domain/Math/Equation/CoverUpRules.hs +++ b/src/Domain/Math/Equation/CoverUpRules.hs @@ -1,205 +1,203 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Equation.CoverUpRules - ( coverUpRules, coverUpRulesOr - , coverUp, coverUpOrs - , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight - , coverUpTimes, coverUpNegate - , coverUpNumerator, coverUpDenominator, coverUpSqrt - -- parameterized rules - , ConfigCoverUp, configName, predicateCovered, predicateCombined - , coverLHS, coverRHS, configCoverUp - , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith - , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith - , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith - -- temporarily exported - , coverUpBinaryRule, commOp, flipOp - ) where - -import Common.Classes -import Common.Context -import Common.Id -import Common.Rewriting -import Common.Transformation -import Common.View -import Control.Monad.Identity -import Data.Maybe -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Expr - ---------------------------------------------------------------------- --- Constructors for cover-up rules - -coverUpFunction :: (Switch f, Relational r) - => (Expr -> [(Expr, Expr)]) - -> (Expr -> Expr -> [f Expr]) - -> ConfigCoverUp -> r Expr -> [f (r Expr)] -coverUpFunction fm fb cfg eq0 = - (guard (coverLHS cfg) >> coverLeft eq0) ++ - (guard (coverRHS cfg) >> coverRight eq0) - where - coverRight = map (fmap flipSides) . coverLeft . flipSides - coverLeft eq = do - (e1, e2) <- fm (leftHandSide eq) - guard (predicateCovered cfg e1) - new <- fb (rightHandSide eq) e2 - _ <- switch $ fmap (guard . predicateCombined cfg) new - return (fmap (constructor eq e1) new) - -coverUpBinaryOrRule :: Relational r - => String -> (Expr -> [(Expr, Expr)]) - -> (Expr -> Expr -> [OrList Expr]) - -> ConfigCoverUp -> Rule (OrList (r Expr)) -coverUpBinaryOrRule opName fm fb cfg = - let name = coverUpRuleName opName (configName cfg) - in makeSimpleRuleList name $ oneDisjunct $ coverUpFunction fm fb cfg - -coverUpBinaryRule :: Relational r => String - -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) - -> ConfigCoverUp -> Rule (r Expr) -coverUpBinaryRule opName fm fb cfg = - let name = coverUpRuleName opName (configName cfg) - fb2 a b = [Identity (fb a b)] - in makeSimpleRuleList name $ map runIdentity . coverUpFunction fm fb2 cfg - -coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr) - -> ConfigCoverUp -> Rule (r Expr) -coverUpUnaryRule opName fm fb = - coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb) - -coverUpRuleName :: String -> String -> Id -coverUpRuleName opName cfg = - let f = if null cfg then newId else ( cfg # ) - in "algebra.equations.coverup" # f opName - ---------------------------------------------------------------------- --- Configuration for cover-up rules - -data ConfigCoverUp = Config - { configName :: String - , predicateCovered :: Expr -> Bool - , predicateCombined :: Expr -> Bool - , coverLHS :: Bool - , coverRHS :: Bool - } - --- Default configuration: cover-up part with variables -configCoverUp :: ConfigCoverUp -configCoverUp = Config - { configName = "" - , predicateCovered = hasSomeVar - , predicateCombined = hasNoVar - , coverLHS = True - , coverRHS = True - } - ---------------------------------------------------------------------- --- Parameterized cover-up rules - -coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr)) -coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb - where - fb rhs e2 = do - n <- isNat e2 - guard (n > 0) - let new1 = root rhs (fromIntegral n) - new2 = (neg new1) - return $ orList $ new1 : [ new2 | new1 /= new2, even n ] - -coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-) - -coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpMinusLeftWith = coverUpBinaryRule "minus-left" isMinus (+) - -coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpMinusRightWith = coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-)) - --- | Negations are pushed inside -coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpTimesWith = coverUpBinaryRule "times" (map signs . commOp . matchM timesView) (/) - where - signs (Negate x, y) = (x, neg y) -- puts negation at combined term - signs (x, y) = (x, y) - -coverUpNegateWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpNegateWith = coverUpUnaryRule "negate" isNegate negate - --- | Negations are pushed inside -coverUpNumeratorWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpNumeratorWith = coverUpBinaryRule "numerator" (matchM divView) (*) - --- | Negations are pushed inside -coverUpDenominatorWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/)) - -coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr) -coverUpSqrtWith = coverUpUnaryRule "sqrt" isSqrt (\x -> x*x) - where - isSqrt (Sqrt a) = return a - isSqrt _ = [] - ---------------------------------------------------------------------- --- Cover-up rules for variables - -coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr) -coverUpOrs = join . fmap (f . coverUp) - where - f :: Equation Expr -> OrList (Equation Expr) - f eq = case apply coverUpPower (return eq) of - Just xs -> coverUpOrs xs - Nothing -> return eq - -coverUp :: Equation Expr -> Equation Expr -coverUp eq = - case mapMaybe (`apply` eq) coverUpRules of - hd:_ -> coverUp hd - _ -> eq - -coverUpRulesOr :: IsTerm a => [Rule (Context a)] -coverUpRulesOr = use coverUpPower : map use coverUpRules - -coverUpRules :: [Rule (Equation Expr)] -coverUpRules = - [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate - , coverUpTimes, coverUpNumerator, coverUpDenominator, coverUpSqrt - ] - -coverUpPower :: Rule (OrList (Equation Expr)) -coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate, - coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr) - -coverUpPower = coverUpPowerWith configCoverUp -coverUpPlus = coverUpPlusWith configCoverUp -coverUpMinusLeft = coverUpMinusLeftWith configCoverUp -coverUpMinusRight = coverUpMinusRightWith configCoverUp -coverUpTimes = coverUpTimesWith configCoverUp -coverUpNegate = coverUpNegateWith configCoverUp -coverUpNumerator = coverUpNumeratorWith configCoverUp -coverUpDenominator = coverUpDenominatorWith configCoverUp -coverUpSqrt = coverUpSqrtWith configCoverUp - ---------------------------------------------------------------------- --- Some helper-functions - -commOp :: MonadPlus m => m (a, a) -> m (a, a) -commOp m = do - (a, b) <- m - return (a, b) `mplus` return (b, a) - -flipOp :: Monad m => m (a, a) -> m (a, a) -flipOp = liftM (\(x, y) -> (y, x)) - -isNat :: MonadPlus m => Expr -> m Integer -isNat (Nat n) = return n +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.CoverUpRules + ( coverUpRules, coverUpRulesOr + , coverUp, coverUpOrs + , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight + , coverUpTimes, coverUpNegate + , coverUpNumerator, coverUpDenominator, coverUpSqrt + -- parameterized rules + , ConfigCoverUp, configName, predicateCovered, predicateCombined + , coverLHS, coverRHS, configCoverUp + , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith + , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith + , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith + -- temporarily exported + , coverUpBinaryRule, commOp, flipOp + ) where + +import Common.Library hiding (root) +import Control.Monad +import Data.Foldable +import Data.Maybe +import Data.Traversable (Traversable, mapM) +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Expr + +--------------------------------------------------------------------- +-- Constructors for cover-up rules + +coverUpFunction :: (Traversable f, Relational r) + => (Expr -> [(Expr, Expr)]) + -> (Expr -> Expr -> [f Expr]) + -> ConfigCoverUp -> r Expr -> [f (r Expr)] +coverUpFunction fm fb cfg eq0 = + (guard (coverLHS cfg) >> coverLeft eq0) ++ + (guard (coverRHS cfg) >> coverRight eq0) + where + coverRight = map (fmap flipSides) . coverLeft . flipSides + coverLeft eq = do + (e1, e2) <- fm (leftHandSide eq) + guard (predicateCovered cfg e1) + new <- fb (rightHandSide eq) e2 + _ <- Data.Traversable.mapM (guard . predicateCombined cfg) new + return (fmap (constructor eq e1) new) + +coverUpBinaryOrRule :: Relational r + => String -> (Expr -> [(Expr, Expr)]) + -> (Expr -> Expr -> [OrList Expr]) + -> ConfigCoverUp -> Rule (OrList (r Expr)) +coverUpBinaryOrRule opName fm fb cfg = + let name = coverUpRuleName opName (configName cfg) + in makeSimpleRuleList name $ oneDisjunct $ coverUpFunction fm fb cfg + +coverUpBinaryRule :: Relational r => String + -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) + -> ConfigCoverUp -> Rule (r Expr) +coverUpBinaryRule opName fm fb cfg = + let name = coverUpRuleName opName (configName cfg) + fb2 a b = [[fb a b]] + in makeSimpleRuleList name $ map head . coverUpFunction fm fb2 cfg + +coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr) + -> ConfigCoverUp -> Rule (r Expr) +coverUpUnaryRule opName fm fb = + coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb) + +coverUpRuleName :: String -> String -> Id +coverUpRuleName opName cfg = + let f = if null cfg then newId else ( cfg # ) + in "algebra.equations.coverup" # f opName + +--------------------------------------------------------------------- +-- Configuration for cover-up rules + +data ConfigCoverUp = Config + { configName :: String + , predicateCovered :: Expr -> Bool + , predicateCombined :: Expr -> Bool + , coverLHS :: Bool + , coverRHS :: Bool + } + +-- Default configuration: cover-up part with variables +configCoverUp :: ConfigCoverUp +configCoverUp = Config + { configName = "" + , predicateCovered = hasSomeVar + , predicateCombined = hasNoVar + , coverLHS = True + , coverRHS = True + } + +--------------------------------------------------------------------- +-- Parameterized cover-up rules + +coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr)) +coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb + where + fb rhs e2 = do + n <- isNat e2 + guard (n > 0) + let new1 = root rhs (fromIntegral n) + new2 = neg new1 + return $ singleton new1 <> + if even n && new1 /= new2 then singleton new2 else false + +coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-) + +coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpMinusLeftWith = coverUpBinaryRule "minus-left" isMinus (+) + +coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpMinusRightWith = coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-)) + +-- | Negations are pushed inside +coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpTimesWith = coverUpBinaryRule "times" (map signs . commOp . matchM timesView) (/) + where + signs (Negate x, y) = (x, neg y) -- puts negation at combined term + signs (x, y) = (x, y) + +coverUpNegateWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpNegateWith = coverUpUnaryRule "negate" isNegate negate + +-- | Negations are pushed inside +coverUpNumeratorWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpNumeratorWith = coverUpBinaryRule "numerator" (matchM divView) (*) + +-- | Negations are pushed inside +coverUpDenominatorWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/)) + +coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpSqrtWith = coverUpUnaryRule "sqrt" isSqrt (\x -> x*x) + where + isSqrt (Sqrt a) = return a + isSqrt _ = [] + +--------------------------------------------------------------------- +-- Cover-up rules for variables + +coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr) +coverUpOrs = foldMap (f . coverUp) + where + f :: Equation Expr -> OrList (Equation Expr) + f eq = case apply coverUpPower (singleton eq) of + Just xs -> coverUpOrs xs + Nothing -> singleton eq + +coverUp :: Equation Expr -> Equation Expr +coverUp eq = + case mapMaybe (`apply` eq) coverUpRules of + hd:_ -> coverUp hd + _ -> eq + +coverUpRulesOr :: IsTerm a => [Rule (Context a)] +coverUpRulesOr = use coverUpPower : map use coverUpRules + +coverUpRules :: [Rule (Equation Expr)] +coverUpRules = + [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate + , coverUpTimes, coverUpNumerator, coverUpDenominator, coverUpSqrt + ] + +coverUpPower :: Rule (OrList (Equation Expr)) +coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate, + coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr) + +coverUpPower = coverUpPowerWith configCoverUp +coverUpPlus = coverUpPlusWith configCoverUp +coverUpMinusLeft = coverUpMinusLeftWith configCoverUp +coverUpMinusRight = coverUpMinusRightWith configCoverUp +coverUpTimes = coverUpTimesWith configCoverUp +coverUpNegate = coverUpNegateWith configCoverUp +coverUpNumerator = coverUpNumeratorWith configCoverUp +coverUpDenominator = coverUpDenominatorWith configCoverUp +coverUpSqrt = coverUpSqrtWith configCoverUp + +--------------------------------------------------------------------- +-- Some helper-functions + +commOp :: MonadPlus m => m (a, a) -> m (a, a) +commOp m = do + (a, b) <- m + return (a, b) `mplus` return (b, a) + +flipOp :: Monad m => m (a, a) -> m (a, a) +flipOp = liftM (\(x, y) -> (y, x)) + +isNat :: MonadPlus m => Expr -> m Integer +isNat (Nat n) = return n isNat _ = mzero diff --git a/src/Domain/Math/Equation/Examples.hs b/src/Domain/Math/Equation/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Equation/Examples.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.Examples + ( fillInResult, coverUpEquations + ) where + +import Common.Rewriting +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Prelude hiding ((^)) + +fillInResult :: [[Equation Expr]] +fillInResult = [level1, level2, level3] + where + level1 = + let x = variable "x" in + [ x-2 :==: 2 + , -4*x :==: -28 + , -8*x :==: 72 + , x+4 :==: 09 + , 4+x :==: 2 + , -10-x :==: -7 + , x/(-8) :==: -3 + , 11-x :==: 14 + ] + + level2 = + let x = variable "x" in + [ -5-3*x :==: -23 + , 21/x - 4 :==: 3 + , -3*(x+3) :==: -27 + , 2-5*x :==: 47 + , 18/(7-x) :==: 6 + , -77/x + 4 :==: -7 + , -7-(x/(-5)) :==: -15 + , -18/(-3+x) :==: 3 + ] + + level3 = + let x = variable "x" in + [ -5*(5-(3-x)) :==: -20 + , (-20-x)/(-5)-2 :==: 3 + , 4-(x-14)/(-3) :==: 1 + , 3*x - 3 - 7 :==: 8 + , -42/(-2*x+2) :==: 7 + , 3*(4+x+2) :==: 12 + , -6-(-54/(-3*x)) :==: -12 + , 14-(x-3)/4 :==: 3 + ] + +coverUpEquations :: [[Equation Expr]] +coverUpEquations = [level1, level2] + where + level1 = + let x = variable "x" in + [ 38-7*x :==: 3 + , sqrt (125/x) :==: 5 + , 4*(12-x) + 7 :==: 35 + , 5*x^2 :==: 80 + , 5*(5-x) :==: 35 + , 32/sqrt x :==: 8 + , (21/x)-8 :==: -1 + , 180/x^2 :==: 5 + , 3*(x-8)^2 :==: 12 + , (8-x)/3 + 7 :==: 9 + ] + + level2 = + let x = variable "x" in + [ sqrt (x+9)/2 :==: 3 + , (4*x-18)^2 :==: 4 + , 3*(13-2*x)^2 - 20 :==: 55 + , 5*((x/3) - 8)^2 :==: 20 + , (6/sqrt (x-7))^3 :==: 8 + , 8-(15/sqrt (31-x)) :==: 5 + , sqrt (4*(x^2-21)) :==: 4 + , 3 + (44/sqrt (87 + x)) :==: 7 + , 13-(56 / (21 + (70/(3+x)))) :==: 12 + , 12/(2+(24/(8+(28/(2+9/x))))) :==: 3 + ] diff --git a/src/Domain/Math/Equation/Views.hs b/src/Domain/Math/Equation/Views.hs --- a/src/Domain/Math/Equation/Views.hs +++ b/src/Domain/Math/Equation/Views.hs @@ -1,59 +1,62 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Equation.Views - ( solvedRelations, solvedRelation - , equationSolvedForm, solvedEquation, solvedEquations - , solvedRelationWith - ) where - -import Domain.Math.Expr -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Common.View -import Common.Classes - --- generalized to relation -solvedRelations :: (Crush f, Relational g) => f (g Expr) -> Bool -solvedRelations = all solvedRelation . crush - --- The variable may appear on one of the sides of the relation (right-hand side --- is thus allowed), but must be isolated -solvedRelation :: Relational f => f Expr -> Bool -solvedRelation r = - case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of - (Just _, Just _) -> False - (Just x, Nothing) -> withoutVar x (rightHandSide r) - (Nothing, Just x) -> withoutVar x (leftHandSide r) - _ -> hasNoVar (leftHandSide r) && hasNoVar (rightHandSide r) - --- The variable must appear on the left -solvedRelationWith :: Relational f => (Expr -> Bool) -> f Expr -> Bool -solvedRelationWith p r = - isVariable (leftHandSide r) && p (rightHandSide r) - -------------------------------------------------------------- --- Views on equations - -solvedEquations :: OrList (Equation Expr) -> Bool -solvedEquations = all solvedEquation . crush - -solvedEquation :: Equation Expr -> Bool -solvedEquation eq@(lhs :==: rhs) = - (eq `belongsTo` equationSolvedForm) || (hasNoVar lhs && hasNoVar rhs) - -equationSolvedForm :: View (Equation Expr) (String, Expr) -equationSolvedForm = makeView f g - where - f (Var x :==: e) | withoutVar x e = - return (x, e) - f _ = Nothing - g (s, e) = Var s :==: e +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.Views + ( relationSolvedForm, relationsSolvedForm + , equationSolvedForm, equationsSolvedForm, equationSolvedWith + ) where + +import Common.Library +import Data.Traversable +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Expr + +relationsSolvedForm :: (Traversable f, Relational g) => + View (f (g Expr)) (f (Expr -> Expr -> g Expr, String, Expr)) +relationsSolvedForm = "relations.solved" @> traverseView relationSolvedForm + +-- The variable may appear on one of the sides of the relation (right-hand side +-- is thus allowed), but must be isolated +relationSolvedForm :: Relational f => + View (f Expr) (Expr -> Expr -> f Expr, String, Expr) +relationSolvedForm = "relation.solved" @> makeView f g + where + f r = case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of + (Just x, Nothing) | withoutVar x (rightHandSide r) -> + return (constructor r, x, rightHandSide r) + (Nothing, Just x) | withoutVar x (leftHandSide r) -> + return (flip (constructor r), x, leftHandSide r) + _ -> Nothing + g (make, s, e) = make (Var s) e + +------------------------------------------------------------- +-- Views on equations + +equationsSolvedForm :: View (OrList (Equation Expr)) (OrList (String, Expr)) +equationsSolvedForm = "equations.solved" @> traverseView equationSolvedForm + +equationSolvedForm :: View (Equation Expr) (String, Expr) +equationSolvedForm = "equation.solved" @> makeView f g + where + f (Var x :==: e) | withoutVar x e = + return (x, e) + f _ = Nothing + g (s, e) = Var s :==: e + +equationSolvedWith :: View Expr a -> View (Equation Expr) (String, a) +equationSolvedWith v = "equation.solved-with" @> makeView f g + where + f (lhs :==: rhs) = do + x <- getVariable lhs + a <- match v rhs + return (x, a) + g (s, a) = Var s :==: build v a diff --git a/src/Domain/Math/Examples/DWO1.hs b/src/Domain/Math/Examples/DWO1.hs deleted file mode 100644 --- a/src/Domain/Math/Examples/DWO1.hs +++ /dev/null @@ -1,517 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Example exercises from the Digital Mathematics Environment (DWO) --- ------------------------------------------------------------------------------ -module Domain.Math.Examples.DWO1 - ( calculateResults, fillInResult - , coverUpEquations, linearEquations - , quadraticEquations, findFactors - , modulusEquations, sqrtEquations, sqrtSubstEquations, brokenEquations - , simplerSqrt, simplerSqrt2, simplerSqrt3 - ) where - -import Prelude hiding ((^)) -import Common.Rewriting -import Domain.Math.Data.Relation -import Domain.Math.Expr - -calculateResults :: [[Expr]] -calculateResults = [level1, level2, level3] - where - level1 = - [ -8*(-3) - , -3-9 - , 55/(-5) - , -6*9 - , -11- (-3) - , 6-(-9) - , -10+3 - , 6+(-5) - ] - - level2 = - [ -3-(6*(-3)) - , -12/3 - 3 - , -4*(2+3) - , 2-6*6 - , -27/(4-(-5)) - , (-24/(-6)) - 3 - , 8-(-77/(-11)) - , 4/(-4+5) - ] - - level3 = - [ 4*(3-(6-2)) - , (-16-9)/5 - 3 - , 4- (4-13)/(-3) - , (3*(-3))-5-4 - , -55/(3*(-5)+4) - , -4*(-2+ (-4)+7) - , -8 - (140/4*5) - , (13-(2-1)) / 3 - ] - -fillInResult :: [[Equation Expr]] -fillInResult = [level1, level2, level3] - where - level1 = - let x = variable "x" in - [ x-2 :==: 2 - , -4*x :==: -28 - , -8*x :==: 72 - , x+4 :==: 09 - , 4+x :==: 2 - , -10-x :==: -7 - , x/(-8) :==: -3 - , 11-x :==: 14 - ] - - level2 = - let x = variable "x" in - [ -5-3*x :==: -23 - , 21/x - 4 :==: 3 - , -3*(x+3) :==: -27 - , 2-5*x :==: 47 - , 18/(7-x) :==: 6 - , -77/x + 4 :==: -7 - , -7-(x/(-5)) :==: -15 - , -18/(-3+x) :==: 3 - ] - - level3 = - let x = variable "x" in - [ -5*(5-(3-x)) :==: -20 - , (-20-x)/(-5)-2 :==: 3 - , 4-(x-14)/(-3) :==: 1 - , 3*x - 3 - 7 :==: 8 - , -42/(-2*x+2) :==: 7 - , 3*(4+x+2) :==: 12 - , -6-(-54/(-3*x)) :==: -12 - , 14-(x-3)/4 :==: 3 - ] - -coverUpEquations :: [[Equation Expr]] -coverUpEquations = [level1, level2] - where - level1 = - let x = variable "x" in - [ 38-7*x :==: 3 - , sqrt (125/x) :==: 5 - , 4*(12-x) + 7 :==: 35 - , 5*x^2 :==: 80 - , 5*(5-x) :==: 35 - , 32/sqrt x :==: 8 - , (21/x)-8 :==: -1 - , 180/x^2 :==: 5 - , 3*(x-8)^2 :==: 12 - , (8-x)/3 + 7 :==: 9 - ] - - level2 = - let x = variable "x" in - [ sqrt (x+9)/2 :==: 3 - , (4*x-18)^2 :==: 4 - , 3*(13-2*x)^2 - 20 :==: 55 - , 5*((x/3) - 8)^2 :==: 20 - , (6/sqrt (x-7))^3 :==: 8 - , 8-(15/sqrt (31-x)) :==: 5 - , sqrt (4*(x^2-21)) :==: 4 - , 3 + (44/sqrt (87 + x)) :==: 7 - , 13-(56 / (21 + (70/(3+x)))) :==: 12 - , 12/(2+(24/(8+(28/(2+9/x))))) :==: 3 - ] - -linearEquations :: [[Equation Expr]] -linearEquations = [level1, level2, level3, level4, level5] - where - level1 :: [Equation Expr] - level1 = - let x = variable "x" in - [ 5*x + 3 :==: 18 - , 11*x - 12 :==: 21 - , 19 - 3*x :==: -5 - , -12 + 5*x :==: 33 - , 15 - 9*x :==: 6 - , 4*x + 18 :==: 0 - , 11*x - 12 :==: -34 - , -2*x - 3 :==: -4 - , 6*x - 12 :==: 2 - , -4*x - 13 :==: -11 - ] - - level2 :: [Equation Expr] - level2 = - let x = variable "x" in - [ 6*x-2 :==: 2*x+14 - , 3+6*x :==: 3*x+24 - , 5*x+7 :==: 2*x - 10 - , 2*x-8 :==: 18 - x - , 4*x - 6 :==: 7*x - 14 - , -1 -5*x :==: 3*x - 20 - , 4*x - 7 :==: -5*x - 24 - , 4*x - 18 :==: 14 + 11*x - , 17 :==: 4 - 10*x - , -5*x + 6 :==: 2 - 3*x - ] - - level3 :: [Equation Expr] - level3 = - let x = variable "x" in - [ 4*(x-1) :==: 11*x - 12 - , 4*(x-4) :==: 5*(2*x+1) - , 2*(5-3*x) :==: 6-x - , 4*x - (x-2) :==: 12 + 5*(x-1) - , -3*(x-2) :==: 3*(x+4) - 7 - , 3*(4*x-1) + 3 :==: 7*x - 14 - , 4*(4*x - 1) - 2 :==: -3*x + 3*(2*x -5) - , 2*x - (3*x + 5) :==: 10 + 5*(x-1) - , -5*(x+1) :==: 9*(x+4)-5 - , 18 - 2*(4*x + 2) :==: 7*x - 4*(4*x -2) - ] - - level4 :: [Equation Expr] - level4 = - let x = variable "x" in - [ (1/2)*x - 4 :==: 2*x + 2+(1/2) - , (1/4)*x + (1/2) :==: (5/2)*x + 2 - , (1/4)*x - (3/4) :==: 2*x + (1/2) - , -(1/2)*x + (3/4) :==: (5/2)*x + 3 - , -(1/2)*x + 1+(1/2) :==: 2*x - 5 - , -(1/3)*x + (3/4) :==: (1/4)*x + (1/6) - , (3/4)*x - (1/3) :==: (2/3)*x - (3/4) - , (2/5)*x - (1/4) :==: (1/2)*x + (3/4) - , (2/3)*x - 2 :==: (1/5)*x - (3/5) - , (-1+(2/5))*x + 3+(1/2) :==: (3/5)*x + (9/10) - ] - - level5 :: [Equation Expr] - level5 = - let x = variable "x" in - [ (1/4)*(x-3) :==: (1/2)*x - 4 - , (x+3)/2 :==: 5*((1/2)*x + 1 + (1/2)) - , (1/2)*(7-(2/3)*x) :==: 2 + (1/9)*x - , (3/4)*x - (x-1) :==: 3 + (2+(1/2))*(x-1) - , -(5/4)*(x-7) :==: (3/4)*(x+2) - (4+(1/2)) - , 3*((1/5)*x - 1) + 5 :==: 7*x - 14 - , ((5*x - 1) / 6) - 2 :==: -4*x + (3*x - 6)/2 - , 2*x - ((2*x+2)/5) :==: 12 + (x-1)/6 - , (-3*(x+2))/6 :==: 9*((2/3)*x + (1/3)) - (5/3) - , 1 - ((4*x + 2)/3) :==: 3*x - ((5*x - 1) / 4) - ] - -quadraticEquations :: [[Equation Expr]] -quadraticEquations = [level1, level2, level3, level4, level5, level6] - where - level1 = - let x = variable "x" in - [ x^2 :==: 2 - , x^2+3 :==: 52 - , x^2-7 :==: 0 - , 9*x^2 - 6 :==: 75 - , 32 - 2*x^2 :==: 14 - , 2*(x^2 - 3) :==: 12 - , (1/4)*x^2 + 12 :==: 16 - , (x-1)^2 :==: 100 - , 14 - 2*x^2 :==: 6 - , (1/4)*(17-x^2) :==: 2 - ] - - level2 = - let x = variable "x" in - [ (x-7)^2 + 3 :==: 11 - , (6-2*x)^2 :==: 81 - , (1/2)*(x+9)^2 :==: 4 - , (3-x^2)/10 :==: 2 - , 5*x^2 + 3*x :==: 3*x + 2 - , 11 - (2*x + 1)^2 :==: 5 - , (6*x - 3)^2 + 6 :==: 12 - , (7+2*x)^2 :==: 7 - , 4 - (x^2 / 10) :==: 6 - , 12 - (2*x + 3)^2 :==: 6 - ] - - level3 = - let x = variable "x" in - [ x^2 :==: 5*x - , x^2 - 6*x :==: 0 - , 6*x + x^2 :==: 0 - , x*(x+4) :==: 0 - , x*(2*x-4) :==: 0 - , 3*x^2 :==: 6*x - , 3*x :==: 2*x^2 - , x*(1-6*x) :==: 0 - , (x+5)*(x-8) :==: 0 - , (3*x-1)*(x+3) :==: 0 - ] - - level4 = - let x = variable "x" in - [ x^2-2*x :==: 3 - , x^2+12*x+20 :==: 0 - , x^2-x :==: 30 - , x*(x+2) :==: 8 - , x*(x-3) :==: 4 - , 2*x+15 :==: x^2 - , 4*x :==: 12 - x^2 - , x^2 :==: 15 - 8*x - , x^2-9*x+18 :==: 0 - , x^2+14*x+24 :==: 0 - ] - - level5 = - let x = variable "x" in - [ (3*x+5)^2+(x-5)^2 :==: 40 - , 4*(10-x^2) :==: -2*x*(2*x + 10) - , x*(x+12) :==: 2*x^2 - , 3*(x-2)*(x+6) :==: 12*x - , 8*x^2+4*x-24 :==: (x+3)*(x-8) - , 3*x^2 - 11 :==: (3+2*x)^2 - , 2*x*(x-3)-3 :==: (x+2)*(x+6) - , 12*(x^2-3*x)+8 :==: 56 - , 4*x^2-6*x :==: x^2+9 - , (x+1)*(x-5) :==: (x-2)*(x-3) - ] - - level6 = - let x = variable "x" in - [ x^2+4*x-4 :==: 0 - , x^2-6*x :==: 4 - , x^2-12*x+34 :==: 0 - , 2*x^2+4*x-8 :==: 0 - , (x-4)*(x-1) :==: 11 - , (x-(7/2))^2 :==: 2*(x+4) - , x^2-3*x :==: 3*(x-2) - , (4-x)*(1-x) :==: 3*x - , 2*x^2 :==: x*(x+2)+7 - , (1-x)^2 :==: x+2 - ] - --- Ontbinden in factoren (VWO B, hoofdstuk 1) -findFactors :: [[Expr]] -findFactors = - let x = variable "x" in - [ -- (buiten haakjes brengen) - [ 4*x^2 -4*x - , 36*x^2+30*x - , -6*x^2-18*x - , 14*x^2-10*x - ] --(product-som methode) - , [ x^2+11*x+24 - , x^2-8*x+15 - , x^2-x-2 - , x^2-11*x+28 - ] - ] - -modulusEquations :: [[Equation Expr]] -modulusEquations = - let x = variable "x" in - [ [ abs (2*x + 3) :==: 2 - , abs (5 - 2*x) :==: 1 - , abs (4*x + 7) :==: 3 - , abs (11 - 3*x) :==: 15 - ] - , [ abs (x^2 + 3) :==: 9 - , abs (x^2 - 7) :==: 2 - , abs (3-x^2) :==: 6 - , abs (9-x^2) :==: 7 - ] - , [ abs (2*x^2+3) :==: 19 - , abs (3*x^2-2) :==: 1 - , abs (6-2*x^2) :==: 2 - , abs (3-(1/2)*x^2) :==: 15 - ] - , [ abs (4*x^3-72) :==: 36 - , abs (0.2*x^4 - 112) :==: 13 - , abs (2*x^4-4.25) :==: 3.75 - , abs (1.75 - 0.5*x^3) :==: 2.25 - ] - ] - -sqrtEquations :: [[Equation Expr]] -sqrtEquations = - let x = variable "x" in - [ [ 5 - 2*sqrt x :==: 1 - , 7 - 3 * sqrt x :==: 5 - , 4 - 2*sqrt x :==: -3 - , 6 - 3*sqrt x :==: 2 - ] - , [ 2*sqrt x :==: x - , 2*sqrt x :==: 3*x - , x-3*sqrt x :==: 0 - , 3*x - 5*sqrt x :==: 0 - ] - , [ x :==: sqrt (2*x + 3) - , x :==: sqrt (3*x+10) - , x :==: sqrt (4*x + 21) - , x :==: sqrt (3*x + 4) - ] - , [ 5*x :==: sqrt (50*x + 75) - , 2*x :==: sqrt (24*x + 28) - , 3*x :==: sqrt (27*x - 18) - , 2*x :==: sqrt (28*x - 40) - , 3*x :==: sqrt (3*x + 42) - , 5*x :==: sqrt (49*x + 2) - , 3*x :==: sqrt (10*x -1) - , 5*x :==: sqrt (30*x - 5) - ] - , [ x - sqrt x :==: 6 - , x - 4*sqrt x :==: 12 - , x - sqrt x :==: 12 - , x - sqrt x :==: 2 - , 2*x + sqrt x :==: 3 - , 3*x + 4*sqrt x :==: 20 - , 2*x + sqrt x :==: 15 - , 2*x - 3*sqrt x :==: 27 - ] - ] - -sqrtSubstEquations :: [[Equation Expr]] -sqrtSubstEquations = - let x = variable "x" in - [ [ 8*x^3 + 1 :==: 9*x * sqrt x - , 27*x^3 :==: 28*x*sqrt x - 1 - , x^3 + 3 :==: 4*x*sqrt x - , x^3 :==: 10*x*sqrt x - 16 - ] - , [ x^3 :==: 6*x*sqrt x + 16 - , x^3 - 24*x*sqrt x :==: 81 - , x^3 + x*sqrt x :==: 20 - , x^3 - 15 :==: 2*x*sqrt x - ] - , [ x^5 +32 :==: 33*x^2*sqrt x - , 243*x^5 - 244*x^2*sqrt x + 1 :==: 0 - , 32*x^5 + 31*x^2*sqrt x :==: 1 - , x^5 :==: 242*x^2*sqrt x + 243 - ] - , [ x^5 + 8 :==: 6*x^2*sqrt x - , x^5 :==: 9*x^2 * sqrt x - 18 - , x^5 :==: 5*x^2*sqrt x + 24 - , x^5 + 4*x^2 * sqrt x :==: 12 - ] - ] - -brokenEquations :: [[Equation Expr]] -brokenEquations = - let x = variable "x" in - [ [ (2*x^2 - 10) / (x^2+3) :==: 0 - , (7*x^2 - 21) / (2*x^2 - 5) :==: 0 - , (3*x^2 - 6) / (4*x^2+1) :==: 0 - , (4*x^2 - 24) / (6*x^2 - 2) :==: 0 - , x^2 / (x+4) :==: (3*x+4) / (x+4) - , (x^2 + 2) / (x-2) :==: (x+8) / (x-2) - , (x^2 + 6*x - 6) / (x^2 - 1) :==: (4*x + 9) / (x^2 - 1) - , (x^2 + 6) / (x^2 - 2) :==: (7*x) / (x^2 - 2) - ] - , [ (x^2 + 6*x) / (x^2 - 1) :==: (3*x + 4) / (x^2 - 1) - , (x^2 + 6) / (x - 3) :==: (5*x) / (x - 3) - , (x^2 + 4*x) / (x^2 - 4) :==: (3*x + 6) / (x^2 - 4) - , (x^2 + 2*x - 4) / (x-5) :==: (4*x + 11) / (x - 5) - , (5*x+2) / (2*x - 1) :==: (5*x + 2) / (3*x + 5) - , (x^2-9) / (4*x - 1) :==: (x^2 - 9) / (2*x + 7) - , (3*x - 2) / (2*x^2) :==: (3*x - 2) / (x^2 + 4) - , (2*x + 1) / (x^2+3*x) :==: (2*x + 1) / (5*x + 8) - ] - , [ (x^2 - 1) / (2*x + 2) :==: (x^2-1) / (x+8) - , (x^2 - 4) / (3*x - 6) :==: (x^2-4) / (2*x+1) - , (x^2 + 5*x) / (2*x^2) :==: (x^2 + 5*x) / (x^2 + 4) - , (x^2 - 3*x) / (2*x - 6) :==: (x^2 - 3*x) / (4*x + 2) - , x/(x+1) :==: 1+3/4 - , (x+2)/(3*x) :==: 1+1/3 - , (2*x+3) / (x-1) :==: 3+1/2 - , (x-3)/(1-x) :==: 1+2/5 - ] - , [ (x+4)/(x+3) :==: (x+1)/(x+2) - , (2*x+3)/(x-1) :==: (2*x-1) / (x-2) - , (3*x+6)/(3*x-1) :==: (x+4) / (x+1) - , (x+2)/(2*x+5) :==: (x+4)/(2*x-3) - , (x+5)/(2*x) +2 :==: 5 - , (3*x+4)/(x+2) - 3 :==: 2 - , (x^2)/(5*x+6) +4 :==: 5 - , (x^2)/(2*x-3) + 3 :==: 7 - ] - , [ (x-2) / (x-3) :==: x/2 - , (x+9) / (x-5) :==: 2/x - , (x+2) / (x+4) :==: 2/(x+1) - , (-3) / (x-5) :==: (x+3)/(x-1) - , (x+1)/(x+2) :==: (7*x+1) / (2*x-4) - , (2*x-7)/(5-x) :==: (x+1) / (3*x-7) - , (x+1)/(x-1) :==: (3*x-7)/(x-2) - , (3*x-7)/(x-2) :==: (7-x) / (3*x-3) - ] - ] - -infix 9 *| - --- short-hand notation for a product with a square-root -(*|) :: Expr -> Expr -> Expr -a *| b = a * sqrt b - -simplerSqrt :: [[Expr]] -simplerSqrt = - let a = Var "a" in - [ [ 9*|5 * 7*|3, 3*|2 * 2*|5, 5*|2 * 6*|7, 4*|6 * 2*|7, (6*a)*|3 * 9*|2 - , 5*|5 * (2*a)*|7, a*|6 * 7*|5, 8*|7 * a*|3 - ] - , [ sqrt 15 / 6*|3, 5*|30/sqrt 5, 4*|10 / 5*|2, 5*|21 / 2*|7, (6*a)*|35 / 3*|5 - , (5*a)*|14 / 9*|2, a*|6 / 7*|3, (a*3)*|42 / 7*|7 - ] - , [ 5/2*|2, 2/5*|3, 3/2*|5, 8/7*|6, (2*a)/3*|7, (6*a)/7*|10, (5*a)/3*|11 - , (6*a)/5*|13 - ] - , [ sqrt (2/3), sqrt (5+1/3), sqrt (1+1/2), sqrt (3+4/7), sqrt (5*a^2) - , sqrt (7*a^2), sqrt (3*a^2), sqrt (6*a^2) - ] - , [ sqrt ((2/9)*a^2), sqrt ((5/16)*a^2), sqrt ((3/25)*a^2), sqrt ((7/16)*a^2) - , ((1/3)*|2)^2, ((1/2)*|3)^2, ((2/7)*|5)^2, ((2/3)*|7)^2 - ] - ] - -simplerSqrt2 :: [[Expr]] -simplerSqrt2 = - let a = Var "a" in - [ [ (((1/7)*a)*|2)^2, (((3/5)*a)*|3)^2, (((1/3)*a)*|5)^2, (((4/7)*a)*|6)^2 - , sqrt 8 + sqrt 2, sqrt 2 + sqrt 18, sqrt 12 - sqrt 3, sqrt 7 - sqrt 28 - ] - , [ sqrt 12 + sqrt 48, sqrt 18 - sqrt 8, sqrt 45 - sqrt 20, sqrt 80 + sqrt 45 - , sqrt (50*a^2) - sqrt (32*a^2), sqrt (75*a^2) - sqrt (12*a^2) - , sqrt (27*a^2) + sqrt (3*a^2), sqrt (24*a^2) + sqrt (96*a^2) - ] - , [ sqrt 27 + 1 / sqrt 3, sqrt 24 + 5/sqrt 6, sqrt 72- 7/ sqrt 2 - , sqrt 98 - 5/sqrt 2, sqrt 24 + sqrt (1+1/2), sqrt 40 - sqrt (2+1/2) - , sqrt 75 - sqrt (1+1/3) - , sqrt (1+2/3) + sqrt 60 - ] - ] - -simplerSqrt3 :: [[Expr]] -simplerSqrt3 = - let a = Var "a" in - [ [ (2*|7 + 7*|3)^2, (sqrt 2 + 6*|3)^2, (4*|3 + 3*|2)^2, (2*|5 + sqrt 7)^2 - , (3*|6 - 4*|5)^2, (5*|3 - sqrt 2)^2, (4*|6 - 2*|7)^2, (sqrt 5 - 2*|3)^2 - ] - , [ (2*|3 - 2)^2, (5*|2 - 1)^2, (3+4*|3)^2, (2+3*|6)^2, (4*|2+3)*(4*|2 - 3) - , (sqrt 7 + sqrt 3)*(sqrt 7 - sqrt 3), (2*|2 - sqrt 5)*(2*|2 + sqrt 5) - , (6-3*|3)*(6+3*|3) - ] - , [ (a-sqrt 3)^2, (2*|6 + a)^2, (2*a + a*|5)^2, (a*|3 - (2*a)*|2)^2 - , (a-sqrt 7)*(a+sqrt 7), (3*a + 2*|3)*(3*a - 2*|3) - , (2*a + a*|2)*(2*a - a*|2), ((3*a)*|5 - a)*((3*a)*|5 + a) - ] - , [ 4/(sqrt 2 + 2), 3/(sqrt 5 + 1), 2/(sqrt 3 - 3), 5/(sqrt 6 - 2) - , 6/(sqrt 7 + sqrt 5), 4/(2*|3 + sqrt 6), 5/(3*|2 - sqrt 3) - , 2/(sqrt 11-sqrt 2) - ] - , [ 2*|3 / (sqrt 5 + sqrt 2), 6*|5 / (sqrt 7 + sqrt 3) - , 4*|3 / (sqrt 5 - sqrt 3), 8*|7 / (sqrt 6 - sqrt 5) - ] - ] diff --git a/src/Domain/Math/Examples/DWO2.hs b/src/Domain/Math/Examples/DWO2.hs deleted file mode 100644 --- a/src/Domain/Math/Examples/DWO2.hs +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Example exercises from the Digital Mathematics Environment (DWO) --- ------------------------------------------------------------------------------ -module Domain.Math.Examples.DWO2 where - -import Prelude hiding ((^)) -import Domain.Math.Expr -import Domain.Math.Data.Relation - --------------------------------------------------------------------- --- Algemene applet - -higherDegreeEquations :: [Equation Expr] -higherDegreeEquations = - let x = variable "x" in - [ x^3 + x^2 :==: 0 - , x^3 - 5*x :==: 0 - , x^3 - 11*x^2 + 18*x :==: 0 - , x^3 + 36*x :==: 13*x^2 - , x^3 + 2*x^2 :==: 24*x - , 7*x^3 :==: 8*x^2 - , x^4 :==: 9*x^2 - , 64*x^7 :==: x^5 - , x^3 - 4*x^2 - 9*x :==: 0 - , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2 - ] - --------------------------------------------------------------------- --- Havo applets - --- Havo B Voorkennis: lineaire ongelijkheden -ineqLin1 :: [[Inequality Expr]] -ineqLin1 = - let a = Var "a" in - let x = Var "x" in - [ [ 7*x - 12 :<: 5*x + 3 - , 4*(x-3) :>: 3*(x-4) - , 6*(a+1) :<: 3*(a-2)+4 - , 5 - 2*(a-3) :>: 5*(3-a) - ] - , [ 4*x+5 :<: 5*x - 3 - , (1/3)*x+10 :>: (1/2)*x - , 3*x+1 :<: 7*x + 5 - , x+6 :>: 2 - (3/4)*x - ] - , [ 5*(x-1) :<: 7*x - 1 - , -3*(4*x-1) :>: 2-(x-1) - , 2*(3*x-1) :<: 5-(2-9*x) - , 2*(x-1)-3*(x-2) :>: 6 - ] - ] - --- Havo B Voorkennis: kwadratische ongelijkheden --- (door eerst gelijkheid op te lossen) --- (level 2 uit Hoofdstuk 3) -ineqQuad1 :: [[Inequality Expr]] -ineqQuad1 = - let x = Var "x" in - [ [ x^2 +3*x-4 :<: 0 - , x^2-4*x-12 :>: 0 - , -x^2 - 4*x + 5 :<: 0 - , -x^2 + 3*x + 18 :>: 0 - , (1/2)*x^2 - 3*x - 8 :<: 0 - , -2*x^2 + 10*x :>: 0 - ] - , [ x^2 + 9*x :<: 3*x - 5 - , x^2 - x :>: 12 - , x^2 - 4.5*x :<: 7-3*x - , 2*x^2 - 10*x :>: x^2 - 3*x - , 4*x^2 + 6*x :<: x^2 + 3*x + 18 - , 2*x^2 + 6*x - 10 :>: x^2 + 2*x - 5 - ] - ] - --- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact --- (door eerst gelijkheid op te lossen) -ineqHigh :: [Inequality Expr] -ineqHigh = - let x = Var "x" in - [ 2*x^3 :>: 54 - , -0.5*x^4 :<: -40.5 - , 1 - 2*x^5 :<: -485 - , (2*x-3)^4 :>: 1 - , -(0.5*x+2)^3 :<: -1 - , 0.25*(0.5*x-2)^4 :<: 4 - ] - --- Havo B hoofdstuk 3, Hogeregraadsvgl. -higherEq1 :: [[Equation Expr]] -higherEq1 = - let x = Var "x" in - [ [ (1/3)*x^3 :==: 9 - , x^5 - 12 :==: 20 - , 1 - 8*x^3 :==: -124 - , 16 - 32*x^5 :==: - 227 - ] - , [ 3*x^4 :==: 48 - , (1/9)*x^6 + 12 :==: 93 - , 39 - 8*x^2 :==: 21 - , (1/2)*x^4 - 13 :==: 27.5 - ] - , [ 3*(2*x-1)^3 + 11 :==: 659 - , 0.5*(3*x-4)^5 + 7 :==: 23 - , 2*(0.5*x+3)^7 - 11 :==: -9 - , 5*(1-4*x)^3 + 4 :==: -621 - ] - , [ 3*(2*x + 5)^2 + 9 :==: 21 - , 2*(3*x-6)^6 - 24 :==: -22 - , -2*(4*x-5)^4 + 192 :==: -8000 - , (3-2*x)^4 + 23 :==: 279 - ] - ] - --------------------------------------------------------------------- --- VWO A/C applets - --- hoofdstuk 2 -ineqQuad2 :: [Inequality Expr] -ineqQuad2 = - let x = Var "x" in - [ x^2 + 9*x :<: 3*x - 5 - , x^2 - x :>: 12 - , x^2 - 4.5*x :<: 7 - 3*x - , 2*x^2 - 10*x :>: x^2 - 3*x - , 4*x^2 + 6*x :<: x^2 + 3*x + 18 - , 2*x^2 + 6*x - 10 :>: x^2 +2*x - 5 - ] - --------------------------------------------------------------------- --- VWO B applets - --- hoofdstuk 1 -higherEq2 :: [[Equation Expr]] -higherEq2 = - let x = Var "x" in - [ [ 2*x^3 + 9 :==: 19 - , 4*x^5 - 17 :==: 27 - , 3*x^7 + 9 :==: 62 - , 5*x^3 - 1 :==: 9 - , 6 - 5*x^3 :==: 76 - , 11 - 7*x^5 :==: 53 - , 4 - 0.2*x^7 :==: 9 - , 18 - 11*x^7 :==: 62 - ] - , [ 0.5*x^4 + 5 :==: 12 - , 5*x^6 - 37 :==: 68 - , 4*x^8 - 19 :==: 9 - , 5*x^6 + 7 :==: 97 - , 18 - 7*x^4 :==: -38 - , 3 + (1/3)*x^6 :==: 7 - , 1 - (1/9)*x^8 :==: -4 - , 47 + 15*x^8 :==: 77 - ] - , [ 18*x^8 - 11 :==: 7 - , (1/4)*x^6 + 14 :==: 30 - , 5*x^4 + 67 :==: 472 - , 5*x^4 - 1 :==: 4 - , (1/8)*x^7 + 24 :==: 40 - , 0.2*x^3 + 27 :==: 52 - , 32*x^3 + 18 :==: 22 - , 4*x^3 - 8 :==: 100 - ] - , [ 14 -2*x^3 :==: 700 - , 4-3*x^5 :==: 100 - , 14 - 11*x^7 :==: 25 - , 1 - 3*x^5 :==: 97 - , 3*(x-2)^4 + 7 :==: 37 - , 6 - (2*x-1)^3 :==: 1 - , (1/3)*(x+5)^6 - 4 :==: 3 - , 6 - 0.5*(x-1)^5 :==: 10 - ] - , [ (1/2)*(3*x-1)^4 :==: 8 - , 100-(1/3)*(4*x-3)^5 :==: 19 - , 4*(0.5*x+2)^6 + 5 :==: 9 - , 3*(2*x + 7)^3 + 11 :==: 35 - ] - -- (Ontbinden applet) - , [ x^3 - 5*x^2 + 4*x :==: 0 - , x^3 :==: 3*x^2 + 10*x - , 14*x :==: x^3 + 5*x^2 - , (1/2)*x^3 + 3*x^2 + 4*x :==: 0 - , x^3 + 6*x^2 + 9*x :==: 0 - , 5*x^2 :==: x^3 + 6*x - , x^3 - 5*x^2 :==: 6*x - , x^3 :==: 4*x^2 + 12*x - ] - , [ x^4 + 36 :==: 13*x^2 - , x^4 - 9*x^2 + 20 :==: 0 - , x^4 :==: 2*x^2 + 3 - , x^4 + 2*x^2 :==: 24 - , 7*x^2 + 18 :==: x^4 - , x^4 :==: x^2 + 12 - , 29*x^2 :==: x^4 + 100 - , 2*x^4 + 2*x^2 :==: 12 - ] - -- (abc-form applet) - , [ 4*x^4 + 4 :==: 17*x^2 - , 16*x^4 + 225 :==: 136*x^2 - , 2*x^4 - 15*x^2 + 25 :==: 0 - , 9*x^4 - 28*x^2 + 3 :==: 0 - , 3*x^4 - 14*x^2 - 5 :==: 0 - , 2*x^4 :==: x^2 + 3 - , 9*x^4 + 14*x^2 :==: 8 - , 4*x^4 - 29*x^2 - 24 :==: 0 - ] - , [ 8*x^6 - 9*x^3 + 1 :==: 0 - , 27*x^6 + 8 :==: 217*x^3 - , 2*x^6 + x^3 - 1 :==: 0 - , 8*x^6 + 31*x^3 :==: 4 - , 3*x^6 - 80*x^3 - 27 :==: 0 - , 5*x^6 :==: 39*x^3 + 8 - , 7*x^6 + 8*x^3 + 1 :==: 0 - , 4*x^6 + 2 :==: -9*x^3 - ] - ] - --------------------------------------------------------------------- --- Extra test cases - -extraIneqQuad :: [Inequality Expr] -extraIneqQuad = - let x = Var "x" in - [ x^2-x-7 :>: -100, x^2-x-7 :<: -100, x^2 :<: x^2, x :>=: x - , x^2 :>=: 0, x^2 :>: 0, x^2 :<: 0, x^2 :<=: 0 - ] diff --git a/src/Domain/Math/Examples/DWO3.hs b/src/Domain/Math/Examples/DWO3.hs deleted file mode 100644 --- a/src/Domain/Math/Examples/DWO3.hs +++ /dev/null @@ -1,482 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Example exercises from the Digital Mathematics Environment (DWO), --- see: http://www.fi.uu.nl/dwo/gr/frameset.html. --- ------------------------------------------------------------------------------ -module Domain.Math.Examples.DWO3 where - -import Prelude hiding ((^)) -import Common.Rewriting -import Domain.Math.Expr - ----------------------------------------------------------- --- HAVO B applets - -simplerPowers :: [[Expr]] -simplerPowers = [level1, level2, level3, level4] - where - a = variable "a" - b = variable "b" - level1 = - [ 4*a^3 * 5*a^2 - , 14*a^6 / (-2*a^3) - , -21*a^7 / (3*a) - , 5*a * (-3)*a^2 * 2*a^3 - ] - - level2 = - [ a^2 * (-2*a)^3 - , (2*a)^5 / (-4*a)^2 - , (2*a)^4 * (-3)*a^2 - , (-3*a)^4 / (9*a^2) - ] - - level3 = - [ (a^2 * b^3)^7 - , -a^3 * (2*b)^5 * a^2 - , 3*a * (-2*b)^3 * (-a*b)^2 - , (2*a*b^3)^2 * (-3*a^2*b)^3 - ] - - level4 = - [ ((1/2)*a)^3 - (4*a)^2 * (1/4)*a - , (2*a)^5 + ((1/3)*a)^2 * (-3*a)^3 - , (2*a^3)^4 - 6*a^3 * (-a^3)^3 - , (-2*a^3)^2 - 6*(3*a)^2 * (-4*a^4) - ] - -powersOfA :: [[Expr]] -powersOfA = [level1, level2, level3, level4] - where - a = variable "a" - level1 = - [ a^3 * a^(-4) - , a^4 * (1/a^2) - , a^(-1) * a^5 - , (1/a^3) * a - ] - - level2 = - [ (a^(-2))^3 - , (a^(-3))^4 - , (1/a^6) * a^(-2) - , (1/a^2) * (1/a^4) - ] - - level3 = - [ (a^(-2))^3 * (1/a^4) - , (1/a^3)^2 - , (a^3)^2 * (1/a) - , (a^(-2))^(-3) * a^(-4) - ] - - level4 = - [ (a^(-1))^2 / a^3 - , (a^2)^(-3) / a^(-1) - , ((a^(-2))^4 / (a^2)^3) * a - , (1/a^(-3))^4 * (1/a)^3 - ] - -nonNegExp :: [[Expr]] -nonNegExp = [level1, level2] - where - a = variable "a" - b = variable "b" - level1 = - [ a * b^(-2) - , a^(-1) * b^2 - , a^(-2) * b^(-3) - , (1/a^(-3)) * (b^(-2))^2 - ] - - level2 = - [ (1/(a*b)^(-2)) * a * b^(-1) - , (2*a)^(-1) / (4*b)^(-2) - , (4*a*b)^(-1) * (b^2)^(-3) - , (5*a)^(-2) * 10*b^(-1) - ] - --- schrijf als een macht van x -powersOfX :: [[Expr]] -powersOfX = - [ [root x 3, 1/root x 4, sqrt (1/x), (x^2) / (root (x^2) 5)] - , [sqrt x/(x^2), root (x/(x^3)) 3, x*root x 3, root x 3 * root (1/(x^2)) 4] - ] - where - x = Var "x" - --- Schrijf zonder negatieve of gebroken exponenten -nonNegExp2 :: [[Expr]] -nonNegExp2 = - [ [ 4^(1/3), 5^(-(1/4)), 5*a^(1/2), 3*a^(-(1/4))] - , [ 4/(a^(-1)*b^(1/3)), a^(-1)/(8*b^(-(2/3))) - , 1/(3*a^(2/5)*b^(-1)), 3*a^(1/4)*b^(-(1/2)) - ] - ] - where - a = Var "a" - b = Var "b" - ----------------------------------------------------------- --- VWO A/C applets - --- herleid -powers1 :: [[Expr]] -powers1 = - [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7 - , 2*a^4*5*a^3, 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a - ] - , [ 5*a^4*(1/a), 8*a^4*(1/2*a^2), 2*a^6*(6/a^4), a^2*(8/a) - , (4*a^3)/(a^5), a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3) - ] - , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3 - , (-a^6)^5, (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4 - ] - , [ 6*a^5+7*a^5-4*a^9, 8*a^2-4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2 - , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7 - , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3 - ] - , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2 - , 6*a^7*(2*a^4)^3, a^17/((a^3)^5), a^9/((a^3)^2) - , a^14/((a^2)^4), a^16/((a^5)^3) - ] - ] - where - a = Var "a" - --- herleid -powers2 :: [[Expr]] -powers2 = - [ [ 4*a^3*5*a^2, (14*a^6)/(-2*a^3), (-21*a^7)/(3*a) - , 5*a*(-3*a^2)*(2*a^3) - ] - , [ a^2*(-2*a)^3, (2*a)^5/(-4*a)^2 - , (2*a)^4*(-3*(a^2)), (-3*a)^4/(9*a^2) - ] - , [ (a^2*b^3)^7, (-a)^3*(2*b)^5*a^2 - , 3*a*(-2*b)^3*(-a*b)^2, (2*a*b^3)^2*(-3*a^2*b)^3 - ] - , [ (2*a^3)^4-6*a^3*(-a^3)^3, (-2*a^3)^2-6*(3*a)^2*(-4*a^4) - ] - ] - where - a = Var "a" - b = Var "b" - -negExp1 :: [[Expr]] -negExp1 = - [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5 - , (1/a^3)/a, a/a^7, (1/a^2)/a - ] - , [ (1/(a^4))/a^6, (1/(a^3))/a^5, (1/a^5)/a^2, 1/(a^4)/a^3 - , 1/a^3, 1/a^5, 1/a^(-4), 1/a^(-6) - ] - , [ a^8/(1/a^2), a^4/(1/a^4), (a^6)/(1/a^5), a^3/(1/a^6) - , 1/(a^3)/a^(-2), (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8) - ] - ] - where - a = Var "a" - -negExp2 :: [[Expr]] -negExp2 = - [ [ a^3*a^(-4), a^4*(1/a^2), a^(-1)*a^5, (1/a^3)*a] - , [ (a^(-2))^3,(a^(-3))^4, (1/a^6)*a^(-2), (1/a^2)*(1/a^4)] - , [ (a^(-2))^3*(1/a^4), (1/a^3)^2, (a^3)^2*(1/a), (a^(-2))^(-3)*a^(-4)] - , [ (a^(-1))^2/a^3, (a^2)^(-3)/a^(-1), ((a^(-2))^4/(a^2)^3)*a - , (1/a^(-3))^4*(1/a)^3 - ] - ] - where - a = Var "a" - -negExp3 :: [[Expr]] -negExp3 = - [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5) - , (1/4)^(-3), (1/7)^(-2), (1/2)^(-4), (1/3)^(-4) - ] - , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1) - , 5*3^(-2), 7*2^(-5), 6*5^(-2), 4*7^(-2) - ] - , [ (1/3)/(6^(-2)), (1/2)/(8^(-2)), (1/8)/4^(-2), (1/10)/5^(-2) -- original in negExp5 - , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3) - ] - ] - -negExp4 :: [[Expr]] -negExp4 = - [ [ a*b^(-2), a^(-1)*b^2, a^(-2)*b^(-3), (1/a^(-3))*(b^(-2))^2] - , [ (1/((a*b)^(-2)))*a*b^(-1), (2*a)^(-1)/(4*b)^(-2) - , (4*a*b)^(-1)*(b^2)^(-3), (5*a)^(-2) * 10*b^(-1) - ] - ] - where - a = Var "a" - b = Var "b" - -negExp5 :: [[Expr]] -negExp5 = - [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3) - , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3) - ] - , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7) - , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2) - ] - , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5) - , 9*a^(-7)*(2*b)^(-4), (a^5) / ((2*b)^(-2)), ((2*a)^(-3))/b^2 - , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4) - ] - ] - where - a = Var "a" - b = Var "b" - -brokenExp1, brokenExp1' :: [[Expr]] -brokenExp1 = - [ [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5) - , 4*a^(2/3), 2*a^(3/4), 3*a^(2/5), 4*a^(3/5) - ] - , [ 6*a^(-(1/2)), 4*a^(-(1/3)), 2*(3*a)^(-(1/4)), (3*a)^(-(1/5)) - , 5*a^(-(2/3)), 7*a^(-(3/4)), 6*a^(-(2/5)), 2*a^(-(3/7)) - ] - , [ (1/2)*a^(1/3)*b^(-(1/2)), (1/7)*a^(-(1/4))*b^(2/3), 4*a^(1/2)*b^(-(1/5)) - , 3*a^(-(3/5))*b^(1/3), (2*a)^(-(2/3)), (6*a)^(-(2/5)) - , (3*a)^(-(3/5)), (2*a)^(-(4/7)) - ] - ] - where - a = Var "a" - b = Var "b" - -brokenExp1' = - [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7 - , a*root (a^2) 3, a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6 - ] - , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3) - , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3) - ] - ] - where - a = Var "a" - -brokenExp2 :: [[Expr]] -brokenExp2 = - [ [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5 - , sqrt (a^6), root (a^6) 3, sqrt (a^4), root (a^9) 3 - ] - , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a/(1/a^2) - , root a 3/(1/a^5), (a^2*sqrt a)/(a*root a 3) - , (a^3*sqrt a)/(a^2*root (a^2) 3), (a^2*root a 5)/(a^3*root a 3) - , (a^4*root a 3)/(a^6*sqrt a) - ] - ] - where - a = Var "a" - -brokenExp3 :: [[Expr]] -brokenExp3 = - [ [root x 3, 1/root x 4, sqrt (1/x), x^2/root (x^2) 5] - , [sqrt x/x^2, root (x/x^3) 3, x*root x 3, root x 3*root (1/x^2) 4] - ] - where - x = Var "x" - ----------------------------------------------------------- --- VWO B applets (hoofdstuk 4) - --- herleiden van wortelvormen -normSqrt1 :: [[Expr]] -normSqrt1 = - [ [ 9*sqrt 5 * 7*sqrt 3, 3*sqrt 2 * 2 * sqrt 5, 5*sqrt 2*6*sqrt 7 - , 4*sqrt 6 * 2*sqrt 7, 6*a*sqrt 3*9*sqrt 2, 5*sqrt 5 * 2 * a * sqrt 7 - , a*sqrt 6 * 7 * sqrt 5, 8*sqrt 7*a*sqrt 3 - ] - , [ sqrt 15/(6*sqrt 3), (5*sqrt 30)/sqrt 5, (4*sqrt 10)/(5*sqrt 2) - , (5*sqrt 21)/(2*sqrt 7), (6*a*sqrt 35)/(3*sqrt 5), (5*a*sqrt 14)/(9*sqrt 2) - , (a*sqrt 6)/(7*sqrt 3), (3*a*sqrt 42)/(7*sqrt 7) - ] - , [ 5/(2*sqrt 2), 2/(5*sqrt 3), 3/(2*sqrt 5), 8/(7*sqrt 6), (2*a)/(3*sqrt 7) - , (6*a)/(7*sqrt 10), (5*a)/(3*sqrt 11), (6*a)/(5*sqrt 13) - ] - , [ sqrt (2/3), sqrt (5+1/3), sqrt (1+1/2), sqrt (3+4/7), sqrt (5*a^2) - , sqrt (7*a^2), sqrt (3*a^2), sqrt (6*a^2) - ] - , [ sqrt ((2/9)*a^2), sqrt ((5/16)*a^2), sqrt ((3/25)*a^2), sqrt ((7/16)*a^2) - , ((1/3)*sqrt 2)^2, ((1/2)*sqrt 3)^2, ((2/7)*sqrt 5)^2, ((2/3)*sqrt 7)^2 - ] - ] - where - a = Var "a" - -normSqrt2 :: [[Expr]] -normSqrt2 = - [ [ ((1/7)*a*sqrt 2)^2, ((3/5)*a*sqrt 3)^2, ((1/3)*a*sqrt 5)^2 - , ((4/7)*a*sqrt 6)^2, sqrt 8 + sqrt 2, sqrt 2 + sqrt 18 - , sqrt 12 - sqrt 3, sqrt 7 - sqrt 28 - ] - , [ sqrt 12 + sqrt 48, sqrt 18 - sqrt 8, sqrt 45 - sqrt 20, sqrt 80 + sqrt 45 - , sqrt (50*a^2) - sqrt (32*a^2), sqrt (75*a^2) - sqrt (12*a^2) - , sqrt (27*a^2) + sqrt (3*a^2), sqrt (24*a^2) + sqrt (96*a^2) - ] - , [ sqrt 27 + 1/sqrt 3, sqrt 24 + 5/sqrt 6, sqrt 72 - 7/sqrt 2 - , sqrt 98 - 5/sqrt 2, sqrt 24 + sqrt (1+1/2), sqrt 40 - sqrt (2+1/2) - , sqrt 75 - sqrt (1+1/3), sqrt (1+2/3) + sqrt 60 - ] - ] - where - a = Var "a" - -normSqrt3 :: [[Expr]] -normSqrt3 = - [ [ (2*sqrt 7 + 7*sqrt 3)^2, (sqrt 2+6*sqrt 3)^2, (4*sqrt 3 + 3*sqrt 2)^2 - , (2*sqrt 5 + sqrt 7)^2, (3*sqrt 6-4*sqrt 5)^2, (5*sqrt 3 - sqrt 2)^2 - , (4*sqrt 6 - 2*sqrt 7)^2, (sqrt 5 - 2*sqrt 3)^2 - ] - , [ (2*sqrt 3 - 2)^2, (5*sqrt 2-1)^2, (3+4*sqrt 3)^2, (2+3*sqrt 6)^2 - , (4*sqrt 2 + 3)*(4*sqrt 2 - 3), (sqrt 7+sqrt 3)*(sqrt 7-sqrt 3) - , (2*sqrt 2 - sqrt 5)*(2*sqrt 2 + sqrt 5), (6-3*sqrt 3)*(6+3*sqrt 3) - ] - , [ (a-sqrt 3)^2, (2*sqrt 6+a)^2, (2*a+a*sqrt 5)^2, (a*sqrt 3 - 2*a*sqrt 2)^2 - , (a-sqrt 7)*(a+sqrt 7), (3*a+2*sqrt 3)*(3*a-2*sqrt 3) - , (2*a+a*sqrt 2)*(2*a-a*sqrt 2), (3*a*sqrt 5 - a)*(3*a*sqrt 5 + a) - ] - , [ 4/ (sqrt 2 + 2), 3/(sqrt 5 + 1), 2 / (sqrt 3 - 3), 5/(sqrt 6-2) - , 6/(sqrt 7+sqrt 5), 4/(2*sqrt 3 + sqrt 6), 5/(3*sqrt 2 - sqrt 3) - , 2 / (sqrt 11 - sqrt 2) - ] - , [ (2*sqrt 3)/(sqrt 5 + sqrt 2), (6*sqrt 5)/(sqrt 7+sqrt 3) - , (4*sqrt 3)/(sqrt 5 - sqrt 3), (8*sqrt 7)/(sqrt 6 - sqrt 5) - ] - ] - where - a = Var "a" - --- Machten herleiden -normPower1 :: [[Expr]] -normPower1 = - [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7, 2*a^4*5*a^3 - , 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a - ] - , [ 5*a^4*(1/a), 8*a^4*(1/(2*a^2)), 2*a^6*(6/a^4), a^2*8/a - , (4*a^3)/a^5, a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3) - ] - , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3, (-(a^6))^5 - , (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4 - ] - , [ 6*a^5 + 7*a^5 - 4*a^9, 8*a^2 - 4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2 - , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7 - , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3 - ] - , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2, 6*a^7*(2*a^4)^3 - , a^17/(a^3)^5, a^9/(a^3)^2, a^14/(a^2)^4, a^16/(a^5)^3 - ] - ] - where - a = Var "a" - -normPower2 :: [[Expr]] -normPower2 = - [ -- one level only - [ (3*a)^3+4*a^3, (2*a^2)^3 +(4*a^3)^2, (-2*a^6)^2+(a^2)^6 - , (-3*a^2)^3+(4*a^3)^2, (4*a*b^2)^2, (2*a^2*b^3)^3 - , (3*a^2*b)^2, (-3*a^2*b^2)^4 - ] - ] - where - a = Var "a" - b = Var "b" - -normPower3, normPower3' :: [[Expr]] -normPower3 = - [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5, (1/a^3)/a, a/a^7, (1/a^2)/a - ] - , [ (1/a^4)/a^6, (1/a^3)/a^5, (1/a^5)/a^2, (1/a^4)/a^3, 1/a^3, 1/a^5 - , 1/a^(-4), 1/a^(-6) - ] - , [ a^8/(1/a^2), a^4/(1/a^4), a^6/(1/a^5), a^3/(1/a^6), (1/a^3)/a^(-2) - , (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8) - ] - ] - where - a = Var "a" -normPower3' = -- bereken zonder rekenmachine - [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5), (1/4)^(-3), (1/7)^(-2) - , (1/2)^(-4), (1/3)^(-4) - ] - , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1), 5*3^(-2), 7*2^(-5) - , 6*5^(-2), 4*7^(-2) - ] - ] - -normPower4, normPower4' :: [[Expr]] -normPower4 = - [ -- bereken zonder rekenmachine - [ (1/3)/6^(-2), (1/2)/8^(-2), (1/8)/4^(-2), (1/10)/5^(-2) - , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3) - ] - ] -normPower4' = -- schrijf zonder negatieve exponenten - [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3) - , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3) - ] - , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7) - , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2) - ] - , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5) - , 9*a^(-7)*(2*b)^(-4), a^5/(2*b)^(-2), (2*a)^(-3)/b^2 - , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4) - ] - ] - where - a = Var "a" - b = Var "b" - -normPower5, normPower5' :: [[Expr]] -normPower5 = - [ -- schrijf zonder negatieve en gebroken exponent - [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5), (4*a)^(2/3) - , 2*a^(3/4), (3*a)^(2/5), 4*a^(3/5) - ] - , [ 6*a^(-1/2), 4*a^(-1/3), 2*(3*a)^(-1/4), (3*a)^(-1/5), 5*a^(-2/3) - , 7*a^(-3/4), 6*a^(-2/5), 2*a^(-3/7) - ] - , [ (1/2)*a^(1/3)*b^(-1/2), (1/7)*a^(-1/4)*b^(2/3), 4*a^(1/2)*b^(-1/5) - , 3*a^(-3/5)*b^(1/3), (2*a)^(-2/3), (6*a)^(-2/5), (3*a)^(-3/5), (2*a)^(-4/7) - ] - ] - where - a = Var "a" - b = Var "b" -normPower5' = -- schrijf als macht van a - [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7, a*root (a^2) 3 - , a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6 - ] - , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3) - , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3) - ] - ] - where - a = Var "a" - -normPower6 :: [[Expr]] -normPower6 = - [ -- schrijf als macht van a - [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5, sqrt (a^6) - , root (a^6) 3, sqrt (a^4), root (a^9) 3 - ] - , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a / (1/a^2), root a 3/(1/a^5) - , (a^2*sqrt a)/(a*root a 3), (a^3*sqrt a)/(a^2*root (a^2) 3) - , (a^2*root a 5)/(a^3*root a 3), (a^4*root a 3)/(a^6*sqrt a) - ] - ] - where - a = Var "a" diff --git a/src/Domain/Math/Examples/DWO4.hs b/src/Domain/Math/Examples/DWO4.hs deleted file mode 100644 --- a/src/Domain/Math/Examples/DWO4.hs +++ /dev/null @@ -1,502 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Example exercises from the Digital Mathematics Environment (DWO), --- see: http://www.fi.uu.nl/dwo/gr/frameset.html. --- ------------------------------------------------------------------------------ -module Domain.Math.Examples.DWO4 - ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit - , powerEquations, expEquations, logEquations, higherPowerEquations - , rootEquations, rootEquations2, rootSubstEquations, expEquations2 - ) where - -import Prelude hiding ((^)) -import Common.Rewriting -import Domain.Math.Data.Relation -import Domain.Math.Expr - ----------------------------------------------------------- --- HAVO B applets - --- Hoofdstuk 7, vergelijkingen met machten algebraisch (6) -powerEquations :: [[Equation Expr]] -powerEquations = - -- los vergelijkingen algebraisch op - let x = Var "x" in - [ [ x^14 :==: 25 - , x^(-7) :==: 110 - , 2*x^(3.5) :==: 70 - , 8*x^(-(9.2)) :==: 1000 - ] - , [ root x 5 :==: 2.9 - , 5 * root x 3 :==: 7 - , root (x^3) 4 :==: 720 - , root (x^2) 5 :==: 5.5 - ] - , [ 4*x^(-12) :==: 28 - , 7*x^(5.1) + 16 :==: 100 - , 8*x^(-((1.9))) - 5 :==: 2 - , 0.8 * x^(0.7) + 7 :==: 12.5 - ] - , [ 4*root x 7 + 7 :==: 11.8 - , 9*x^(3.2)+17 :==: 37 - , 6*x^(-(3.1))-9 :==: 12 - , 0.7 * x^(-(1.1)) + 17 :==: 40 - ] - ] - --- Hoofdstuk 7, exponentiele vergelijkingen algebraisch (7) -expEquations :: [[Equation Expr]] -expEquations = - -- los exponentiele vergelijkingen algebraisch op - let x = Var "x" in - [ [ 2^x :==: 16 * sqrt 2 - , 2^(x+2) :==: 1/4 - , 3^(x-1) :==: 81 - , 3^(x+5) :==: 243/(sqrt 3) - ] - , [ 5^(2-x) :==: 0.04 - , 3^(2*x) :==: 1/9 - , 3^(1-3*x) :==: 81 - , 3^(3*x-2) :==: 3*sqrt 3 - ] - , [ 5*2^(x-1) :==: 20*sqrt 2 - , 6*5^(2-x) :==: 150 - , 2*7^(4*x-1) :==: 98 - , 8*3^(5-2*x) :==: 72*sqrt 3 - ] - , [ 2^x-7 :==: 9 - , 4^(3*x)+5 :==: 69 - , 7*3^(2*x+1) :==: 189 - , 5*2^(1-4*x)+11 :==: 51 - ] - , [ 5^(x-4) :==: (1/5)^(2*x+1) - , 7^(1-2*x) :==: 1 - , 4^(2*x-3) :==: 2*sqrt 2 - , 2*9^(1-2*x) :==: 6*sqrt 3 - ] - ] - --- Hoofdstuk 7, logaritmische vergelijkingen algebraisch (8) -logEquations :: [[Equation Expr]] -logEquations = - -- los algebraisch op - let x = Var "x" in - [ [ logBase 2 x :==: 7 - , logBase 3 (x-2) :==: 2 - , logBase 4 (x-3) :==: 1+(1/2) - , logBase 5 ((1/10)*x-3) :==: -1 - , logBase x 7 :==: 1 - , logBase x 4 :==: -1 - , logBase 2 (x^2-1) :==: 3 - , logBase (1/3) (1-5*x) :==: -1 - ] - ] - - ----------------------------------------------------------- --- VWO A/C applets - --- Hoofdstuk 5, hogeremachtswortels (1) -higherPowerEquations :: [[Equation Expr]] -higherPowerEquations = - -- bereken exacte oplossing - let x = Var "x" in - [ [ 2*x^3+9 :==: 19 - , 4*x^5-17 :==: 27 - , 3*x^7+8 :==: 62 - , 5*x^3-1 :==: 9 - , 6-5*x^3 :==: 76 - , 11-7*x^5 :==: 53 - , 4-(1/5)*x^7 :==: 9 - , 18-11*x^7 :==: 62 - ] - , [ (1/2)*x^4+5 :==: 12 - , 5*x^6-37 :==: 68 - , 4*x^8-19 :==: 9 - , 5*x^6+7 :==: 97 - , 18-7*x^4 :==: -38 - , 3+(1/3)*x^6 :==: 7 - , 1-(1/9)*x^8 :==: -4 - , 47+15*x^8 :==: 77 - ] - , [ 18*x^8-11 :==: 7 - , (1/4)*x^6+14 :==: 30 - , 5*x^4+67 :==: 472 - , 5*x^4-1 :==: 4 - , (1/8)*x^7+24 :==: 40 - , (1/5)*x^3+27 :==: 52 - , 32*x^3+18 :==: 22 - , 4*x^3-8 :==: 100 - ] - , [ 14-2*x^3 :==: 700 - , 4-3*x^5 :==: 100 - , 14-11*x^7 :==: 25 - , 1-3*x^5 :==: 97 - ] - -- Geef in twee decimalen nauwkeurig - , [ 3*x^5+7 :==: 15 - , 0.7 * x^4 - 1.3 :==: 2 - , (1/3)*x^7 :==: 720 - ] - ] - --- Hoofdstuk 5, hogeremachtswortels (2) -rootEquations :: [[Equation Expr]] -rootEquations = - -- Bereken exacte oplossing - let x = Var "x" in - let y = Var "y" in - [ [ x^4 :==: 6 - , root x 4 :==: 6 - , sqrt x :==: 10 - , root x 5 :==: 2 - ] - , [ 3*x^5-1 :==: 20 - , 3*root (x-1) 5 - 1 :==: 20 - , (1/10)*sqrt x + 2 :==: 12 - , (1/5)*x^7+8 :==: 26 - ] - , [ 3*root x 4+2 :==: 14 - , (1/2)*x^8-2 :==: 18 - , 5-2*root x 3 :==: 3 - ] - -- Maak x vrij - , [ y :==: x^5 - , y :==: 2*x^5+4 - , y :==: (1/10)*x^3-6 - , y :==: root x 7 - , y :==: 2*root x 3+8 - , y :==: (1/10)*root x 5-6 - ] - , [ y :==: 3*root x 7-6 - , y :==: (1/4)*x^9-6 - , y :==: 8+(1/2)*root x 3 - ] - ] - - - ----------------------------------------------------------- --- VWO B applets - --- Hoofdstuk 1, wortelvergelijkingen -rootEquations2 :: [[Equation Expr]] -rootEquations2 = - let x = Var "x" in - -- los algebraisch op - [ [ 5-2*sqrt x :==: 1 - , 7-3*sqrt x :==: 5 - , 4-2*sqrt x :==: -3 - , 6-3*sqrt x :==: 2 - ] - , [ 2*sqrt x :==: x - , 2*sqrt x :==: 3*x - , x-3*sqrt x :==: 0 - , 3*x-5*sqrt x :==: 0 - ] - , [ x :==: sqrt (2*x+3) - , x :==: sqrt (3*x+10) - , x :==: sqrt (4*x+21) - , x :==: sqrt (3*x+4) - ] - , [ 5*x :==: sqrt (50*x+75) - , 2*x :==: sqrt (24*x+28) - , 3*x :==: sqrt (27*x-18) - , 2*x :==: sqrt (28*x-40) - , 3*x :==: sqrt (3*x+42) - , 5*x :==: sqrt (49*x+2) - , 3*x :==: sqrt (10*x-1) - , 5*x :==: sqrt (30*x-5) - ] - , [ x-sqrt x :==: 6 - , x-4*sqrt x :==: 12 - , x-sqrt x :==: 12 - , x-sqrt x :==: 2 - , 2*x+sqrt x :==: 3 - , 3*x+4*sqrt x :==: 20 - , 2*x+sqrt x :==: 15 - , 2*x-3*sqrt x :==: 27 - ] - ] - --- Hoofdstuk 1, wortelvergelijkingen -rootSubstEquations :: [[Equation Expr]] -rootSubstEquations = - let x = Var "x" in - -- los algebraisch op - [ [ 8*x^3+1 :==: 9*x*sqrt x - , 27*x^3 :==: 28*x*sqrt x-1 - , x^3+3 :==: 4*x*sqrt x - , x^3 :==: 10*x*sqrt x-16 - ] - , [ x^3 :==: 6*x*sqrt x+16 - , x^3-24*x*sqrt x :==: 81 - , x^3+x*sqrt x :==: 20 - , x^3-15 :==: 2*x*sqrt x - ] - , [ x^5+32 :==: 33*x^2*sqrt x - , 243*x^5-244*x^2*sqrt x+1 :==: 0 - , 32*x^5+31*x^2*sqrt x :==: 1 - , x^5 :==: 242*x^2*sqrt x+243 - ] - , [ x^5+8 :==: 6*x^2*sqrt x - , x^5 :==: 9*x^2*sqrt x-18 - , x^5 :==: 5*x^2*sqrt x+24 - , x^5+4*x^2*sqrt x :==:12 - ] - ] - --- Hoofdstuk 1, gebroken vergelijkingen -brokenEquations :: [[Equation Expr]] -brokenEquations = - -- Bereken exact de oplossingen - let x = Var "x" in - [ [ (2*x^2-10) / (x^2+3) :==: 0 - , (7*x^2-21) / (2*x^2-5) :==: 0 - , (3*x^2-6) / (4*x^2+1) :==: 0 - , (4*x^2-24) / (6*x^2-2) :==: 0 - , x^2 / (x+4) :==: (3*x+4) / (x+4) - , (x^2+2) / (x-2) :==: (x+8) / (x-2) - , (x^2+6*x-6)/(x^2-1) :==: (4*x+9)/(x^2-1) - , (x^2+6)/(x^2-2) :==: (7*x)/(x^2-2) - ] - , [ (x^2+6*x)/(x^2-1) :==: (3*x+4)/(x^2-1) - , (x^2+6)/(x-3) :==: (5*x)/(x-3) - , (x^2+4*x)/(x^2-4) :==: (3*x + 6)/(x^2-4) - , (x^2+2*x-4)/(x-5) :==: (4*x+11)/(x-5) - , (5*x+2)/(2*x-1) :==: (5*x+2)/(3*x+5) - , (x^2-9)/(4*x-1) :==: (x^2-9)/(2*x+7) - , (3*x-2)/(2*x^2) :==: (3*x-2)/(x^2+4) - , (2*x+1)/(x^2+3*x) :==: (2*x+1)/(5*x+8) - ] - , [ (x^2-1)/(2*x+2) :==: (x^2-1)/(x+8) - , (x^2-4)/(3*x-6) :==: (x^2-4)/(2*x+1) - , (x^2+5*x)/(2*x^2) :==: (x^2+5*x)/(x^2+4) - , (x^2-3*x)/(2*x-6) :==: (x^2-3*x)/(4*x+2) - , x/(x+1) :==: 1 + 3/4 - , (x+2)/(3*x) :==: 1 + 1/3 - , (2*x+3)/(x-1) :==: 3 + 1/2 - , (x-3)/(1-x) :==: 1 + 2/5 - ] - , [ (x+4)/(x+3) :==: (x+1)/(x+2) - , (2*x+3)/(x-1) :==: (2*x-1) / (x-2) - , (3*x+6)/(3*x-1) :==: (x+4)/(x+1) - , (x+2)/(2*x+5) :==: (x+4)/(2*x-3) - , (x+5)/(2*x) + 2 :==: 5 - , (3*x+4)/(x+2) - 3 :==: 2 - , (x^2)/(5*x+6) + 4 :==: 5 - , (x^2)/(2*x-3) + 3 :==: 7 - ] - , [ (x-2)/(x-3) :==: x/2 - , (x+9)/(x-5) :==: 2/x - , (x+2)/(x+4) :==: 2/(x+1) - , (-3)/(x-5) :==: (x+3)/(x+1) - , (x+1)/(x+2) :==: (7*x+1)/(2*x-4) - , (2*x-7)/(5-x) :==: (x+1)/(3*x-7) - , (x+1)/(x-1) :==: (3*x-7)/(x-2) - , (3*x-7)/(x-2) :==: (7-x)/(3*x-3) - ] - ] - --- Hoofdstuk 4, gebroken vorm herleiden (1 en 1a) -normBroken :: [[Expr]] -normBroken = - -- Herleid - let x = Var "x" in - let y = Var "y" in - let a = Var "a" in - let b = Var "b" in - [ [ 7/(2*x) + 3/(5*x), 3/(2*x) + 2/(3*x), 4/(5*x)-2/(3*x) - , 2/(7*x) - 1/(4*x), 5/(6*a)+3/(7*a), 3/(8*a)+5/(3*a) - , 7/(2*a)-2/(3*a), 9/(5*a)-1/(2*a) - ] - , [ 1/x+1/y, 2/(3*x)+1/(2*y), 3/(x^2*y) - 5/(2*x*y), 2/(x*y)-7/(5*y) - , 2/a - 3/b, 4/(3*a)-2/(5*b), 2/(a*b)+4/(3*a), 7/(4*a)+3/(4*b) - ] - , [ 3+1/(2*x), 2*x+(3/(5*x)), 5/(2*x)-3, 3-5/(7*x), 5/(3*a)+1 - , 4*a+3/(2*a), 2*a-1/(3*a), 7/(5*a)-2 - ] - , [ 5/(x+2)+4/(x+3), 3/(x-1)+2/(x+3), 4/(x+5)+2/(x-3), 3/(x-2)+2/(x-3) - , 4/(x+3)-6/(x+2), 1/(x+5)-3/(x-4), 7/(x-3)-2/(x+1), 6/(x-1)-3/(x-2) - ] - , [ (x+1)/(x+2)+(x+2)/(x-3), (x-2)/(x+3)+(x-1)/(x+2), (x+3)/(x-1)+(x+2)/(x-4) - , (x-4)/(x+5)+(x-2)/(x-3), (x-1)/(x+1)-(x+2)/(x-2), (x+5)/(x+3)-(x+3)/(x+5) - , (x-1)/(x+2)-(x+4)/(x+1), (x-3)/(x-1)-(x+2)/(x+4) - ] - , [ (2*x)/(x-1)+x/(x+2), (3*x)/(x-4)+(5*x)/(x-2) - , (4*x)/(x+2)-(2*x)/(x+1), x/(x+5)-(4*x)/(x+6) - ] - ] - --- Hoofdstuk 4, gebroken vorm herleiden (2 en 2a) -normBroken2 :: [[Expr]] -normBroken2 = - -- Herleid - let x = Var "x" in - let a = Var "a" in - let p = Var "p" in - [ [ (x^2+4*x-5)/(x^2+5*x-6), (x^2+2*x-8)/(x^2+10*x+24) - , (x^2-7*x+12)/(x^2+x-20), (x^2+7*x+12)/(x^2+5*x+6) - , (a^2-a-2)/(a^2+4*a-12), (a^2-3*a-10)/(a^2-a-20) - , (a^2-2*a-15)/(a^2-3*a-18), (a^2+a-2)/(a^2+3*a+2) - ] - , [ (x^2-16)/(x^2+x-12), (x^2-2*x+1)/(x^2-1), (x^2-9)/(x^2+6*x+9) - , (x^2-7*x+6)/(x^2-1), (2*p^2+8*p)/(p^2-16), (-(p^2)+5*p)/(p^2-10*p+25) - , (p^2-4)/(4*p^2+8*p), (p^2-12*p+36)/(p^2-6*p) - ] - , [ (x^3+3*x^2+2*x)/(x^2+4*x+4), (x^3+10*x^2+24*x)/(x^2+7*x+6) - , (x^2+5*x+6)/(x^3-x^2-6*x), (x^2+3*x-4)/(x^3-6*x^2+5*x) - , (a^3+7*a^2+12*a)/(a^2+6*a+9), (a^3+7*a^2+10*a)/(a^2-a-6) - , (a^2-9)/(a^3-4*a^2+3*a), (a^2-2*a-15)/(a^3-3*a^2-10*a) - ] - ] - -deelUit :: [[Expr]] -deelUit = - let x = Var "x" in - let a = Var "a" in - let p = Var "p" in - let t = Var "t" in - [ -- laatste sommen van gebroken vorm herleiden (2), niveau 5 - [ (-6*a^2-1)/a, -2*p^2+3/(7*p), (7*t^2+4)/(-4*t), (9*x^2+8)/(8*x) - ] - , -- sommen (2a) - [ (-7*a^2-4*a-6)/(-6*a), (3*p^2+6*p-8)/p, (2*t^2-9*t-8)/(-2*t) - , (x^2+5*x+5)/(2*x), (5*a^3-4*a+2)/(9*a), (5*p^3-7*p^2+9)/(2*p) - , (-3*t^3+6*t-4)/(3*t), (4*x^3-3*x^2+4)/(7*x) - ] - ] - --- Vervolg hoofdstuk 4, gebroken vorm herleiden (2 en 2a), vanaf niveau 4 -normBrokenCon :: [[Equation Expr]] -normBrokenCon = - -- Herleid - let a = Var "a" in - let p = Var "p" in - let t = Var "t" in - let ca = symbol (newSymbol "A") in - let ct = symbol (newSymbol "T") in - let cn = symbol (newSymbol "N") in - [ [ ca :==: (p^2+2*p)/(p^2-4), ca :==: (6*p^2-18*p)/(p^2-9) - , ca :==: (p^2-1)/(-2*p^2+2*p), ca :==: (p^2-16)/(4*p^2+16*p) - , ct :==: (t^3-2*t^2)/(t^2-4), ct :==: (t^3+4*t^2)/(t^2-16) - , ct :==: (t^2-1)/(t^3+t^2), ct :==: (t^2-25)/(t^3-5*t^2) - ] - , [ cn :==: (a^4+4*a^2-5)/(a^4-1), cn :==: (a^4+5*a^2+6)/(a^4+4*a^2+3) - , cn :==: (a^4-5*a^2+6)/(a^4-7*a^2+10), cn :==: (a^4-8*a^2+16)/(a^4-5*a^2+4) - ] - ] - --- Hoofdstuk 5, exponentiele vergelijkingen exact oplossen (1, 2, 2a) -expEquations2 :: [[Equation Expr]] -expEquations2 = - let x = Var "x" in - -- los algebraisch op - -- 1 - [ [ 2^(2*x-1) :==: 1/16 - , 3^(1-x) :==: 81 - , 5^(1-2*x) :==: 1/5 - , (1/2)^(4*x-3) :==: 1/4 - , (1/3)^(5*x+2) :==: 1/3 - , 6^(3*x-2) :==: 1/216 - ] - , [ 2^(3*x+2) :==: 2*sqrt 2 - , 3^(2*x+1) :==: 9*sqrt 3 - , 5^(4*x+3) :==: 625*sqrt 5 - , (1/2)^(x+1) :==: 4 - , (1/3)^(x-3) :==: 3 - , 4^(x+2) :==: 64*root 4 3 - ] - , [ 2^(x+3) :==: (1/2)*root 2 3 - , 3^(4*x+1) :==: 27 - , 5^(-x+2) :==: 1/25 - , (1/2)^(1-x) :==: sqrt 2 - , (1/3)^(x+1) :==: (1/9)*sqrt 3 - , 2^(1-3*x) :==: (1/8)*sqrt 2 - ] - , [ 3*2^x+1 :==: 25 - , 4*3^x-9 :==: 27 - , 2*5^x+4 :==: 14 - , 5*(1/2)^x+11 :==: 51 - , 8*(1/3)^x+27 :==: 99 - , 3*(1/5)^x-35 :==: 40 - ] - , [ 2^(4*x+3) :==: 1 - , (1/2)^(2*x-1) :==: 1 - , 3^(2*x+4) :==: 1 - , (1/3)^(x-3) :==: 1 - , 4^(4*x-7) :==: 1 - , 5^(3*x-6) :==: 1 - ] - -- 2 - , [ 2^(2*x+1) :==: (1/2)^(x+2) - , 4^(2*x-1) :==: 2^(3*x+2) - , 2^(5*x-4) :==: 8^(x-3) - , (1/4)^(2*x+1) :==: 2^(6-2*x) - , (1/3)^(2*x-3) :==: 3^(4*x-3) - , 3^(3*x-2) :==: 9^(2-x) - , 27^(2*x+1) :==: 3^(2*x-5) - , 3^(5*x-1) :==: (1/9)^(2*x-1) - ] - , [ 6^(7*x-3) :==: 36^(2*x+3) - , (1/7)^(2*x-1) :==: 7^(2*x-7) - , 5^(5-2*x) :==: (1/5)^(x+2) - , 25^(4*x+1) :==: 5^(5*x-4) - , 3^(x^2) :==: (1/3)^(2*x) - , (1/2)^(x^2) :==: 2^(2*x) - , 5^(x^2) :==: 25^(3*x) - , 2^(x^2) :==: (1/8)^(-x) - ] - , [ (1/2)^(2-2*x) :==: 4^(3*x+5) - , 8^(x+1) :==: (1/2)^(x+7) - , (1/4)^(x+2) :==: 8^(2*x-1) - , 8^(2*x-3) :==: 16^(2*x+3) - , (1/3)^(x-2) :==: 9^(x+4) - , 9^(2*x-1) :==: 27^(2*x-1) - , (1/9)^(x+3) :==: 27^(2*x+2) - , 27^(3-2*x) :==: (1/3)^(4*x+3) - ] - , [ 4*2^x :==: 2^(3*x-2) - , 2^(5*x-9) :==: (1/8)*2^x - , 3^(4*x+6) :==: 27*3^x - , (1/9)*3^x :==: 3^(2-3*x) - , 3*3^x :==: (1/3)^(2*x+5) - , 4^(x+1) :==: 8*2^x - , (1/2)*2^x :==: (1/2)^x - , 9^(x+2) :==: (1/3)*3^x - ] - , [ (1/5)*5^(3*x-2) :==: 25^(x+1) - , 9*3^(2*x+1) :==: (1/3)^(4*x-3) - , 4^(3*x-5) :==: 8*2^(x+2) - , (1/2)^(3-2*x) :==: (1/4)*2^(3*x-4) - , 2^(x+2)+2^x :==: 40 - , 2^(x+4) :==: 3/4+2^(x+2) - , 2^(x-2)+2^(x+1) :==: 9 - , 2^(x+5)-2^(x+4) :==: 16 - ] - -- 2a - , [ 3^(x+2) :==: 72+3^x - , 3^(x-1)+3^(x+1) :==: 10 - , 3^(x+3)+3^(x+2) :==: 12 - , 3^x-3^(x-1) :==: 54 - ] - , [ 5^(x+1)+5^x :==: 150 - , 5^(x+1) :==: 100+5^x - , 5^(x+2)+5^x :==:1+1/25 - , 5^(x+1)+5^(x+2) :==: 30 - ] - , [ 2^(x+4)-2^(x-2) :==: 63*sqrt 2 - , 3^(x-1)+3^x :==: 12*sqrt 3 - , 5^x-5^(x-1) :==: 4*sqrt 5 - , 2^(x+2)+2^(x-3) :==: 66*sqrt 2 - ] - ] diff --git a/src/Domain/Math/Examples/DWO5.hs b/src/Domain/Math/Examples/DWO5.hs deleted file mode 100644 --- a/src/Domain/Math/Examples/DWO5.hs +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Example exercises from the Digital Mathematics Environment (DWO), --- see: http://www.fi.uu.nl/dwo/gr/frameset.html. --- ------------------------------------------------------------------------------ -module Domain.Math.Examples.DWO5 - ( diffSet1, diffSet2, diffSet3, diffSet4 - , diffSet5, diffSet6, diffSet7, diffSet8 - ) where - -import Domain.Math.Expr -import Prelude hiding ((^)) -import Data.Maybe - -differentiateLists :: [[Expr]] -> [[Expr]] -differentiateLists = map (map differentiate) - -differentiate :: Expr -> Expr -differentiate a = - let x = fromMaybe "x" (selectVar a) - in unary diffSymbol $ binary lambdaSymbol (Var x) a - ----------------------------------------------------------- --- HAVO B applets - --- Hoofdstuk 6, differentieer --- Bereken de afgeleide -diffSet1 :: [[Expr]] -diffSet1 = differentiateLists $ - let x = Var "x" in - let p = Var "p" in - let q = Var "q" in - let r = Var "r" in - [ [ 3*x^4 - 7*x^2, -x^3-5*x, 1/2*x^6-5*x^2+4, -1/3*x^3+(1+1/2)*x^2-x+1] - , [ -x^5+5*x+23, -2*p^4+5*p-12, 3/5*q^5-q^3+4*q, -2/3*r^6+1/4*r^4-3*r+7] - , -- werk eerst de haakjes weg - [ (x-2)^2, -(1-3*x)^2, (x-1)*(2*x+5), -(1-3*x)*(2*x+7)] - -- differentieer - , [x^3-x*(x+5), -2*(p+1)*(p-12), q*(q^5-q^3)+3*q^2+4, -3*r*(r-1)*(r+2)] - ] - ----------------------------------------------------------- --- VWO A/C applets - --- Hoofdstuk 7, differentieer -diffSet2 :: [[Expr]] -diffSet2 = differentiateLists $ - let x = Var "x" in - [ [ 5*x^2, -4*x^2, 10*x^2-8, -8*x^2+7] - , [ 3*x^2+4*x, -0.5*x^2-2*x, -8*x^2+7*x-3, -0.25*x^2+x-1] - , [ (x+2)^2, (5*x+7)*(4-3*x), (3*x+6)^2-8*x - , 5*(x-3)^2+5*x, 5*(x-3)^2+5*(2*x-1), -3*(x-1)*(5-9*x)-8*(x-7) ] - ] - --- Hoofdstuk 7, bereken de afgeleide: zelfde als Havo B applet - ----------------------------------------------------------- --- VWO B applets - --- Hoofdstuk 3, differentieren: zelfde als Havo B applet - --- Hoofdstuk 7 --- Gebruik de productregel -diffSet3 :: [[Expr]] -diffSet3 = differentiateLists $ - let x = Var "x" in - [ [ (x^2+2*x)*(3*x+5), (2*x^2-3*x)*(4*x+1), (3*x^3+4*x)*(x^2-2) - , (4*x^3-x)*(3*x^2+7*x), (x^2+2*x)*(x^3-4*x^2+3), (5*x-7)*(2*x^3-3*x+1) - , (3*x^2+2)*(5*x^3+4*x^2-7*x), (4*x+1)*(3*x^3-x^2+2*x) - ] - , [ (3*x+1)^2, (5*x-2)^2, (2*x+7)^2, (4*x-3)^2 - , (2*x^2-3*x)^2, (3*x^2+2)^2, 2*x^3-3*x^2, (5*x^3+7*x)^2 - ] - ] - --- Gebruik de quotientregel -diffSet4 :: [[Expr]] -diffSet4 = differentiateLists $ - let x = Var "x" in - [ [ 5/(x-1), 3/(x+2), (-2)/(x-3), (-3)/(x+4), 3/(2*x-1) - , 2/(3*x+4), (-4)/(3*x-1), (-2)/(4*x+3) - ] - , [ (x+1)/(x-2), (x-3)/(x+4), (x+5)/(x-1), (x-2)/(x+1) - , (2*x+3)/(4*x-1), (3*x-1)/(2*x+1), (4*x+3)/(3*x-2), (5*x-2)/(3*x+4) - ] - , [ (3*x^2)/(2*x^3+4), (2*x^3)/(3*x^2-1), (x^2)/(4*x^3-2) - , (3*x^3)/(5*x^2+7), (1-x^3)/(x+4), (x+3)/(2-x^2) - , (1-2*x^3)/(x+1), (x+5)/(2-3*x^2) - ] - , [ (2-x)/(x^2+1)+2*x^3, (x^3-3)/(4-x)+x^2 - , (3-2*x)/(2*x^2-3)+x^3, (2*x^3-4)/(6-5*x)+4*x^2 - ] - ] - --- differentieer x^n (n geheel), noteer zonder negatieve exponent -diffSet5 :: [[Expr]] -diffSet5 = differentiateLists $ - let x = Var "x" in - [ [ 4/x^2, 5/x^3, 2/x^4, 3/x^5, 1/9*x^2, 1/7*x^3, 1/5*x^4, 1/8*x^5 ] - , [ 3*x^2-4/(x^2), 7*x^3-2/(x^3), 2*x^4-5/(x^4), 2*x^5-6/(x^5) - , (3*x+2)/(x^3), (2*x^2-4)/x^5, (4*x-3)/x^2, (6*x^2+5)/x^4 - ] - , -- herleid de afgeleide tot 1 breuk - [ (2*x^4+3)/x^2, (2*x^5-5)/x^3, (4*x^5-1)/x^2, (4*x^4+3)/x^3 - , (3*x-1)/(7*x^2), (2*x^3+1)/(3*x^4), (x^2-2)/(3*x^3), (x+5)/(6*x^3) - ] - ] - --- differentieer x^r (r uit R), noteer zonder negatieve en gebroken exponent -diffSet6 :: [[Expr]] -diffSet6 = differentiateLists $ - let x = Var "x" in - [ [ x*root x 3, x^3*sqrt x, x*root x 5, x^4*sqrt x, 1/(x*root x 3) - , 1/(x^3*sqrt x), 1/(x*root x 5), 1/(x^4*sqrt x) - ] - , [ x^2*root (x^2) 3, x*root (x^3) 4, x^3*root (x^2) 5, x^2*root (x^3) 5 - , (x^3+1)*(2+sqrt x), (3+x^2)*(1+root x 3), (x^2+1)*(root x 3+2) - , (3+x^3)*(sqrt x+1) - ] - , [ (sqrt x + 1)^2, (x*sqrt x-3)^2, (sqrt x-2)^2, (x*sqrt x+1)^2 - , (x+2)/sqrt x, (x-3)/sqrt x, (x-4)/sqrt x, (x+5)/sqrt x - ] - , [ (x-2)/(x*sqrt x), (x+3)/(x*sqrt x), (x+4)/(x*sqrt x), (x-5)/(x*sqrt x) - , (x^2+2)/(3*sqrt x), (x^2-3)/(4*sqrt x) - , (x^2+4)/(2*sqrt x), (x^2-6)/(3*sqrt x) - ] - , [ (x+3)/(x^2*sqrt x), (x-1)/(x^3*sqrt x), (x-2)/(x^2*sqrt x) - , (x+4)/(x^3*sqrt x), (sqrt x-2)/x^2, (2*sqrt x+1)/x^2 - , (1-sqrt x)/x, (3*sqrt x+2)/x - ] - ] - --- differentieren met de kettingregel -diffSet7 :: [[Expr]] -diffSet7 = differentiateLists $ - let x = Var "x" in - [ [ 2*(x^2+3*x)^5, 3*(x^3-4*x)^6, -6*(x^2+2*x)^4, -5*(x^3-3*x^2)^3] - , [ -(2/(x^2+3*x)^5),-(3/(x^3-4*x)^6), 6/(x^2+2*x)^4, 5/(x^3-3*x^2)^3] - , [ sqrt (3*x^4-x), sqrt (x^3+5*x^2), sqrt (6*x^2+x), sqrt (7*x^3-3*x^2)] - , [ 1/sqrt (3*x-2), 1/sqrt (8*x+5), 1/sqrt (3*x-4), 1/sqrt (5*x-2)] - , [ (2*x-1)^2*sqrt (2*x-1), (3*x^2+2)*sqrt (3*x^2+2) - , (3*x+5)^3*sqrt (3*x+5), (4*x^3-7)*sqrt (4*x^3-7) - ] - ] - --- differentieren met de kettingregel gecombineerd -diffSet8 :: [[Expr]] -diffSet8 = differentiateLists $ - let x = Var "x" in - [ [ 2*x*sqrt (4*x+3), 3*x*sqrt (2*x-5), 4*x*sqrt (3*x+2), 2*x*sqrt (5*x-3)] - , [ x^2*(4*x^2-2)^3, x^3*(3*x-4)^3, x^4*(3*x^2+1)^5, x^5*(4*x+3)^4] - , [ (x+3)/sqrt (2*x-1), (x+7)/sqrt (4*x+3) - , (x-2)/sqrt (3*x+1), (x-7)/sqrt (5*x-4) - ] - , [ sqrt (2*x^2-1)/(x+3), sqrt (4*x^2+3)/(x+7) - , sqrt (3*x^2+1)/(x-2), sqrt (5*x^2-4)/(x-7) - ] - ] diff --git a/src/Domain/Math/ExerciseList.hs b/src/Domain/Math/ExerciseList.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/ExerciseList.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- All exported exercises in the mathematical domain +-- +----------------------------------------------------------------------------- +module Domain.Math.ExerciseList + ( exerciseList, viewList, scriptList, testSuiteList + ) where + +import Common.Library +import Common.Utils (Some(..)) +import Common.Utils.TestSuite +import Domain.Math.Data.Interval +import Domain.Math.Derivative.Exercises +import Domain.Math.Equation.CoverUpExercise +import Domain.Math.Expr +import Domain.Math.Numeric.Exercises +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Balance +import Domain.Math.Polynomial.Exercises +import Domain.Math.Polynomial.IneqExercises +import Domain.Math.Polynomial.LeastCommonMultiple +import Domain.Math.Polynomial.RationalExercises +import Domain.Math.Power.Equation.Exercises +import Domain.Math.Power.Exercises +import qualified Domain.Math.Numeric.Tests as MathNum +import qualified Domain.Math.Polynomial.Tests as MathPoly +import qualified Domain.Math.SquareRoot.Tests as MathSqrt + +exerciseList :: [Some Exercise] +exerciseList = + [ -- basic math + -- , Some naturalExercise + -- , Some integerExercise + -- , Some rationalExercise + Some fractionExercise + , Some coverUpExercise + , Some linearExercise + , Some linearMixedExercise + , Some balanceExercise + , Some quadraticExercise + , Some higherDegreeExercise + , Some findFactorsExercise + , Some expandExercise + , Some ineqLinearExercise + , Some ineqQuadraticExercise + , Some ineqHigherDegreeExercise + , Some rationalEquationExercise + , Some simplifyRationalExercise + -- , Some divisionBrokenExercise + , Some quadraticNoABCExercise + , Some quadraticWithApproximation + , Some derivativeExercise + , Some derivativePolyExercise + , Some derivativeProductExercise + , Some derivativeQuotientExercise + -- , Some derivativePowerExercise + , Some simplifyPowerExercise + , Some powerOfExercise + , Some nonNegBrokenExpExercise + , Some calcPowerExercise + , Some powerEqExercise + , Some expEqExercise + , Some logEqExercise +-- , Some higherPowerEqExercise + ] + +viewList :: [ViewPackage] +viewList = + [ exprVP sumView + , exprVP naturalView, exprVP naturalNF + , exprVP integerView, exprVP integerNF + , exprVP decimalFractionView + , exprVP rationalView, exprVP rationalNF + , exprVP mixedFractionView, exprVP mixedFractionNF + , exprVP doubleView, exprVP doubleNF + ] + where + exprVP :: (IsView f, Show a) => f Expr a -> ViewPackage + exprVP a = ViewPackage parseExprM (toView a) + +scriptList :: [(Id, FilePath)] +scriptList = + [ (getId linearExercise, "math.lineq-en.txt") + , (getId quadraticExercise, "math.quadreq-en.txt") + , (getId higherDegreeExercise, "math.polyeq-en.txt") + ] + +testSuiteList :: [TestSuite] +testSuiteList = [MathNum.main, MathPoly.tests, MathSqrt.tests, testMe, testLCM] diff --git a/src/Domain/Math/Expr.hs b/src/Domain/Math/Expr.hs --- a/src/Domain/Math/Expr.hs +++ b/src/Domain/Math/Expr.hs @@ -1,24 +1,18 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Expr - ( module Common.Rewriting.Term - , module Domain.Math.Expr.Data - , module Domain.Math.Expr.Parser - , module Domain.Math.Expr.Symbols - , module Domain.Math.Expr.Views - ) where - -import Domain.Math.Expr.Data -import Domain.Math.Expr.Parser -import Domain.Math.Expr.Symbols -import Domain.Math.Expr.Views -import Common.Rewriting.Term hiding (Term(..)) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr (module Export) where + +import Domain.Math.Expr.Clipboard as Export +import Domain.Math.Expr.Data as Export +import Domain.Math.Expr.Parser as Export +import Domain.Math.Expr.Symbols as Export +import Domain.Math.Expr.Views as Export diff --git a/src/Domain/Math/Expr/Clipboard.hs b/src/Domain/Math/Expr/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Clipboard.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for a clipboard, on which expressions can be placed. The clipboard +-- is part of the environment (terms that are placed in a context) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Clipboard + ( addToClipboard, addListToClipboard + , lookupClipboard, lookupListClipboard, removeClipboard + -- generalized interface + , addToClipboardG, addListToClipboardG + , lookupClipboardG, lookupListClipboardG + , maybeOnClipboardG + ) where + +import Common.Context +import Common.Rewriting +import Control.Monad +import Data.Maybe +import Domain.Math.Data.Relation +import Domain.Math.Expr.Data +import Domain.Math.Expr.Parser +import qualified Data.Map as M + +--------------------------------------------------------------------- +-- Expression variables (internal) + +newtype ExprVar a = ExprVar (Var Term) + +exprVar :: (Show a, IsTerm a) => String -> a -> ExprVar a +exprVar s a = ExprVar (makeVar showF readF s (toTerm a)) + where + showF = show . toExpr -- pretty-print as an Expr + readF = liftM toTerm . parseExprM + +readExprVar :: IsTerm a => ExprVar a -> ContextMonad a +readExprVar (ExprVar var) = do + term <- readVar var + maybeCM (fromTerm term) + +modifyExprVar :: IsTerm a => ExprVar a -> (a -> a) -> ContextMonad () +modifyExprVar (ExprVar var) f = + let safe h a = fromMaybe a (h a) + g = fmap (toTerm . f) . fromTerm + in modifyVar var (safe g) + +--------------------------------------------------------------------- +-- Clipboard variable + +newtype Key = Key String deriving (Show, Eq, Ord) + +instance (IsTerm k, Ord k, IsTerm a) => IsTerm (M.Map k a) where + toTerm = toTerm . map (\(k, a) -> toTerm k :==: toTerm a) . M.toList + fromTerm term = do + eqs <- fromTerm term + xs <- forM eqs $ \(a :==: b) -> + liftM2 (,) (fromTerm a) (fromTerm b) + return (M.fromList xs) + +instance IsTerm Key where + toTerm (Key s) = variable s + fromTerm = liftM Key . getVariable + +clipboard :: ExprVar (M.Map Key Expr) +clipboard = exprVar "clipboard" M.empty + +--------------------------------------------------------------------- +-- Interface to work with clipboard + +addToClipboard :: String -> Expr -> ContextMonad () +addToClipboard = addToClipboardG + +addListToClipboard :: [String] -> [Expr] -> ContextMonad () +addListToClipboard = addListToClipboardG + +lookupClipboard :: String -> ContextMonad Expr +lookupClipboard = lookupClipboardG + +lookupListClipboard :: [String] -> ContextMonad [Expr] +lookupListClipboard = lookupListClipboardG + +removeClipboard :: String -> ContextMonad () +removeClipboard s = + modifyExprVar clipboard (M.delete (Key s)) + +--------------------------------------------------------------------- +-- Generalized interface to work with clipboard + +addToClipboardG :: IsTerm a => String -> a -> ContextMonad () +addToClipboardG s a = modifyExprVar clipboard (M.insert (Key s) (toExpr a)) + +addListToClipboardG :: IsTerm a => [String] -> [a] -> ContextMonad () +addListToClipboardG = zipWithM_ addToClipboardG + +lookupClipboardG :: IsTerm a => String -> ContextMonad a +lookupClipboardG s = do + m <- readExprVar clipboard + expr <- maybeCM (M.lookup (Key s) m) + fromExpr expr + +maybeOnClipboardG :: IsTerm a => String -> ContextMonad (Maybe a) +maybeOnClipboardG s = do + m <- readExprVar clipboard + return (M.lookup (Key s) m >>= fromExpr) + +lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a] +lookupListClipboardG = mapM lookupClipboardG 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,278 +1,274 @@ -{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Expr.Data where - -import Common.Rewriting -import Common.Uniplate -import Common.Utils (commaList) -import Common.View -import Control.Monad -import Data.Char (isAlphaNum) -import Data.Maybe -import Data.Ratio -import Data.Typeable -import Domain.Math.Data.Relation (relationSymbols) -import Domain.Math.Expr.Symbols -import Test.QuickCheck -import qualified Common.Rewriting.Term as Term - ------------------------------------------------------------------------ --- Expression data type - -data Expr = -- Num - Expr :+: Expr - | Expr :*: Expr - | Expr :-: Expr - | Negate Expr - | Nat Integer - -- Fractional - | Expr :/: Expr - -- Floating-point - | Sqrt Expr - | Number Double -- positive only - -- Symbolic - | Var String - | Sym Symbol [Expr] - deriving (Eq, Ord, Typeable) - ------------------------------------------------------------------------ --- Numeric instances (and symbolic) - -instance Num Expr where - (+) = (:+:) - (*) = (:*:) - (-) = (:-:) - fromInteger n - | n < 0 = negate $ Nat $ abs n - | otherwise = Nat n - negate = Negate - abs = unary absSymbol - signum = unary signumSymbol - -instance Fractional Expr where - (/) = (:/:) - fromRational r - | denominator r == 1 = - fromIntegral (numerator r) - | numerator r < 0 = - Negate (fromIntegral (abs (numerator r)) :/: fromIntegral (denominator r)) - | otherwise = - fromIntegral (numerator r) :/: fromIntegral (denominator r) - -instance Floating Expr where - pi = symbol piSymbol - sqrt = Sqrt - (**) = binary powerSymbol - logBase = binary logSymbol - exp = unary expSymbol - log = unary logSymbol - sin = unary sinSymbol - tan = unary tanSymbol - cos = unary cosSymbol - asin = unary asinSymbol - atan = unary atanSymbol - acos = unary acosSymbol - sinh = unary sinhSymbol - tanh = unary tanhSymbol - cosh = unary coshSymbol - asinh = unary asinhSymbol - atanh = unary atanhSymbol - acosh = unary acoshSymbol - -instance WithFunctions Expr where - function s [a, b] - | s == plusSymbol = a :+: b - | s == timesSymbol = a :*: b - | s == minusSymbol = a :-: b - | s == divideSymbol = a :/: b - | isRootSymbol s && b == Nat 2 = Sqrt a - function s [a] - | s == negateSymbol = Negate a - function s as = Sym s as - - getFunction expr = - case expr of - a :+: b -> return (plusSymbol, [a, b]) - a :*: b -> return (timesSymbol, [a, b]) - a :-: b -> return (minusSymbol, [a, b]) - Negate a -> return (negateSymbol, [a]) - a :/: b -> return (divideSymbol, [a, b]) - Sqrt a -> return (rootSymbol, [a, Nat 2]) - Sym s as -> return (s, as) - _ -> fail "Expr.getFunction" - -instance WithVars Expr where - variable = Var - getVariable (Var s) = return s - getVariable _ = fail "Expr.getVariable" - -fromDouble :: Double -> Expr -fromDouble d - | d < 0 = negate (Number (abs d)) - | otherwise = Number d - ------------------------------------------------------------------------ --- Uniplate instance - -instance Uniplate Expr where - uniplate expr = - case getFunction expr of - Just (s, as) -> (as, function s) - _ -> ([], const expr) - ------------------------------------------------------------------------ --- Arbitrary instance - -instance Arbitrary Expr where - arbitrary = natGenerator - -- before changing this instance, check that the - -- Gaussian elimination exercise still works (with checkExercise) - {- - let syms = [plusSymbol, timesSymbol, minusSymbol, negateSymbol, divSymbol] - in sized (symbolGenerator (const [natGenerator]) syms) -} -instance CoArbitrary Expr where - coarbitrary expr = - case expr of - a :+: b -> variant (0 :: Int) . coarbitrary a . coarbitrary b - a :*: b -> variant (1 :: Int) . coarbitrary a . coarbitrary b - a :-: b -> variant (2 :: Int) . coarbitrary a . coarbitrary b - Negate a -> variant (3 :: Int) . coarbitrary a - Nat n -> variant (4 :: Int) . coarbitrary n - a :/: b -> variant (5 :: Int) . coarbitrary a . coarbitrary b - Number d -> variant (6 :: Int) . coarbitrary d - Sqrt a -> variant (7 :: Int) . coarbitrary a - Var s -> variant (8 :: Int) . coarbitrary s - Sym f xs -> variant (9 :: Int) . coarbitrary (show f) . coarbitrary xs - -symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr -symbolGenerator extras syms = f - where - f n = oneof $ map (g n) (filter (\(_, a) -> n > 0 || a == Just 0) syms) - ++ extras n - g n (s, arity) = do - i <- case arity of - Just i -> return i - Nothing -> choose (0, 5) - as <- replicateM i (f (n `div` i)) - return (function s as) - -natGenerator :: Gen Expr -natGenerator = liftM (Nat . abs) arbitrary - -varGenerator :: [String] -> Gen Expr -varGenerator xs - | null xs = error "varGenerator: empty list" - | otherwise = oneof [ return (Var x) | x <- xs ] - ------------------------------------------------------------------------ --- Pretty printer - -instance Show Expr where - show = showExpr operatorTable - -showExpr :: OperatorTable -> Expr -> String -showExpr table = rec 0 - where - rec :: Int -> Expr -> String - rec _ (Nat n) = if n>=0 then show n else "(ERROR)" ++ show n - rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d - rec _ (Var s) - | all isAlphaNum s = s - | otherwise = "\"" ++ s ++ "\"" - rec i expr = - case getFunction expr of - Just (s1, [Sym s2 [Var x, a]]) | s1 == diffSymbol && s2 == lambdaSymbol -> - parIf (i>10000) $ "D(" ++ x ++ ") " ++ rec 10001 a - -- To do: remove special case for sqrt - Just (s, [a, b]) | isRootSymbol s && b == Nat 2 -> - parIf (i>10000) $ unwords ["sqrt", rec 10001 a] - Just (s, xs) | s == listSymbol -> - "[" ++ commaList (map (rec 0) xs) ++ "]" - Just (s, as) -> - case (lookup s symbolTable, as) of - (Just (InfixLeft, n, op), [x, y]) -> - parIf (i>n) $ rec n x ++ op ++ rec (n+1) y - (Just (InfixRight, n, op), [x, y]) -> - parIf (i>n) $ rec (n+1) x ++ op ++ rec n y - (Just (InfixNon, n, op), [x, y]) -> - parIf (i>n) $ rec (n+1) x ++ op ++ rec (n+1) y - (Just (PrefixNon, n, op), [x]) -> - parIf (i>=n) $ op ++ rec (n+1) x - _ -> - parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as) - Nothing -> - error "showExpr" - - showSymbol s - | isRootSymbol s = "root" - | otherwise = show s - - symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ] - - parIf b = if b then par else id - par s = "(" ++ s ++ ")" - -type OperatorTable = [(Associativity, [(Symbol, String)])] - -data Associativity = InfixLeft | InfixRight | PrefixNon - | InfixNon - deriving (Show, Eq) - -operatorTable :: OperatorTable -operatorTable = - (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) : - [ (InfixLeft, [(plusSymbol, "+"), (minusSymbol, "-")]) -- 6 - , (PrefixNon, [(negateSymbol, "-")]) -- 6+ - , (InfixLeft, [(timesSymbol, "*"), (divideSymbol, "/")]) -- 7 - , (InfixRight, [(powerSymbol, "^")]) -- 8 - ] - - -instance Rewrite Expr - -instance Different Expr where - different = (Nat 0, Nat 1) - -instance IsTerm Expr where - toTerm (Nat n) = Term.Num n - toTerm (Number d) = Term.Float d - toTerm (Var v) = Term.Var v - toTerm expr = - case getFunction expr of - Just (s, xs) -> function s (map toTerm xs) - Nothing -> error "IsTerm Expr" - - fromTerm (Term.Num n) = return (fromInteger n) - fromTerm (Term.Float d) = return (Number d) - fromTerm (Term.Var v) = return (Var v) - fromTerm t = - case getFunction t of - Just (s, xs) -> do - ys <- mapM fromTerm xs - return (function s ys) - _ -> fail "fromTerm" - -instance IsTerm a => IsTerm [a] where - toTerm = function listSymbol . map toTerm - fromTerm a = do - xs <- isFunction listSymbol a - mapM fromTerm xs - -toExpr :: IsTerm a => a -> Expr -toExpr = fromJust . fromTerm . toTerm - -fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Data + ( Expr(..), toExpr, fromExpr, fromDouble + ) where + +import Common.Algebra.Field +import Common.Rewriting +import Common.Utils (commaList) +import Common.Utils.Uniplate +import Control.Monad +import Data.Char (isAlphaNum) +import Data.Maybe +import Data.Ratio +import Data.Typeable +import Domain.Math.Data.Relation (relationSymbols) +import Domain.Math.Expr.Symbols +import Test.QuickCheck +import qualified Common.Algebra.CoField as F + +----------------------------------------------------------------------- +-- Expression data type + +data Expr = -- Num + Expr :+: Expr + | Expr :*: Expr + | Expr :-: Expr + | Negate Expr + | Nat Integer + -- Fractional + | Expr :/: Expr + -- Floating-point + | Sqrt Expr + | Number Double -- positive only + -- Symbolic + | Var String + | Sym Symbol [Expr] + deriving (Eq, Ord, Typeable) + +----------------------------------------------------------------------- +-- Numeric instances (and symbolic) + +instance Num Expr where + (+) = (:+:) + (*) = (:*:) + (-) = (:-:) + fromInteger n + | n < 0 = negate $ Nat $ abs n + | otherwise = Nat n + negate = Negate + abs = unary absSymbol + signum = unary signumSymbol + +instance Fractional Expr where + (/) = (:/:) + fromRational r + | denominator r == 1 = + fromIntegral (numerator r) + | numerator r < 0 = + Negate (fromIntegral (abs (numerator r)) :/: fromIntegral (denominator r)) + | otherwise = + fromIntegral (numerator r) :/: fromIntegral (denominator r) + +instance Floating Expr where + pi = symbol piSymbol + sqrt = Sqrt + (**) = binary powerSymbol + logBase = binary logSymbol + exp = unary expSymbol + log = unary logSymbol + sin = unary sinSymbol + tan = unary tanSymbol + cos = unary cosSymbol + asin = unary asinSymbol + atan = unary atanSymbol + acos = unary acosSymbol + sinh = unary sinhSymbol + tanh = unary tanhSymbol + cosh = unary coshSymbol + asinh = unary asinhSymbol + atanh = unary atanhSymbol + acosh = unary acoshSymbol + +instance WithFunctions Expr where + function s [a, b] + | s == plusSymbol = a :+: b + | s == timesSymbol = a :*: b + | s == minusSymbol = a :-: b + | s == divideSymbol = a :/: b + | isRootSymbol s && b == Nat 2 = Sqrt a + function s [a] + | s == negateSymbol = Negate a + function s as = Sym s as + + getFunction expr = + case expr of + a :+: b -> return (plusSymbol, [a, b]) + a :*: b -> return (timesSymbol, [a, b]) + a :-: b -> return (minusSymbol, [a, b]) + Negate a -> return (negateSymbol, [a]) + a :/: b -> return (divideSymbol, [a, b]) + Sqrt a -> return (rootSymbol, [a, Nat 2]) + Sym s as -> return (s, as) + _ -> fail "Expr.getFunction" + +instance WithVars Expr where + variable = Var + getVariable (Var s) = return s + getVariable _ = fail "Expr.getVariable" + +fromDouble :: Double -> Expr +fromDouble d + | d < 0 = negate (Number (abs d)) + | otherwise = Number d + +----------------------------------------------------------------------- +-- Uniplate instance + +instance Uniplate Expr where + uniplate expr = + case getFunction expr of + Just (s, as) -> plate function |- s ||* as + _ -> plate expr + +----------------------------------------------------------------------- +-- Arbitrary instance + +instance Arbitrary Expr where + arbitrary = liftM fromInteger arbitrary + -- before changing this instance, check that the + -- Gaussian elimination exercise still works (with checkExercise) + {- + let syms = [plusSymbol, timesSymbol, minusSymbol, negateSymbol, divSymbol] + in sized (symbolGenerator (const [natGenerator]) syms) -} + +----------------------------------------------------------------------- +-- Pretty printer + +instance Show Expr where + show = showExpr operatorTable + +showExpr :: OperatorTable -> Expr -> String +showExpr table = rec 0 + where + rec :: Int -> Expr -> String + rec _ (Nat n) = if n>=0 then show n else "(ERROR)" ++ show n + rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d + rec _ (Var s) + | all isAlphaNum s = s + | otherwise = "\"" ++ s ++ "\"" + rec i expr = + case getFunction expr of + Just (s1, [Sym s2 [Var x, a]]) | s1 == diffSymbol && s2 == lambdaSymbol -> + parIf (i>10000) $ "D(" ++ x ++ ") " ++ rec 10001 a + Just (s, [Nat a, Nat b, Nat c]) | s == mixedFractionSymbol -> + let ok = all (>= 0) [a, b, c] + err = if ok then "" else "(ERROR)" + in err ++ show a ++ "[" ++ show b ++ "/" ++ show c ++ "]" + -- To do: remove special case for sqrt + Just (s, [a, b]) | isRootSymbol s && b == Nat 2 -> + parIf (i>10000) $ unwords ["sqrt", rec 10001 a] + Just (s, xs) | s == listSymbol -> + "[" ++ commaList (map (rec 0) xs) ++ "]" + Just (s, as) -> + case (lookup s symbolTable, as) of + (Just (InfixLeft, n, op), [x, y]) -> + parIf (i>n) $ rec n x ++ op ++ rec (n+1) y + (Just (InfixRight, n, op), [x, y]) -> + parIf (i>n) $ rec (n+1) x ++ op ++ rec n y + (Just (InfixNon, n, op), [x, y]) -> + parIf (i>n) $ rec (n+1) x ++ op ++ rec (n+1) y + (Just (PrefixNon, n, op), [x]) -> + parIf (i>=n) $ op ++ rec (n+1) x + _ -> + parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as) + Nothing -> + error "showExpr" + + showSymbol s + | isRootSymbol s = "root" + | isLogSymbol s = "log" + | otherwise = show s + + symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ] + + parIf b = if b then par else id + par s = "(" ++ s ++ ")" + +type OperatorTable = [(Associativity, [(Symbol, String)])] + +data Associativity = InfixLeft | InfixRight | PrefixNon + | InfixNon + deriving (Show, Eq) + +operatorTable :: OperatorTable +operatorTable = + (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) : + [ (InfixLeft, [(plusSymbol, "+"), (minusSymbol, "-")]) -- 6 + , (PrefixNon, [(negateSymbol, "-")]) -- 6+ + , (InfixLeft, [(timesSymbol, "*"), (divideSymbol, "/")]) -- 7 + , (InfixRight, [(powerSymbol, "^")]) -- 8 + ] + +instance SemiRing Expr where + (<+>) = (+) + zero = 0 + (<*>) = (*) + one = 1 + +instance Ring Expr where + plusInverse = negate + (<->) = (-) + +instance Field Expr where + timesInverse = recip + () = (/) + +instance F.CoSemiRing Expr where + isPlus = isPlus + isZero = (==0) + isTimes = isTimes + isOne = (==1) + +instance F.CoRing Expr where + isNegate = isNegate + isMinus = isMinus + +instance F.CoField Expr where + isRecip _ = Nothing + isDivision = isDivide + +instance Different Expr where + different = (Nat 0, Nat 1) + +instance IsTerm Expr where + toTerm (Nat n) = TNum n + toTerm (Number d) = TFloat d + toTerm (Var v) = TVar v + toTerm expr = + case getFunction expr of + Just (s, xs) -> function s (map toTerm xs) + Nothing -> error "IsTerm Expr" + + fromTerm (TNum n) = return (fromInteger n) + fromTerm (TFloat d) = return (fromDouble d) + fromTerm (TVar v) = return (Var v) + fromTerm t = + case getFunction t of + Just (s, xs) -> do + ys <- mapM fromTerm xs + return (function s ys) + _ -> fail "fromTerm" + +instance IsTerm a => IsTerm [a] where + toTerm = function listSymbol . map toTerm + fromTerm a = do + xs <- isFunction listSymbol a + mapM fromTerm xs + +toExpr :: IsTerm a => a -> Expr +toExpr = fromJust . fromTerm . toTerm + +fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a fromExpr = fromTerm . toTerm - -exprView :: IsTerm a => View Expr a -exprView = makeView fromExpr toExpr diff --git a/src/Domain/Math/Expr/Parser.hs b/src/Domain/Math/Expr/Parser.hs --- a/src/Domain/Math/Expr/Parser.hs +++ b/src/Domain/Math/Expr/Parser.hs @@ -1,133 +1,203 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Expr.Parser - ( scannerExpr, parseExpr, parseExprWith, pExpr - , pEquations, pEquation, pOrList, pFractional - , pRelation, pLogic, pLogicRelation - ) where - -import Prelude hiding ((^)) -import Text.Parsing -import Control.Monad.Error -import Common.Rewriting -import Common.Transformation -import qualified Domain.Logic.Formula as Logic -import Domain.Logic.Formula (Logic) -import Domain.Math.Data.Relation -import Domain.Math.Expr.Data -import Domain.Math.Expr.Symbols -import Domain.Math.Data.OrList -import Test.QuickCheck (arbitrary) - -scannerExpr :: Scanner -scannerExpr = defaultScanner - { keywords = ["sqrt", "root", "log", "and", "or", "true", "false", "D"] - , keywordOperators = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"] - , operatorCharacters = "+-*/^.=<>~" - , qualifiedIdentifiers = True - } - -parseExprWith :: TokenParser a -> String -> Either String a -parseExprWith = parseWithM scannerExpr - -parseExpr :: String -> Either String Expr -parseExpr = parseExprWith pExpr - -pExpr :: TokenParser Expr -pExpr = expr6 - --- This expression could have a fraction at top-level: both the numerator --- and denominator are atoms, optionally preceded by a (unary) minus -pFractional :: TokenParser Expr -pFractional = expr6u - -expr6, expr6u, expr7, expr8, term, atom :: TokenParser Expr -expr6 = pChainl ((+) <$ pKey "+" <|> (-) <$ pKey "-") expr6u -expr6u = optional (Negate <$ pKey "-") id <*> expr7 -expr7 = pChainl ((*) <$ pKey "*" <|> (/) <$ pKey "/") expr8 -expr8 = pChainr ((^) <$ pKey "^") term -term = symb <*> pList atom - <|> atom -atom = fromInteger <$> pInteger - <|> Number <$> pReal - <|> Var <$> pVarid - <|> pParens pExpr - -symb :: TokenParser ([Expr] -> Expr) -symb = qualifiedSymb - -- To fix: sqrt expects exactly one argument - <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt" - <|> function rootSymbol <$ pKey "root" - <|> function logSymbol <$ pKey "log" - <|> makeDiff <$ pKey "D" - where - makeDiff [x,a] = unary diffSymbol (binary lambdaSymbol x a) - makeDiff _ = symbol bottomSymbol - -qualifiedSymb :: TokenParser ([Expr] -> Expr) -qualifiedSymb = f <$> (pQVarid <|> pQConid) - where f (a, b) = function $ newSymbol (a, b) - -pEquations :: TokenParser a -> TokenParser (Equations a) -pEquations = pLines True . pEquation - -pEquation :: TokenParser a -> TokenParser (Equation a) -pEquation p = (:==:) <$> p <* pKey "==" <*> p - -pRelation :: TokenParser a -> TokenParser (Relation a) -pRelation p = (\x f -> f x) <$> p <*> pRelationType <*> p - -pRelationChain :: TokenParser a -> TokenParser [Relation a] -pRelationChain p = f <$> p <*> pList1 ((,) <$> pRelationType <*> p) - where - f _ [] = [] - f a ((op, b):xs) = op a b:f b xs - -pRelationType :: TokenParser (a -> a -> Relation a) -pRelationType = pChoice (map make table) - where - make (s, f) = f <$ pKey s - table = - [ ("==", (.==.)), ("<=", (.<=.)), (">=", (.>=.)) - , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.)) - ] - -pOrList :: TokenParser a -> TokenParser (OrList a) -pOrList p = (join . orList) <$> pSepList pTerm (pKey "or") - where - pTerm = return <$> p - <|> true <$ pKey "true" - <|> false <$ pKey "false" - -pLogic :: TokenParser a -> TokenParser (Logic a) -pLogic p = levelOr - where - levelOr = pChainr ((Logic.:||:) <$ pKey "or") levelAnd - levelAnd = pChainr ((Logic.:&&:) <$ pKey "and") levelAtom - levelAtom = Logic.Var <$> p - <|> Logic.F <$ pKey "false" - <|> Logic.T <$ pKey "true" - <|> pParens levelOr - -pLogicRelation :: TokenParser a -> TokenParser (Logic (Relation a)) -pLogicRelation p = (Logic.catLogic . fmap f) <$> pLogic (pRelationChain p) - where - f xs = if null xs then Logic.T else foldr1 (Logic.:&&:) (map Logic.Var xs) - ------------------------------------------------------------------------ --- Argument descriptor (for parameterized rules) - -instance Argument Expr where - makeArgDescr = exprArgDescr - -exprArgDescr :: String -> ArgDescr Expr -exprArgDescr descr = ArgDescr descr Nothing (either (const Nothing) Just . parseExpr) show arbitrary +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Parser + ( parseExpr, parseExprM + , parseEqExpr, parseBoolEqExpr, parseRelExpr + , parseOrsEqExpr, parseOrsRelExpr + , parseLogicRelExpr + , parseExprTuple + ) where + +import Common.Algebra.Boolean hiding (ors) +import Common.Classes +import Common.Id +import Common.Rewriting +import Common.Transformation +import Control.Monad +import Data.Monoid +import Domain.Logic.Formula (Logic, catLogic) +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Data.WithBool +import Domain.Math.Expr.Data +import Domain.Math.Expr.Symbols +import Prelude hiding ((^)) +import Test.QuickCheck (arbitrary) +import Text.Parsing +import qualified Text.ParserCombinators.Parsec.Token as P + +parseExpr :: String -> Either String Expr +parseExpr = parseSimple expr + +parseExprM :: Monad m => String -> m Expr +parseExprM = either fail return . parseExpr + +parseEqExpr :: String -> Either String (Equation Expr) +parseEqExpr = parseSimple (equation expr) + +parseBoolEqExpr :: String -> Either String (WithBool (Equation Expr)) +parseBoolEqExpr = parseSimple (boolAtom (equation expr)) + +parseRelExpr :: String -> Either String (Relation Expr) +parseRelExpr = parseSimple (relation expr) + +parseOrsEqExpr :: String -> Either String (OrList (Equation Expr)) +parseOrsEqExpr = parseSimple (ors (equation expr)) + +parseOrsRelExpr :: String -> Either String (OrList (Relation Expr)) +parseOrsRelExpr = parseSimple (ors (relation expr)) + +parseLogicRelExpr :: String -> Either String (Logic (Relation Expr)) +parseLogicRelExpr = parseSimple (catLogic <$> logic (relationChain expr)) + +parseExprTuple :: String -> Either String [Expr] +parseExprTuple = parseSimple (tuple expr) + +ors :: Parser a -> Parser (OrList a) +ors p = mconcat <$> sepBy1 (boolAtom p) (reserved "or") + +logic :: Parser a -> Parser (Logic a) +logic p = buildExpressionParser table (boolAtom p) + where + table = + [ [Infix ((<&&>) <$ reservedOp "and") AssocRight] + , [Infix ((<||>) <$ reservedOp "or" ) AssocRight] + ] + +boolAtom :: (Container f, BoolValue (f a)) => Parser a -> Parser (f a) +boolAtom p = choice + [ true <$ reserved "true" + , false <$ reserved "false" + , singleton <$> p + ] + +equation :: Parser a -> Parser (Equation a) +equation p = (:==:) <$> p <* reservedOp "==" <*> p + +relation :: Parser a -> Parser (Relation a) +relation p = p <**> relType <*> p + +relationChain :: Parser a -> Parser (Logic (Relation a)) +relationChain p = (\x -> ands . make x) <$> p <*> many1 ((,) <$> relType <*> p) + where + make _ [] = [] + make a ((f, b): rest) = singleton (f a b) : make b rest + +relType :: Parser (a -> a -> Relation a) +relType = choice (map make table) + where + make (s, f) = reserved s >> return f + table = + [ ("==", (.==.)), ("<=", (.<=.)), (">=", (.>=.)) + , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.)) + ] + +tuple :: Parser a -> Parser [a] +tuple p = parens (sepBy p comma) + +expr :: Parser Expr +expr = buildExpressionParser exprTable term + +term :: Parser Expr +term = choice + [ sqrt <$ reserved "sqrt" <*> atom + , binary rootSymbol <$ reserved "root" <*> atom <*> atom + , binary logSymbol <$ reserved "log" <*> atom <*> atom + , do reserved "D" + x <- identifier <|> parens identifier + a <- atom + return $ unary diffSymbol (binary lambdaSymbol (Var x) a) + , do a <- qualId + as <- many atom + return (function (newSymbol a) as) + , atom + ] + +pmixed :: Parser Expr +pmixed = do + a <- natural + P.brackets lexer $ do + b <- natural + reservedOp "/" + c <- natural + return $ mixed a b c + +atom :: Parser Expr +atom = choice + [ try pmixed + , do notFollowedBy (char '-') + either fromInteger fromDouble <$> naturalOrFloat + , variable <$> identifier + , parens expr + ] + +exprTable :: [[Operator Char () Expr]] +exprTable = + [ -- precedence level 7 + [ Infix ((^) <$ reservedOp "^") AssocRight + ] + -- precedence level 7 + , [ Infix ((*) <$ reservedOp "*") AssocLeft + , Infix ((/) <$ reservedOp "/") AssocLeft + ] + -- precedence level 6+ + , [ Prefix (negate <$ reservedOp "-") + ] + -- precedence level 6 + , [ Infix ((+) <$ reservedOp "+") AssocLeft + , Infix ((-) <$ reservedOp "-") AssocLeft + ] + ] + +-------------------------------------------------------------------------- +-- Lexing + +lexer :: P.TokenParser a +lexer = P.makeTokenParser $ emptyDef + { reservedNames = ["sqrt", "root", "log", "and", "or", "true", "false", "D"] + , reservedOpNames = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"] + } + +identifier :: Parser String +identifier = P.identifier lexer + +qualId :: CharParser st Id +qualId = try (P.lexeme lexer (do + xs <- idPart `sepBy1` char '.' + guard (length xs > 1) + return (mconcat (map newId xs))) + "qualified identifier") + where + idPart = (:) <$> letter <*> many idLetter + idLetter = alphaNum <|> oneOf "-_" + +natural :: Parser Integer +natural = P.natural lexer + +reserved :: String -> Parser () +reserved = P.reserved lexer + +reservedOp :: String -> Parser () +reservedOp = P.reservedOp lexer + +comma :: Parser String +comma = P.comma lexer + +parens :: Parser a -> Parser a +parens = P.parens lexer + +----------------------------------------------------------------------- +-- Argument descriptor (for parameterized rules) + +instance Argument Expr where + makeArgDescr descr = + ArgDescr descr Nothing parseExprM show termView arbitrary diff --git a/src/Domain/Math/Expr/Symbols.hs b/src/Domain/Math/Expr/Symbols.hs --- a/src/Domain/Math/Expr/Symbols.hs +++ b/src/Domain/Math/Expr/Symbols.hs @@ -1,138 +1,144 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Exports relevant OpenMath symbols --- ------------------------------------------------------------------------------ -module Domain.Math.Expr.Symbols - ( openMathSymbol - -- OpenMath dictionary symbols - , plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol - , powerSymbol, negateSymbol, sinSymbol, cosSymbol, lnSymbol - , diffSymbol, piSymbol, lambdaSymbol, listSymbol - , absSymbol, signumSymbol, logSymbol, expSymbol, tanSymbol, asinSymbol - , atanSymbol, acosSymbol, sinhSymbol, tanhSymbol, coshSymbol, asinhSymbol - , atanhSymbol, acoshSymbol, bottomSymbol, fcompSymbol - -- Matching - , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot - , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol - , (^), root - ) where - -import Common.Id -import Common.Rewriting -import Control.Monad -import Prelude hiding ((^)) -import qualified Text.OpenMath.Dictionary.Arith1 as OM -import qualified Text.OpenMath.Dictionary.Calculus1 as OM -import qualified Text.OpenMath.Dictionary.Fns1 as OM -import qualified Text.OpenMath.Dictionary.List1 as OM -import qualified Text.OpenMath.Dictionary.Nums1 as OM -import qualified Text.OpenMath.Dictionary.Transc1 as OM -import qualified Text.OpenMath.Symbol as OM - --- | Conversion function -openMathSymbol :: OM.Symbol -> Symbol -openMathSymbol s = newSymbol (OM.dictionary s # OM.symbolName s) - -------------------------------------------------------------- --- Arith1 dictionary - -plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol, - powerSymbol, negateSymbol, absSymbol :: Symbol - -plusSymbol = openMathSymbol OM.plusSymbol -timesSymbol = openMathSymbol OM.timesSymbol -minusSymbol = openMathSymbol OM.minusSymbol -divideSymbol = openMathSymbol OM.divideSymbol -rootSymbol = openMathSymbol OM.rootSymbol -powerSymbol = openMathSymbol OM.powerSymbol -negateSymbol = openMathSymbol OM.unaryMinusSymbol -absSymbol = openMathSymbol OM.absSymbol - -------------------------------------------------------------- --- Transc1 dictionary - -logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol, - sinhSymbol, tanhSymbol, coshSymbol :: Symbol - -logSymbol = openMathSymbol OM.logSymbol -sinSymbol = openMathSymbol OM.sinSymbol -cosSymbol = openMathSymbol OM.cosSymbol -lnSymbol = openMathSymbol OM.lnSymbol -expSymbol = openMathSymbol OM.expSymbol -tanSymbol = openMathSymbol OM.tanSymbol -sinhSymbol = openMathSymbol OM.sinhSymbol -tanhSymbol = openMathSymbol OM.tanhSymbol -coshSymbol = openMathSymbol OM.coshSymbol - -------------------------------------------------------------- --- Other dictionaries - -diffSymbol, lambdaSymbol, listSymbol, piSymbol :: Symbol - -diffSymbol = openMathSymbol OM.diffSymbol -lambdaSymbol = openMathSymbol OM.lambdaSymbol -listSymbol = openMathSymbol OM.listSymbol -piSymbol = openMathSymbol OM.piSymbol - -------------------------------------------------------------- --- Extra math symbols - -signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol, - acoshSymbol, bottomSymbol, fcompSymbol :: Symbol - -signumSymbol = newSymbol "signum" -asinSymbol = newSymbol "asin" -atanSymbol = newSymbol "atan" -acosSymbol = newSymbol "acos" -asinhSymbol = newSymbol "asinh" -atanhSymbol = newSymbol "atanh" -acoshSymbol = newSymbol "acosh" -bottomSymbol = newSymbol "error" -fcompSymbol = newSymbol "compose" - -------------------------------------------------------------- --- Some match functions - -isPlus, isTimes, isMinus, isDivide, isPower, isRoot :: - (WithFunctions a, MonadPlus m) => a -> m (a, a) -isNegate :: (WithFunctions a, MonadPlus m) => a -> m a - -isPlus = isAssoBinary plusSymbol -isTimes = isAssoBinary timesSymbol -isMinus = isBinary minusSymbol -isDivide = isBinary divideSymbol -isNegate = isUnary negateSymbol -isPower = isBinary powerSymbol -isRoot = isBinary rootSymbol - -isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol :: Symbol -> Bool - -isPowerSymbol = (== powerSymbol) -isRootSymbol = (== rootSymbol) -isLogSymbol = (== logSymbol) -isDivideSymbol = (== divideSymbol) - -infixr 8 ^ - -(^) :: WithFunctions a => a -> a -> a -(^) = binary powerSymbol - -root :: WithFunctions a => a -> a -> a -root = binary rootSymbol - --- left-associative -isAssoBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) -isAssoBinary s a = - case isFunction s a of - Just [x, y] -> return (x, y) - Just (x:xs) | length xs > 1 -> return (x, function s xs) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exports relevant OpenMath symbols +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Symbols + ( -- OpenMath dictionary symbols + plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol + , powerSymbol, negateSymbol, sinSymbol, cosSymbol, lnSymbol + , diffSymbol, piSymbol, lambdaSymbol, listSymbol + , absSymbol, signumSymbol, logSymbol, expSymbol, tanSymbol, asinSymbol + , atanSymbol, acosSymbol, sinhSymbol, tanhSymbol, coshSymbol, asinhSymbol + , atanhSymbol, acoshSymbol, bottomSymbol, fcompSymbol, mixedFractionSymbol + -- Matching + , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot + , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol + , isMixedFractionSymbol + , (^), root, mixed + ) where + +import Common.Rewriting +import Control.Monad +import Prelude hiding ((^)) +import qualified Text.OpenMath.Dictionary.Arith1 as OM +import qualified Text.OpenMath.Dictionary.Calculus1 as OM +import qualified Text.OpenMath.Dictionary.Fns1 as OM +import qualified Text.OpenMath.Dictionary.List1 as OM +import qualified Text.OpenMath.Dictionary.Nums1 as OM +import qualified Text.OpenMath.Dictionary.Transc1 as OM + +------------------------------------------------------------- +-- Arith1 dictionary + +plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol, + powerSymbol, negateSymbol, absSymbol :: Symbol + +plusSymbol = newSymbol OM.plusSymbol +timesSymbol = newSymbol OM.timesSymbol +minusSymbol = newSymbol OM.minusSymbol +divideSymbol = newSymbol OM.divideSymbol +rootSymbol = newSymbol OM.rootSymbol +powerSymbol = newSymbol OM.powerSymbol +negateSymbol = newSymbol OM.unaryMinusSymbol +absSymbol = newSymbol OM.absSymbol + +------------------------------------------------------------- +-- Transc1 dictionary + +logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol, + sinhSymbol, tanhSymbol, coshSymbol :: Symbol + +logSymbol = newSymbol OM.logSymbol +sinSymbol = newSymbol OM.sinSymbol +cosSymbol = newSymbol OM.cosSymbol +lnSymbol = newSymbol OM.lnSymbol +expSymbol = newSymbol OM.expSymbol +tanSymbol = newSymbol OM.tanSymbol +sinhSymbol = newSymbol OM.sinhSymbol +tanhSymbol = newSymbol OM.tanhSymbol +coshSymbol = newSymbol OM.coshSymbol + +------------------------------------------------------------- +-- Other dictionaries + +diffSymbol, lambdaSymbol, listSymbol, piSymbol :: Symbol + +diffSymbol = newSymbol OM.diffSymbol +lambdaSymbol = newSymbol OM.lambdaSymbol +listSymbol = newSymbol OM.listSymbol +piSymbol = newSymbol OM.piSymbol + +------------------------------------------------------------- +-- Extra math symbols + +signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol, + acoshSymbol, bottomSymbol, fcompSymbol, mixedFractionSymbol :: Symbol + +signumSymbol = newSymbol "signum" +asinSymbol = newSymbol "asin" +atanSymbol = newSymbol "atan" +acosSymbol = newSymbol "acos" +asinhSymbol = newSymbol "asinh" +atanhSymbol = newSymbol "atanh" +acoshSymbol = newSymbol "acosh" +bottomSymbol = newSymbol "error" +fcompSymbol = newSymbol "compose" + +-- support for mixed fractions +mixedFractionSymbol = newSymbol ("extra", "mixedfraction") + +------------------------------------------------------------- +-- Some match functions + +isPlus, isTimes, isMinus, isDivide, isPower, isRoot :: + (WithFunctions a, MonadPlus m) => a -> m (a, a) +isNegate :: (WithFunctions a, MonadPlus m) => a -> m a + +isPlus = isAssoBinary plusSymbol +isTimes = isAssoBinary timesSymbol +isMinus = isBinary minusSymbol +isDivide = isBinary divideSymbol +isNegate = isUnary negateSymbol +isPower = isBinary powerSymbol +isRoot = isBinary rootSymbol + +isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol, + isMixedFractionSymbol :: Symbol -> Bool + +isPowerSymbol = (== powerSymbol) +isRootSymbol = (== rootSymbol) +isLogSymbol = (== logSymbol) +isDivideSymbol = (== divideSymbol) + +isMixedFractionSymbol = (== mixedFractionSymbol) + +infixr 8 ^ + +(^) :: WithFunctions a => a -> a -> a +(^) = binary powerSymbol + +root :: WithFunctions a => a -> a -> a +root = binary rootSymbol + +mixed :: (Num a, WithFunctions a) => Integer -> Integer -> Integer -> a +mixed a b c = function mixedFractionSymbol $ map fromInteger [a, b, c] + +------------------------------------------------------------- +-- Helper + +-- left-associative +isAssoBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) +isAssoBinary s a = + case isFunction s a of + Just [x, y] -> return (x, y) + Just (x:xs) | length xs > 1 -> return (x, function s xs) _ -> fail "isAssoBinary" diff --git a/src/Domain/Math/Expr/Views.hs b/src/Domain/Math/Expr/Views.hs --- a/src/Domain/Math/Expr/Views.hs +++ b/src/Domain/Math/Expr/Views.hs @@ -1,171 +1,152 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Expr.Views where - -import Prelude hiding (recip, (^)) -import Common.Rewriting -import Common.View -import Domain.Math.Expr.Data -import Domain.Math.Expr.Symbols -import qualified Data.Set as S - ------------------------------------------------------------- --- Smart constructors - -infixr 8 .^. -infixl 7 .*., ./. -infixl 6 .-., .+. - -(.+.) :: Expr -> Expr -> Expr -Nat 0 .+. b = b -a .+. Nat 0 = a -a .+. Negate b = a .-. b -a .+. (b :+: c) = (a .+. b) .+. c -a .+. (b :-: c) = (a .+. b) .-. c -a .+. b = a :+: b - -(.-.) :: Expr -> Expr -> Expr -Nat 0 .-. b = neg b -a .-. Nat 0 = a -a .-. Negate b = a .+. b -a .-. (b :+: c) = (a .-. b) .-. c -a .-. (b :-: c) = (a .-. b) .+. c -a .-. b = a :-: b - -neg :: Expr -> Expr -neg (Nat 0) = 0 -neg (Negate a) = a -neg (a :+: b) = neg a .-. b -neg (a :-: b) = neg a .+. b -neg a = Negate a - -(.*.) :: Expr -> Expr -> Expr -Nat 0 .*. _ = Nat 0 -_ .*. Nat 0 = Nat 0 -Nat 1 .*. b = b -a .*. Nat 1 = a -Negate a .*. b = neg (a .*. b) -a .*. Negate b = neg (a .*. b) -a .*. (Nat 1 :/: b) = a ./. b -a .*. (b :*: c) = (a .*. b) .*. c -a .*. b = a :*: b - -(./.) :: Expr -> Expr -> Expr -a ./. Nat 1 = a -Negate a ./. b = neg (a ./. b) -a ./. Negate b = neg (a ./. b) -(a :/: b) ./. c = a ./. (b .*. c) -a ./. b = a :/: b - -recip :: Expr -> Expr -recip (Nat 1 :/: a) = a -recip a = Nat 1 :/: a - -(.^.) :: Expr -> Expr -> Expr -Nat 0 .^. _ = Nat 0 -Nat 1 .^. _ = Nat 1 -_ .^. Nat 0 = Nat 1 -a .^. Nat 1 = a -a .^. b = a ^ b - ------------------------------------------------------------- --- Views of binary constructors - -plusView :: View Expr (Expr, Expr) -plusView = makeView matchPlus (uncurry (.+.)) - where - matchPlus :: Match Expr (Expr, Expr) - matchPlus (a :+: b) = Just (a, b) - matchPlus (a :-: b) = Just (a, neg b) - matchPlus (Negate a) = do (x, y) <- matchPlus a - Just (neg x, neg y) - matchPlus _ = Nothing - -timesView :: View Expr (Expr, Expr) -timesView = makeView matchTimes (uncurry (.*.)) - where - matchTimes :: Match Expr (Expr, Expr) - matchTimes (a :*: b) = Just (a, b) - matchTimes (Negate a) = do (x, y) <- matchTimes a - Just (neg x, y) - matchTimes _ = Nothing - -divView :: View Expr (Expr, Expr) -divView = makeView matchDiv (uncurry (./.)) - where - matchDiv :: Match Expr (Expr, Expr) - matchDiv (a :/: b) = Just (a, b) - matchDiv (Negate a) = do (x, y) <- matchDiv a - Just (neg x, y) - matchDiv _ = Nothing - ------------------------------------------------------------- --- Some constant views - -conView :: View Expr Integer -conView = makeView f fromInteger - where - f (Nat n) = return n - f (Negate e) = fmap negate (f e) - f _ = Nothing - -fractionView :: View Expr (Integer, Integer) -- second component is positive -fractionView = divView >>> signs >>> (conView *** conView) - where - signs = makeView (Just . f) id - f (a, Negate b) = f (neg a, b) - f (a, b) = (a, b) - -------------------------------------------------------------- --- Sums and products - -sumView :: View Expr [Expr] -sumView = makeView (return . ($ []) . f False) (foldl (.+.) 0) - where - f n (a :+: b) = f n a . f n b - f n (a :-: b) = f n a . f (not n) b - f n (Negate a) = f (not n) a - f n e = if n then (neg e:) else (e:) - -simpleProductView :: View Expr (Bool, [Expr]) -simpleProductView = makeView (Just . second ($ []) . f) g - where - f (a :*: b) = f a .&&. f b - f (Negate a) = first not (f a) - f e = (False, (e:)) - - (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2) - - g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) - -productView :: View Expr (Bool, [Expr]) -productView = makeView (Just . second ($ []) . f False) g - where - f r (a :*: b) = f r a .&&. f r b - f r (a :/: b) = case a of -- two special cases (for efficiency) - Nat 1 -> f (not r) b - Negate (Nat 1) -> first not (f (not r) b) - _ -> f r a .&&. f (not r) b - f r (Negate a) = first not (f r a) - f r e = (False, if r then (recip e:) else (e:)) - - (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2) - - g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) - --- helper to determine the name of the variable (move to a different module?) -selectVar :: Expr -> Maybe String -selectVar = f . S.toList . varSet - where - f [] = Just "x" -- exceptional case (e.g., for constants) - f [a] = Just a +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Views + ( module Domain.Math.Expr.Views + , (.+.), (.-.), neg, (.*.), (./.) + ) where + +import Common.Algebra.CoField +import Common.Algebra.Group +import Common.Library +import Common.Utils.Uniplate +import Domain.Math.Expr.Data +import Domain.Math.Expr.Symbols +import Prelude hiding ((^)) +import qualified Data.Set as S + +------------------------------------------------------------ +-- Smart constructors + +infixr 8 .^. + +(.^.) :: Expr -> Expr -> Expr +Nat 0 .^. _ = Nat 0 +Nat 1 .^. _ = Nat 1 +_ .^. Nat 0 = Nat 1 +a .^. Nat 1 = a +a .^. b = a ^ b + +------------------------------------------------------------ +-- Views of binary constructors + +plusView :: View Expr (Expr, Expr) +plusView = makeView matchPlus (uncurry (.+.)) + where + matchPlus (a :+: b) = Just (a, b) + matchPlus (a :-: b) = Just (a, neg b) + matchPlus (Negate a) = do (x, y) <- matchPlus a + Just (neg x, neg y) + matchPlus _ = Nothing + +timesView :: View Expr (Expr, Expr) +timesView = makeView matchTimes (uncurry (.*.)) + where + matchTimes (a :*: b) = Just (a, b) + matchTimes (Negate a) = do (x, y) <- matchTimes a + Just (neg x, y) + matchTimes _ = Nothing + +divView :: View Expr (Expr, Expr) +divView = makeView matchDiv (uncurry (./.)) + where + matchDiv (a :/: b) = Just (a, b) + matchDiv (Negate a) = do (x, y) <- matchDiv a + Just (neg x, y) + matchDiv _ = Nothing + +------------------------------------------------------------- +-- Sums and products + +sumView :: Isomorphism Expr [Expr] +sumView = describe "View an expression as the sum of a list of elements, \ + \taking into account associativity of plus, its unit element zero, and \ + \inverse (both unary negation, and binary subtraction)." $ + "math.sum" @> sumEP + where + sumEP = (($ []) . f False) <-> foldl (.+.) 0 + + f n (a :+: b) = f n a . f n b + f n (a :-: b) = f n a . f (not n) b + f n (Negate a) = f (not n) a + f _ (Nat 0) = id + f n e = if n then (neg e:) else (e:) + +-- no distribution +simpleSumView :: Isomorphism Expr [Expr] +simpleSumView = sumEP + where + sumEP = f <-> foldl (.+) 0 + + f (a :+: b) = f a <> f b + f (a :-: b) = f a <> f (-b) + f (Nat 0) = mempty + f (Negate (Nat 0)) = mempty + f (Negate (Negate a)) = f a + f a = return a + + Nat 0 .+ b = b + a .+ Nat 0 = a + a .+ Negate b = a :-: b + a .+ b = a :+: b + +productView :: Isomorphism Expr (Bool, [Expr]) +productView = "math.product" @> productEP + where + productEP = (second ($ []) . f False) <-> g + + f r (a :*: b) = f r a .&&. f r b + f r (a :/: b) = case a of -- two special cases (for efficiency) + Nat 1 -> f (not r) b + Negate (Nat 1) -> first not (f (not r) b) + _ -> f r a .&&. f (not r) b + f r (Negate a) = first not (f r a) + f r e = (False, if r then (recip e:) else (e:)) + + (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2) + + g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) + +simpleProductView :: Isomorphism Expr (Bool, [Expr]) +simpleProductView = "math.product.simple" @> simpleProductEP + where + simpleProductEP = (second ($ []) . f) <-> g + + f (a :*: b) = f a .&&. f b + f (Nat 1) = (False, id) + f (Negate a) = first not (f a) + f e = (False, (e:)) + + (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2) + + g (b, xs) = (if b then myNeg else id) (foldl (.*) 1 xs) + + Nat 1 .* a = a + a .* Nat 1 = a + Nat 0 .* a | ok a = 0 + a .* Nat 0 | ok a = 0 + Negate a .* b = myNeg (a .* b) + a .* Negate b = myNeg (a .* b) + a .* b = a :*: b + + myNeg (Negate a) = a + myNeg a = Negate a + + ok (a :/: b) = b /= 0 && ok a && ok b -- to do: evaluate b before b/=0 + ok a = all ok (children a) + +-- helper to determine the name of the variable (move to a different module?) +selectVar :: Expr -> Maybe String +selectVar = f . S.toList . varSet + where + f [] = Just "x" -- exceptional case (e.g., for constants) + f [a] = Just a f _ = Nothing diff --git a/src/Domain/Math/Numeric/Exercises.hs b/src/Domain/Math/Numeric/Exercises.hs --- a/src/Domain/Math/Numeric/Exercises.hs +++ b/src/Domain/Math/Numeric/Exercises.hs @@ -1,69 +1,79 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Exercises - ( naturalExercise, integerExercise - , rationalExercise, fractionExercise - ) where - -import Common.Exercise -import Common.Strategy -import Common.View -import Domain.Math.Expr -import Domain.Math.Numeric.Strategies -import Domain.Math.Numeric.Views -import Domain.Math.Numeric.Generators -import Domain.Math.Examples.DWO1 (calculateResults) -import Common.Context - ------------------------------------------------------------- --- Exercises - -numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr -numericExercise s = makeExercise - { status = Alpha - , parser = parseExpr - , equivalence = viewEquivalent rationalView - , strategy = s - , navigation = termNavigator - } - -naturalExercise :: Exercise Expr -naturalExercise = (numericExercise naturalStrategy) - { exerciseId = describe "simplify expression (natural numbers)" $ - newId "numbers.natural" - , isReady = (`belongsTo` integerNormalForm) - , examples = concat calculateResults - } - -integerExercise :: Exercise Expr -integerExercise = (numericExercise integerStrategy) - { exerciseId = describe "simplify expression (integers)" $ - newId "numbers.integers" - , isReady = (`belongsTo` integerNormalForm) - , examples = concat calculateResults - } - -rationalExercise :: Exercise Expr -rationalExercise = (numericExercise rationalStrategy) - { exerciseId = describe "simplify expression (rational numbers)" $ - newId "numbers.rational" - , isReady = (`belongsTo` rationalNormalForm) - , randomExercise = simpleGenerator (rationalGenerator 5) - } - -fractionExercise :: Exercise Expr -fractionExercise = (numericExercise fractionStrategy) - { exerciseId = describe "simplify expression (fractions)" $ - newId "arithmetic.fractions" - , isReady = (`belongsTo` rationalNormalForm) - , randomExercise = simpleGenerator (rationalGenerator 5) - } +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Exercises + ( naturalExercise, integerExercise + , rationalExercise, fractionExercise + ) where + +import Common.Library +import Domain.Math.Expr +import Domain.Math.Numeric.Generators +import Domain.Math.Numeric.Strategies +import Domain.Math.Numeric.Views + +------------------------------------------------------------ +-- Exercises + +numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr +numericExercise s = makeExercise + { status = Alpha + , parser = parseExpr + , equivalence = withoutContext (viewEquivalent rationalView) + , strategy = s + , navigation = termNavigator + } + +naturalExercise :: Exercise Expr +naturalExercise = (numericExercise naturalStrategy) + { exerciseId = describe "simplify expression (natural numbers)" $ + newId "numbers.natural" + , ready = predicateView integerNF + , examples = level Medium $ concat calculateResults + } + +integerExercise :: Exercise Expr +integerExercise = (numericExercise integerStrategy) + { exerciseId = describe "simplify expression (integers)" $ + newId "numbers.integers" + , ready = predicateView integerNF + , examples = level Medium $ concat calculateResults + } + +rationalExercise :: Exercise Expr +rationalExercise = (numericExercise rationalStrategy) + { exerciseId = describe "simplify expression (rational numbers)" $ + newId "numbers.rational" + , ready = predicateView rationalNF + , randomExercise = simpleGenerator (rationalGenerator 5) + } + +fractionExercise :: Exercise Expr +fractionExercise = (numericExercise fractionStrategy) + { exerciseId = describe "simplify expression (fractions)" $ + newId "arithmetic.fractions" + , ready = predicateView rationalNF + , randomExercise = simpleGenerator (rationalGenerator 5) + } + +calculateResults :: [[Expr]] +calculateResults = [level1, level2, level3] + where + level1 = + [ -8*(-3), -3-9, 55/(-5), -6*9, -11- (-3), 6-(-9), -10+3, 6+(-5) ] + level2 = + [ -3-(6*(-3)), -12/3 - 3, -4*(2+3), 2-6*6 + , -27/(4-(-5)), (-24/(-6)) - 3, 8-(-77/(-11)), 4/(-4+5) + ] + level3 = + [ 4*(3-(6-2)), (-16-9)/5 - 3, 4- (4-13)/(-3), (3*(-3))-5-4 + , -55/(3*(-5)+4), -4*(-2+ (-4)+7), -8 - (140/4*5), (13-(2-1)) / 3 + ] diff --git a/src/Domain/Math/Numeric/Generators.hs b/src/Domain/Math/Numeric/Generators.hs --- a/src/Domain/Math/Numeric/Generators.hs +++ b/src/Domain/Math/Numeric/Generators.hs @@ -1,82 +1,109 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Generators - ( integerGenerator, rationalGenerator, numGenerator - , ratioGen, ratioExprGen, ratioExprGenNonZero, nonZero - ) where - -import Control.Monad -import Common.View -import Common.Utils (ratioGen) -import Domain.Math.Numeric.Views -import Test.QuickCheck -import Domain.Math.Expr - -------------------------------------------------------------------- --- Generators - --- tailored towards generating "int" expressions (also prevents --- division by zero) -integerGenerator :: Int -> Gen Expr -integerGenerator = symbolGenerator extras numSymbols - where - extras n = natGenerator : [ divGen n | n > 0 ] - divGen n = do - e1 <- integerGenerator (n `div` 2) - e2 <- integerGenerator (n `div` 2) - case (match integerView e1, match integerView e2) of - (Just a, Just b) - | b == 0 -> oneof $ map return - [ e1 :/: (e2 + 1), e1 :/: (e2 - 1) - , e1 :/: (1 + e2), e1 :/: (1 - e2) - ] - | a `mod` b == 0 -> - return (e1 :/: e2) - | otherwise -> do -- change numerator - i <- arbitrary - let m1 = fromInteger ((a `mod` b) + i*b) - m2 = fromInteger (b - (a `mod` b) + i*b) - oneof $ map return - [ (e1 - m1) :/: e2, (m1 - e1) :/: e2 - , (e1 + m2) :/: e2, (m2 + e1) :/: e2 - ] - _ -> error "integerGenerator" - --- Prevents division by zero -rationalGenerator :: Int -> Gen Expr -rationalGenerator = symbolGenerator extras numSymbols - where - extras n = natGenerator : [ divGen n | n > 0 ] - divGen n = do - e1 <- rationalGenerator (n `div` 2) - e2 <- rationalGenerator (n `div` 2) - case match rationalView e2 of - Just b | b == 0 -> return e1 - _ -> return (e1 :/: e2) - --- Also generates "division-by-zero" expressions -numGenerator :: Int -> Gen Expr -numGenerator = symbolGenerator (const [natGenerator]) $ - (divideSymbol, Just 2):numSymbols - -ratioExprGen :: Int -> Gen Expr -ratioExprGen n = liftM fromRational $ ratioGen n (n `div` 4) - -ratioExprGenNonZero :: Int -> Gen Expr -ratioExprGenNonZero n = liftM fromRational $ nonZero $ ratioGen n (n `div` 4) - -nonZero :: Num a => Gen a -> Gen a -nonZero = liftM (\a -> if a==0 then 1 else a) - -numSymbols :: [(Symbol, Maybe Int)] -numSymbols = (negateSymbol, Just 1) - : zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2)) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Generators + ( integerGenerator, rationalGenerator, numGenerator + , ratioGen, ratioExprGen, ratioExprGenNonZero, nonZero + ) where + +import Common.Rewriting +import Common.View +import Control.Monad +import Data.Ratio +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Test.QuickCheck + +------------------------------------------------------------------- +-- Generators + +-- tailored towards generating "int" expressions (also prevents +-- division by zero) +integerGenerator :: Int -> Gen Expr +integerGenerator = symbolGenerator extras numSymbols + where + extras n = natGenerator : [ divGen n | n > 0 ] + divGen n = do + e1 <- integerGenerator (n `div` 2) + e2 <- integerGenerator (n `div` 2) + case (match integerView e1, match integerView e2) of + (Just a, Just b) + | b == 0 -> elements + [ e1 :/: (e2 + 1), e1 :/: (e2 - 1) + , e1 :/: (1 + e2), e1 :/: (1 - e2) + ] + | a `mod` b == 0 -> + return (e1 :/: e2) + | otherwise -> do -- change numerator + i <- arbitrary + let m1 = fromInteger ((a `mod` b) + i*b) + m2 = fromInteger (b - (a `mod` b) + i*b) + elements + [ (e1 - m1) :/: e2, (m1 - e1) :/: e2 + , (e1 + m2) :/: e2, (m2 + e1) :/: e2 + ] + _ -> error "integerGenerator" + +-- Prevents division by zero +rationalGenerator :: Int -> Gen Expr +rationalGenerator = symbolGenerator extras numSymbols + where + extras n = natGenerator : [ divGen n | n > 0 ] + divGen n = do + e1 <- rationalGenerator (n `div` 2) + e2 <- rationalGenerator (n `div` 2) + case match rationalView e2 of + Just b | b == 0 -> return e1 + _ -> return (e1 :/: e2) + +-- Also generates "division-by-zero" expressions +numGenerator :: Int -> Gen Expr +numGenerator = symbolGenerator (const [natGenerator]) $ + (divideSymbol, Just 2):numSymbols + +ratioExprGen :: Int -> Gen Expr +ratioExprGen n = liftM fromRational $ ratioGen n (n `div` 4) + +ratioExprGenNonZero :: Int -> Gen Expr +ratioExprGenNonZero n = liftM fromRational $ nonZero $ ratioGen n (n `div` 4) + +nonZero :: Num a => Gen a -> Gen a +nonZero = liftM (\a -> if a==0 then 1 else a) + +numSymbols :: [(Symbol, Maybe Int)] +numSymbols = (negateSymbol, Just 1) + : zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2)) + +------------------------------------------------------------------- +-- Helpers + +symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr +symbolGenerator extras syms = f + where + f n = oneof $ map (g n) (filter (\(_, a) -> n > 0 || a == Just 0) syms) + ++ extras n + g n (s, arity) = do + i <- case arity of + Just i -> return i + Nothing -> choose (0, 5) + as <- replicateM i (f (n `div` i)) + return (function s as) + +natGenerator :: Gen Expr +natGenerator = liftM (Nat . abs) arbitrary + +-- | Prevents a bias towards small numbers +ratioGen :: Integral a => Int -> Int -> Gen (Ratio a) +ratioGen n m = do + a <- choose (-n, n) + b <- liftM (succ . abs) (choose (-m, m)) + c <- choose (1-b, b-1) + return (fromIntegral a + (fromIntegral c / fromIntegral b)) diff --git a/src/Domain/Math/Numeric/Laws.hs b/src/Domain/Math/Numeric/Laws.hs deleted file mode 100644 --- a/src/Domain/Math/Numeric/Laws.hs +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Algebraic laws, for testing purposes --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Laws - ( numLaws, testNumLaws, testNumLawsWith - , fracLaws, testFracLaws, testFracLawsWith - ) where - -import Common.TestSuite -import Test.QuickCheck - -testNumLaws :: Num a => String -> Gen a -> TestSuite -testNumLaws = testNumLawsWith (==) - -testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> TestSuite -testNumLawsWith eq s g = suite ("Num instance for " ++ s) $ - mapM_ ($ g) (numLaws eq) - -testFracLaws :: Fractional a => String -> Gen a -> TestSuite -testFracLaws = testFracLawsWith (==) - -testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> TestSuite -testFracLawsWith eq s g = suite ("Fractional instance for " ++ s) $ - mapM_ ($ g) (fracLaws eq) - -numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> TestSuite] -numLaws eq = - [ law1 "plus zero left" $ \a -> 0+a === a - , law1 "plus zero right" $ \a -> a+0 === a - , law2 "plus comm" $ \a b -> a+b === b+a - , law3 "plus trans" $ \a b c -> a+(b+c) === (a+b)+c - , law1 "negate zero" $ \a -> -0 === 0 `asTypeOf` a - , law1 "negate double" $ \a -> -(-a) === a - , law1 "minus zero left" $ \a -> 0-a === -a - , law1 "minus zero right" $ \a -> a-0 === a - , law2 "negate plus" $ \a b -> -(a+b) === -a-b - , law2 "negate minus" $ \a b -> -(a-b) === -a+b - , law2 "plus negate" $ \a b -> a+(-b) === a-b - , law1 "times zero left" $ \a -> 0*a === 0 - , law1 "times zero right" $ \a -> a*0 === 0 - , law1 "times one left" $ \a -> 1*a === a - , law1 "times one right" $ \a -> a*1 === a - , law2 "times comm" $ \a b -> a*b === b*a - , law3 "times trans" $ \a b c -> a*(b*c) === (a*b)*c - , law2 "times negate left" $ \a b -> (-a)*b === -(a*b) - , law2 "times negate right" $ \a b -> a*(-b) === -(a*b) - , law3 "times plus left" $ \a b c -> (a+b)*c === a*c + b*c - , law3 "times plus right" $ \a b c -> a*(b+c) === a*b + a*c - , law3 "times minus left" $ \a b c -> (a-b)*c === a*c - b*c - , law3 "times minus right" $ \a b c -> a*(b-c) === a*b - a*c - ] - where - infix 4 === - a === b = property (a `eq` b) - -fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> TestSuite] -fracLaws eq = - [ law3 "division numerator" $ \a b c -> (a/b)/c === a/(b*c) <| b/=0 && c/=0 - , law3 "division denominator" $ \a b c -> a/(b/c) === a*(c/b) <| b/=0 && c/=0 - , law1 "zero numerator" $ \a -> 0/a === 0 <| a/=0 - , law1 "one numerator" $ \a -> 1/a === recip a <| a/=0 - , law1 "one denominator" $ \a -> a/1 === a - , law1 "division is one" $ \a -> a/a === 1 <| a/=0 - , law1 "recip double" $ \a -> a === recip (recip a) <| a/=0 - , law3 "times division left" $ \a b c -> (a/b)*c === (a*c)/b <| b/=0 - , law3 "times division right" $ \a b c -> a*(b/c) === (a*b)/c <| c/=0 - , law3 "plus division left" $ \a b c -> (a/b)+c === (a+c*b)/b <| b/=0 - , law3 "plus division right" $ \a b c -> a+(b/c) === (a*c+b)/c <| c/=0 - , law3 "minus division left" $ \a b c -> (a/b)-c === (a-c*b)/b <| b/=0 - , law3 "minus division right" $ \a b c -> a-(b/c) === (a*c-b)/c <| c/=0 - , law2 "negate numerator" $ \a b -> a/(-b) === -(a/b) <| b/=0 - , law2 "negate denominator" $ \a b -> (-a)/b === -(a/b) <| b/=0 - , law2 "recip times" $ \a b -> recip (a*b) === recip a*recip b <| a/=0 && b/=0 - , law2 "recip division" $ \a b -> recip (a/b) === b/a <| a/=0 && b/=0 - ] - where - infix 4 === - a === b = property (a `eq` b) - infix 1 <| - p <| b = b ==> p - --- local helper-functions -law1 :: Show a => String -> (a -> Property) -> Gen a -> TestSuite -law1 s p g = addProperty s (make g id p) - -law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> TestSuite -law2 s p g = addProperty s (make g (make g id) p) - -law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> TestSuite -law3 s p g = addProperty s (make g (make g (make g id)) p) - -make :: Show a => Gen a -> (b -> Property) -> (a -> b) -> Property -make g c p = forAll g (c . p) diff --git a/src/Domain/Math/Numeric/Rules.hs b/src/Domain/Math/Numeric/Rules.hs --- a/src/Domain/Math/Numeric/Rules.hs +++ b/src/Domain/Math/Numeric/Rules.hs @@ -1,164 +1,164 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Rules where - -import Common.Transformation -import Control.Monad -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Common.View - ------------------------------------------------------------- --- Rules - -alg :: String -alg = "algebra.manipulation" - -calcRuleName :: String -> String -> String -calcRuleName opName viewName = - "arithmetic.operation." ++ viewName ++ "." ++ opName - -calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e -calcBinRule opName op m viewName v = - makeSimpleRule (calcRuleName opName viewName) $ \e -> - do (e1, e2) <- m e - a <- match v e1 - b <- match v e2 - return (build v (op a b)) - -calcPlusWith :: Num a => String -> View Expr a -> Rule Expr -calcPlusWith = calcBinRule "plus" (+) isPlus - -calcMinusWith :: Num a => String -> View Expr a -> Rule Expr -calcMinusWith = calcBinRule "minus" (-) isMinus - -calcTimesWith :: Num a => String -> View Expr a -> Rule Expr -calcTimesWith = calcBinRule "times" (*) isTimes - -calcDivisionWith :: Integral a => String -> View Expr a -> Rule Expr -calcDivisionWith viewName v = - makeSimpleRule (calcRuleName "division" viewName) $ \e -> - do (e1, e2) <- isDivide e - a <- match v e1 - b <- match v e2 - let (d, m) = divMod a b - guard (b /= 0 && m == 0) - return (build v d) - -negateZero :: Rule Expr -negateZero = makeSimpleRule (alg, "negate-zero") f - where - f (Negate (Nat n)) | n == 0 = Just 0 - f _ = Nothing - -doubleNegate :: Rule Expr -doubleNegate = makeSimpleRule (alg, "double-negate") f - where - f (Negate (Negate a)) = Just a - f _ = Nothing - -plusNegateLeft :: Rule Expr -plusNegateLeft = makeSimpleRule (alg, "plus-negate-left") f - where - f (Negate a :+: b) = Just (b :-: a) - f _ = Nothing - -plusNegateRight :: Rule Expr -plusNegateRight = makeSimpleRule (alg, "plus-negate-right") f - where - f (a :+: Negate b) = Just (a :-: b) - f _ = Nothing - -minusNegateLeft :: Rule Expr -minusNegateLeft = makeSimpleRule (alg, "minus-negate-left") f - where - f (Negate a :-: b) = Just (Negate (a :+: b)) - f _ = Nothing - -minusNegateRight :: Rule Expr -minusNegateRight = makeSimpleRule (alg, "minus-negate-right") f - where - f (a :-: Negate b) = Just (a :+: b) - f _ = Nothing - -timesNegateLeft :: Rule Expr -timesNegateLeft = makeSimpleRule (alg, "times-negate-left") f - where - f (Negate a :*: b) = Just (Negate (a :*: b)) - f _ = Nothing - -timesNegateRight :: Rule Expr -timesNegateRight = makeSimpleRule (alg, "times-negate-right") f - where - f (a :*: Negate b) = Just (Negate (a :*: b)) - f _ = Nothing - -divisionNegateLeft :: Rule Expr -divisionNegateLeft = makeSimpleRule (alg, "division-negate-left") f - where - f (Negate a :/: b) = Just (Negate (a :/: b)) - f _ = Nothing - -divisionNegateRight :: Rule Expr -divisionNegateRight = makeSimpleRule (alg, "division-negate-right") f - where - f (a :/: Negate b) = Just (Negate (a :/: b)) - f _ = Nothing - -divisionNumerator :: Rule Expr -divisionNumerator = makeSimpleRule (alg, "division-numerator") f - where - f ((a :/: b) :/: c) = Just (a :/: (b :*: c)) - f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c))) - f _ = Nothing - -divisionDenominator :: Rule Expr -divisionDenominator = makeSimpleRule (alg, "division-denominator") f - where - f (a :/: (b :/: c)) = Just ((a :*: c) :/: b) - f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b)) - f _ = Nothing - -simplerFraction :: Rule Expr -simplerFraction = makeSimpleRule (alg, "simpler-fraction") $ \expr -> do - new <- canonical rationalRelaxedForm expr - guard (expr /= new) - return new - -fractionPlus :: Rule Expr -- also minus -fractionPlus = makeSimpleRule (alg, "fraction-plus") $ \expr -> do - (e1, e2) <- match plusView expr - (a, b) <- match fractionForm e1 - (c, d) <- match fractionForm e2 - guard (b == d) - return (build fractionForm (a+c, b)) - -fractionPlusScale :: Rule Expr -- also minus -fractionPlusScale = makeSimpleRuleList (alg, "fraction-plus-scale") $ \expr -> do - (e1, e2) <- matchM plusView expr - (a, b) <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1)) - (c, d) <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2)) - guard (b /= 0 && d /= 0 && b /= d) - let bd = lcm b d - e1n = build fractionForm (a * (bd `div` b), bd) - e2n = build fractionForm (c * (bd `div` d), bd) - [ build plusView (e1n, e2) | b /= bd ] ++ [ - build plusView (e1, e2n) | d /= bd ] - -fractionTimes :: Rule Expr -fractionTimes = makeSimpleRule (alg, "fraction-times") f - where - f (e1 :*: e2) = do - (a, b) <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1)) - (c, d) <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2)) - return (build fractionForm (a*c, b*d)) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Rules where + +import Common.Transformation +import Common.View +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Numeric.Views + +------------------------------------------------------------ +-- Rules + +alg :: String +alg = "algebra.manipulation" + +calcRuleName :: String -> String -> String +calcRuleName opName viewName = + "arithmetic.operation." ++ viewName ++ "." ++ opName + +calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e +calcBinRule opName op m viewName v = + makeSimpleRule (calcRuleName opName viewName) $ \e -> + do (e1, e2) <- m e + a <- match v e1 + b <- match v e2 + return (build v (op a b)) + +calcPlusWith :: Num a => String -> View Expr a -> Rule Expr +calcPlusWith = calcBinRule "plus" (+) isPlus + +calcMinusWith :: Num a => String -> View Expr a -> Rule Expr +calcMinusWith = calcBinRule "minus" (-) isMinus + +calcTimesWith :: Num a => String -> View Expr a -> Rule Expr +calcTimesWith = calcBinRule "times" (*) isTimes + +calcDivisionWith :: Integral a => String -> View Expr a -> Rule Expr +calcDivisionWith viewName v = + makeSimpleRule (calcRuleName "division" viewName) $ \e -> + do (e1, e2) <- isDivide e + a <- match v e1 + b <- match v e2 + let (d, m) = divMod a b + guard (b /= 0 && m == 0) + return (build v d) + +negateZero :: Rule Expr +negateZero = makeSimpleRule (alg, "negate-zero") f + where + f (Negate (Nat n)) | n == 0 = Just 0 + f _ = Nothing + +doubleNegate :: Rule Expr +doubleNegate = makeSimpleRule (alg, "double-negate") f + where + f (Negate (Negate a)) = Just a + f _ = Nothing + +plusNegateLeft :: Rule Expr +plusNegateLeft = makeSimpleRule (alg, "plus-negate-left") f + where + f (Negate a :+: b) = Just (b :-: a) + f _ = Nothing + +plusNegateRight :: Rule Expr +plusNegateRight = makeSimpleRule (alg, "plus-negate-right") f + where + f (a :+: Negate b) = Just (a :-: b) + f _ = Nothing + +minusNegateLeft :: Rule Expr +minusNegateLeft = makeSimpleRule (alg, "minus-negate-left") f + where + f (Negate a :-: b) = Just (Negate (a :+: b)) + f _ = Nothing + +minusNegateRight :: Rule Expr +minusNegateRight = makeSimpleRule (alg, "minus-negate-right") f + where + f (a :-: Negate b) = Just (a :+: b) + f _ = Nothing + +timesNegateLeft :: Rule Expr +timesNegateLeft = makeSimpleRule (alg, "times-negate-left") f + where + f (Negate a :*: b) = Just (Negate (a :*: b)) + f _ = Nothing + +timesNegateRight :: Rule Expr +timesNegateRight = makeSimpleRule (alg, "times-negate-right") f + where + f (a :*: Negate b) = Just (Negate (a :*: b)) + f _ = Nothing + +divisionNegateLeft :: Rule Expr +divisionNegateLeft = makeSimpleRule (alg, "division-negate-left") f + where + f (Negate a :/: b) = Just (Negate (a :/: b)) + f _ = Nothing + +divisionNegateRight :: Rule Expr +divisionNegateRight = makeSimpleRule (alg, "division-negate-right") f + where + f (a :/: Negate b) = Just (Negate (a :/: b)) + f _ = Nothing + +divisionNumerator :: Rule Expr +divisionNumerator = makeSimpleRule (alg, "division-numerator") f + where + f ((a :/: b) :/: c) = Just (a :/: (b :*: c)) + f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c))) + f _ = Nothing + +divisionDenominator :: Rule Expr +divisionDenominator = makeSimpleRule (alg, "division-denominator") f + where + f (a :/: (b :/: c)) = Just ((a :*: c) :/: b) + f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b)) + f _ = Nothing + +simplerFraction :: Rule Expr +simplerFraction = makeSimpleRule (alg, "simpler-fraction") $ \expr -> do + new <- canonical rationalRelaxedForm expr + guard (expr /= new) + return new + +fractionPlus :: Rule Expr -- also minus +fractionPlus = makeSimpleRule (alg, "fraction-plus") $ \expr -> do + (e1, e2) <- match plusView expr + (a, b) <- match fractionForm e1 + (c, d) <- match fractionForm e2 + guard (b == d) + return (build fractionForm (a+c, b)) + +fractionPlusScale :: Rule Expr -- also minus +fractionPlusScale = makeSimpleRuleList (alg, "fraction-plus-scale") $ \expr -> do + (e1, e2) <- matchM plusView expr + (a, b) <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1) + (c, d) <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2) + guard (b /= 0 && d /= 0 && b /= d) + let bd = lcm b d + e1n = build fractionForm (a * (bd `div` b), bd) + e2n = build fractionForm (c * (bd `div` d), bd) + [ build plusView (e1n, e2) | b /= bd ] ++ [ + build plusView (e1, e2n) | d /= bd ] + +fractionTimes :: Rule Expr +fractionTimes = makeSimpleRule (alg, "fraction-times") f + where + f (e1 :*: e2) = do + (a, b) <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1) + (c, d) <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2) + return (build fractionForm (a*c, b*d)) f _ = Nothing diff --git a/src/Domain/Math/Numeric/Strategies.hs b/src/Domain/Math/Numeric/Strategies.hs --- a/src/Domain/Math/Numeric/Strategies.hs +++ b/src/Domain/Math/Numeric/Strategies.hs @@ -1,80 +1,77 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Strategies - ( naturalStrategy, integerStrategy - , rationalStrategy, fractionStrategy - ) where - -import Common.Context -import Common.Strategy -import Common.View -import Domain.Math.Expr -import Domain.Math.Numeric.Rules -import Domain.Math.Numeric.Views -import Prelude hiding (repeat) - ------------------------------------------------------------- --- Strategies - -naturalStrategy :: LabeledStrategy (Context Expr) -naturalStrategy = label "simplify" $ - repeat $ somewhere $ alternatives $ map use - [ calcPlusWith "natural" natView - , calcMinusWith "natural" natView - , calcTimesWith "natural" natView - , calcDivisionWith "natural" natView - , doubleNegate, negateZero, plusNegateLeft, plusNegateRight - , minusNegateLeft, minusNegateRight, timesNegateLeft - , timesNegateRight, divisionNegateLeft, divisionNegateRight - ] - where - natView = makeView f fromInteger - where - f (Nat n) = Just n - f _ = Nothing - -integerStrategy :: LabeledStrategy (Context Expr) -integerStrategy = label "simplify" $ - repeat $ somewhere $ alternatives $ map use - [ calcPlusWith "integer" integerNormalForm - , calcMinusWith "integer" integerNormalForm - , calcTimesWith "integer" integerNormalForm - , calcDivisionWith "integer" integerNormalForm - , doubleNegate, negateZero - ] - -rationalStrategy :: LabeledStrategy (Context Expr) -rationalStrategy = label "simplify" $ - repeat $ somewhere $ alternatives $ map use - [ calcPlusWith "rational" rationalRelaxedForm - , calcMinusWith "rational" rationalRelaxedForm - , calcTimesWith "rational" rationalRelaxedForm - , calcDivisionWith "integer" integerNormalForm - , doubleNegate, negateZero, divisionDenominator - , divisionNumerator, simplerFraction - ] - -fractionStrategy :: LabeledStrategy (Context Expr) -fractionStrategy = label "simplify" $ - repeat $ - somewhere - ( use (calcPlusWith "integer" integerNormalForm) - <|> use (calcMinusWith "integer" integerNormalForm) - <|> use (calcTimesWith "integer" integerNormalForm) -- not needed? - -- <|> use (calcDivisionWith "integer" integerNormalForm) -- not needed? - ) |> - somewhere - ( use doubleNegate <|> use negateZero <|> use divisionDenominator - <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator - ) |> - somewhere (use fractionPlusScale) |> +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Strategies + ( naturalStrategy, integerStrategy + , rationalStrategy, fractionStrategy + ) where + +import Common.Library +import Domain.Math.Expr +import Domain.Math.Numeric.Rules +import Domain.Math.Numeric.Views + +------------------------------------------------------------ +-- Strategies + +naturalStrategy :: LabeledStrategy (Context Expr) +naturalStrategy = label "simplify" $ + repeatS $ somewhere $ alternatives $ map use + [ calcPlusWith "natural" natView + , calcMinusWith "natural" natView + , calcTimesWith "natural" natView + , calcDivisionWith "natural" natView + , doubleNegate, negateZero, plusNegateLeft, plusNegateRight + , minusNegateLeft, minusNegateRight, timesNegateLeft + , timesNegateRight, divisionNegateLeft, divisionNegateRight + ] + where + natView = makeView f fromInteger + where + f (Nat n) = Just n + f _ = Nothing + +integerStrategy :: LabeledStrategy (Context Expr) +integerStrategy = label "simplify" $ + repeatS $ somewhere $ alternatives $ map use + [ calcPlusWith "integer" integerNF + , calcMinusWith "integer" integerNF + , calcTimesWith "integer" integerNF + , calcDivisionWith "integer" integerNF + , doubleNegate, negateZero + ] + +rationalStrategy :: LabeledStrategy (Context Expr) +rationalStrategy = label "simplify" $ + repeatS $ somewhere $ alternatives $ map use + [ calcPlusWith "rational" rationalRelaxedForm + , calcMinusWith "rational" rationalRelaxedForm + , calcTimesWith "rational" rationalRelaxedForm + , calcDivisionWith "integer" integerNF + , doubleNegate, negateZero, divisionDenominator + , divisionNumerator, simplerFraction + ] + +fractionStrategy :: LabeledStrategy (Context Expr) +fractionStrategy = label "simplify" $ + repeatS $ + somewhere + ( use (calcPlusWith "integer" integerNF) + <|> use (calcMinusWith "integer" integerNF) + <|> use (calcTimesWith "integer" integerNF) -- not needed? + -- <|> use (calcDivisionWith "integer" integerNF) -- not needed? + ) |> + somewhere + ( use doubleNegate <|> use negateZero <|> use divisionDenominator + <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator + ) |> + somewhere (use fractionPlusScale) |> somewhere (use simplerFraction) 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 @@ -1,89 +1,89 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Tests (main) where - -import Common.Classes -import Common.Context -import Common.TestSuite -import Common.View -import Control.Monad -import Data.Maybe -import Domain.Math.Expr -import Domain.Math.Numeric.Generators -import Domain.Math.Numeric.Strategies -import Domain.Math.Numeric.Views -import Test.QuickCheck - -main :: TestSuite -main = suite "Numeric tests" $ do - - suite "Correctness numeric views" $ do - let f s v = forM_ numGenerators $ \g -> do - addProperty ("idempotence " ++ s) $ propIdempotence g v - addProperty ("soundness " ++ s) $ propSoundness semEqDouble g v - f "integer view" integerView - f "rational view" rationalView - f "integer normal form" integerNormalForm - f "rational normal form" rationalNormalForm - f "rational relaxed form" rationalRelaxedForm - - suite "Normal forms" $ do - let f s v = forM_ numGenerators $ \g -> - addProperty s $ propNormalForm g v - f "integer normal form" integerNormalForm - -- f rationalNormalForm -- no longer a normal form - - suite "Correctness generators" $ do - let f s g v = addProperty s $ forAll (sized g) (`belongsTo` v) - f "integer" integerGenerator integerView - f "rational" rationalGenerator rationalView - f "ratio expr" ratioExprGen rationalNormalForm - f "ratio expr nonzero" ratioExprGenNonZero rationalNormalForm - - suite "View relations" $ do - let va .>. vb = forM_ numGenerators $ \g -> - addProperty "" $ forAll g $ \a -> - not (a `belongsTo` va) || a `belongsTo` vb - integerNormalForm .>. integerView - rationalNormalForm .>. rationalRelaxedForm - rationalRelaxedForm .>. rationalView - integerNormalForm .>. rationalNormalForm - integerView .>. rationalView - - suite "Pre/post conditions strategies" $ do - let f l s pre post = forM_ numGenerators $ \g -> - addProperty l $ forAll g $ \a -> - let run = fromMaybe a . fromContext . applyD s - . newContext emptyEnv . termNavigator - in not (a `belongsTo` pre) || run a `belongsTo` post - f "natural" naturalStrategy integerView integerNormalForm - f "integer" integerStrategy integerView integerNormalForm - f "rational" rationalStrategy rationalView rationalNormalForm - f "fraction" fractionStrategy rationalView rationalNormalForm - -numGenerators :: [Gen Expr] -numGenerators = map sized - [ integerGenerator, rationalGenerator - , ratioExprGen, ratioExprGenNonZero, numGenerator - ] - -semEqDouble :: Expr -> Expr -> Bool -semEqDouble a b = - case (match doubleView a, match doubleView b) of - (Just x, Just y) -> x ~= y - (Nothing, Nothing) -> True - _ -> False - where - delta = 0.0001 - - (~=) :: Double -> Double -> Bool +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Tests (main) where + +import Common.Classes +import Common.Context +import Common.Utils.TestSuite +import Common.View +import Control.Monad +import Data.Maybe +import Domain.Math.Expr +import Domain.Math.Numeric.Generators +import Domain.Math.Numeric.Strategies +import Domain.Math.Numeric.Views +import Test.QuickCheck + +main :: TestSuite +main = suite "Numeric tests" $ do + + suite "Correctness numeric views" $ do + let f s v = forM_ numGenerators $ \g -> do + addProperty ("idempotence " ++ s) $ propIdempotence g v + addProperty ("soundness " ++ s) $ propSoundness semEqDouble g v + f "integer view" integerView + f "rational view" rationalView + f "integer normal form" integerNF + f "rational normal form" rationalNF + f "rational relaxed form" rationalRelaxedForm + + suite "Normal forms" $ do + let f s v = forM_ numGenerators $ \g -> + addProperty s $ propNormalForm g v + f "integer normal form" integerNF + -- f rationalNF -- no longer a normal form + + suite "Correctness generators" $ do + let f s g v = addProperty s $ forAll (sized g) (`belongsTo` v) + f "integer" integerGenerator integerView + f "rational" rationalGenerator rationalView + f "ratio expr" ratioExprGen rationalNF + f "ratio expr nonzero" ratioExprGenNonZero rationalNF + + suite "View relations" $ do + let va .>. vb = forM_ numGenerators $ \g -> + addProperty "" $ forAll g $ \a -> + not (a `belongsTo` va) || a `belongsTo` vb + integerNF .>. integerView + rationalNF .>. rationalRelaxedForm + rationalRelaxedForm .>. rationalView + integerNF .>. rationalNF + integerView .>. rationalView + + suite "Pre/post conditions strategies" $ do + let f l s pre post = forM_ numGenerators $ \g -> + addProperty l $ forAll g $ \a -> + let run = fromMaybe a . fromContext . applyD s + . newContext emptyEnv . termNavigator + in not (a `belongsTo` pre) || run a `belongsTo` post + f "natural" naturalStrategy integerView integerNF + f "integer" integerStrategy integerView integerNF + f "rational" rationalStrategy rationalView rationalNF + f "fraction" fractionStrategy rationalView rationalNF + +numGenerators :: [Gen Expr] +numGenerators = map sized + [ integerGenerator, rationalGenerator + , ratioExprGen, ratioExprGenNonZero, numGenerator + ] + +semEqDouble :: Expr -> Expr -> Bool +semEqDouble a b = + case (match doubleView a, match doubleView b) of + (Just x, Just y) -> x ~= y + (Nothing, Nothing) -> True + _ -> False + where + delta = 0.0001 + + (~=) :: Double -> Double -> Bool x ~= y = abs x < delta || abs y < delta || abs (1 - (x/y)) < delta diff --git a/src/Domain/Math/Numeric/Views.hs b/src/Domain/Math/Numeric/Views.hs --- a/src/Domain/Math/Numeric/Views.hs +++ b/src/Domain/Math/Numeric/Views.hs @@ -1,187 +1,238 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Numeric.Views - ( integralView, integerView - , rationalView, doubleView, mixedFractionView - , integerNormalForm, rationalNormalForm, mixedFractionNormalForm - , rationalRelaxedForm, fractionForm - , intDiv, fracDiv, exprToNum - ) where - -import Common.Rewriting -import Common.View -import Control.Monad -import Data.Ratio -import Domain.Math.Expr - -------------------------------------------------------------------- --- Numeric views - -integralView :: Integral a => View Expr a -integralView = newView "num.integer" (exprToNum f) fromIntegral - where - f s [x, y] - | isDivideSymbol s = - intDiv x y - | isPowerSymbol s = do - guard (y >= 0) - return (x Prelude.^ y) - f _ _ = Nothing - -integerView :: View Expr Integer -integerView = integralView - -rationalView :: View Expr Rational -rationalView = newView "num.rational" (exprToNum f) fromRational - where - f s [x, y] - | isDivideSymbol s = - fracDiv x y - | isPowerSymbol s = do - let ry = toRational y - guard (denominator ry == 1) - let a = x Prelude.^ abs (numerator ry) - return (if numerator ry < 0 then 1/a else a) - f _ _ = Nothing - -mixedFractionView :: View Expr Rational -mixedFractionView = newView "num.mixed-fraction" (match rationalView) mix - where - mix r = - let (d, m) = abs (numerator r) `divMod` denominator r - rest = fromInteger m ./. fromInteger (denominator r) - sign = if numerator r < 0 then negate else id - in sign (fromInteger d .+. rest) - -doubleView :: View Expr Double -doubleView = newView "num.double" rec Number - where - rec expr = - case expr of - Sym s xs -> mapM rec xs >>= doubleSym s - Number d -> return d - _ -> exprToNumStep rec expr - -------------------------------------------------------------------- --- Numeric views in normal form - --- N or -N (where n is a natural number) -integerNormalForm :: View Expr Integer -integerNormalForm = newView "num.integer-nf" (optionNegate f) fromInteger - where - f (Nat n) = Just n - f _ = Nothing - --- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5) -rationalNormalForm :: View Expr Rational -rationalNormalForm = newView "num.rational-nf" f fromRational - where - f (Nat a :/: Nat b) = simple a b - f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b) - f (Negate (Nat a) :/: Nat b) = fmap negate (simple a b) - f a = fmap fromInteger (match integerNormalForm a) - - simple a b - | a > 0 && b > 1 && gcd a b == 1 = - Just (fromInteger a / fromInteger b) - | otherwise = Nothing - -mixedFractionNormalForm :: View Expr Rational -mixedFractionNormalForm = newView "num.mixed-fraction-nf" f fromRational - where - f (Negate (Nat a) :-: (Nat b :/: Nat c)) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c) - f (Negate (Nat a :+: (Nat b :/: Nat c))) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c) - f (Nat a :+: (Nat b :/: Nat c)) | a > 0 = fmap (fromInteger a+) (simple b c) - f (Nat a :/: Nat b) = simple a b - f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b) - f (Negate (Nat a) :/: Nat b) = fmap negate (simple a b) - f a = fmap fromInteger (match integerNormalForm a) - - simple a b - | a > 0 && b > 1 && gcd a b == 1 && a < b = - Just (fromInteger a / fromInteger b) - | otherwise = Nothing - -fractionForm :: View Expr (Integer, Integer) -fractionForm = newView "num.fraction-form" f (\(a, b) -> (fromInteger a :/: fromInteger b)) - where - f (Negate a) = liftM (first negate) (g a) - f a = g a - g (e1 :/: e2) = do - a <- match integerNormalForm e1 - b <- match integerNormalForm e2 - guard (b /= 0) - return (a, b) - g _ = Nothing - -rationalRelaxedForm :: View Expr Rational -rationalRelaxedForm = newView "num.rational-relaxed" (optionNegate f) fromRational - where - f (e1 :/: e2) = do - a <- match integerNormalForm e1 - b <- match integerNormalForm e2 - fracDiv (fromInteger a) (fromInteger b) - f (Nat n) = Just (fromInteger n) - f _ = Nothing - --- helper-function -optionNegate :: (MonadPlus m, Num a) => (Expr -> m a) -> Expr -> m a -optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b) -optionNegate f a = f a - -------------------------------------------------------------------- --- Helper functions - -doubleSym :: Symbol -> [Double] -> Maybe Double -doubleSym s [x, y] - | isDivideSymbol s = fracDiv x y - | isPowerSymbol s = floatingPower x y - | isRootSymbol s && x >= 0 && y >= 1 = Just (x ** (1/y)) -doubleSym _ _ = Nothing - --- General numeric interpretation function: constructors Sqrt and --- (:/:) are interpreted with function -exprToNum :: (Monad m, Num a) => (Symbol -> [a] -> m a) -> Expr -> m a -exprToNum f = rec - where - rec expr = - case expr of - Sym s xs -> mapM rec xs >>= f s - _ -> exprToNumStep rec expr - -exprToNumStep :: (Monad m, Num a) => (Expr -> m a) -> Expr -> m a -exprToNumStep rec expr = - case expr of - a :+: b -> liftM2 (+) (rec a) (rec b) - a :*: b -> liftM2 (*) (rec a) (rec b) - a :-: b -> liftM2 (-) (rec a) (rec b) - Negate a -> liftM negate (rec a) - Nat n -> return (fromInteger n) - a :/: b -> rec (Sym divideSymbol [a, b]) - Sqrt a -> rec (Sym rootSymbol [a, 2]) - _ -> fail "exprToNumStep" - -intDiv :: Integral a => a -> a -> Maybe a -intDiv x y - | y /= 0 && m == 0 = Just d - | otherwise = Nothing - where (d, m) = x `divMod` y - -fracDiv :: Fractional a => a -> a -> Maybe a -fracDiv x y - | y /= 0 = Just (x / y) - | otherwise = Nothing - -floatingPower :: (Ord a, Floating a) => a -> a -> Maybe a -floatingPower x y - | x==0 && y<0 = Nothing - | otherwise = Just (x**y) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Views + ( -- * Natural numbers + naturalView, naturalNF + -- * Integers + , integerView, integerNF + -- * Decimal fractions + , decimalFractionView + -- * Rational numbers + , rationalView, rationalNF + , rationalRelaxedForm, fractionForm + -- * Mixed fractions + , mixedFractionView, mixedFractionNF + -- * Double + , doubleView, doubleNF + ) where + +import Common.Id +import Common.Rewriting (function) +import Common.View +import Control.Monad +import Data.Ratio +import Domain.Math.Expr hiding ((^)) +import Domain.Math.Safe +import qualified Domain.Math.Data.DecimalFraction as DF +import qualified Domain.Math.Data.MixedFraction as MF + +------------------------------------------------------------------- +-- Natural numbers + +-- |Non-negative numbers only, also for intermediate results +naturalView :: View Expr Integer +naturalView = "num.natural" @> makeView rec (fromInteger . abs) + where + rec :: Expr -> Maybe Integer + rec expr = do + x <- matchInteger rec expr + guard (x >= 0) + return x + +naturalNF :: View Expr Integer +naturalNF = "num.natural.nf" @> makeView f (build naturalView) + where + f (Nat n) = Just n + f _ = Nothing + +------------------------------------------------------------------- +-- Integers + +integerView :: View Expr Integer +integerView = "num.integer" @> makeView (fix matchInteger) fromIntegral + +-- N or -N (where n is a natural number) +integerNF :: View Expr Integer +integerNF = "num.integer.nf" @> makeView (optionNegate f) fromInteger + where + f (Nat n) = Just n + f _ = Nothing + +matchInteger :: (Expr -> Maybe Integer) -> Expr -> Maybe Integer +matchInteger f expr = + case expr of + a :/: b -> join (liftM2 safeDiv (f a) (f b)) + Sym s [a, b] + | isPowerSymbol s -> join (liftM2 safePower (f a) (f b)) + _ -> matchNum f expr + +matchNum :: Num a => (Expr -> Maybe a) -> Expr -> Maybe a +matchNum f expr = + case expr of + Nat n -> return (fromInteger n) + a :+: b -> liftM2 (+) (f a) (f b) + a :-: b -> liftM2 (-) (f a) (f b) + Negate a -> liftM negate (f a) + a :*: b -> liftM2 (*) (f a) (f b) + _ -> Nothing + +------------------------------------------------------------------- +-- Decimal fractions + +decimalFractionView :: View Expr DF.DecimalFraction +decimalFractionView = "num.decimal" @> makeView (fix matchDecimal) f + where + f = fromDouble . fromRational . toRational + +matchDecimal :: (Expr -> Maybe DF.DecimalFraction) -> Expr -> Maybe DF.DecimalFraction +matchDecimal f expr = + case expr of + Number d -> Just (DF.fromDouble d) + a :/: b -> join (liftM2 safeDiv (f a) (f b)) + Sym s [a, b] + | isPowerSymbol s -> join (liftM2 safePower (f a) (f b)) + Sym s [a, b, c] + | isMixedFractionSymbol s -> f (a+b/c) + _ -> matchNum f expr + +------------------------------------------------------------------- +-- Rational numbers + +-- |like the original defintion, except that this view +-- now also converts floating point numbers (using an exact approximation) +rationalView :: View Expr Rational +rationalView = describe "Interpret an expression as a (normalized) rational \ + \number, performing computations such as addition and multiplication if \ + \necessary." $ + "number.rational" @> makeView f fromRational + where + f a = matchExact a >>= either (const Nothing) Just + +matchRational :: (Expr -> Maybe Rational) -> Expr -> Maybe Rational +matchRational f expr = + case expr of + Number d -> return $ fromRational $ toRational $ DF.fromDouble d + a :/: b -> join (liftM2 safeDiv (f a) (f b)) + Sym s [a, b] + | isPowerSymbol s -> join (liftM2 safePower (f a) (f b)) + Sym s [a, b, c] + | isMixedFractionSymbol s -> f (a+b/c) + _ -> matchNum f expr + +matchExact :: Expr -> Maybe (Either Double Rational) +matchExact expr = + fmap Left (match doubleNF expr) `mplus` + fmap Right (fix matchRational expr) + +-- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5) +rationalNF :: View Expr Rational +rationalNF = "num.rational.nf" @> makeView f fromRational + where + f (Nat a :/: Nat b) = simpleRational a b + f (Negate (Nat a :/: Nat b)) = fmap negate (simpleRational a b) + f (Negate (Nat a) :/: Nat b) = fmap negate (simpleRational a b) + f a = fmap fromInteger (match integerNF a) + +simpleRational :: Integer -> Integer -> Maybe Rational +simpleRational a b = do + guard (a > 0 && b > 1 && gcd a b == 1) + return (fromInteger a / fromInteger b) + +fractionForm :: View Expr (Integer, Integer) +fractionForm = "num.fraction-form" @> makeView f g + where + f = match (divView >>> integerNF *** integerNF) + g (a, b) = fromInteger a :/: fromInteger b + +rationalRelaxedForm :: View Expr Rational +rationalRelaxedForm = "num.rational-relaxed" @> makeView (optionNegate f) fromRational + where + f (e1 :/: e2) = do + a <- match integerNF e1 + b <- match integerNF e2 + safeDiv (fromInteger a) (fromInteger b) + f (Nat n) = Just (fromInteger n) + f _ = Nothing + +------------------------------------------------------------------- +-- Mixed fractions + +mixedFractionView :: View Expr MF.MixedFraction +mixedFractionView = "num.mixed-fraction" @> makeView f (sign g) + where + f = fmap fromRational . fix matchRational + + sign k a | a < 0 = negate (k (abs a)) + | otherwise = k a + + g a + | frac == 0 = fromInteger whole + | whole == 0 = fromRational frac + | otherwise = function mixedFractionSymbol $ map fromInteger parts + where + whole = MF.wholeNumber a + frac = MF.fractionPart a + parts = [whole, numerator frac, denominator frac] + +mixedFractionNF :: View Expr MF.MixedFraction +mixedFractionNF = describe "A normal form for mixed fractions. \ + \Improper fractions (numerator greater or equal to denominator) are not \ + \allowed." $ + "number.mixed-fraction.nf" @> makeView f (build mixedFractionView) + where + f (Sym s [Nat a, Nat b, Nat c]) + | isMixedFractionSymbol s = simple a b c + f (Negate (Sym s [Nat a, Nat b, Nat c])) + | isMixedFractionSymbol s = liftM negate (simple a b c) + f expr = do r <- match rationalNF expr + guard ((-1 < r && r < 1) || denominator r == 1) + return (fromRational r) + + simple a b c = do + guard (a > 0 && b > 0 && b < c) + r <- simpleRational b c + return (fromInteger a + fromRational r) + +------------------------------------------------------------------- +-- Double (imprecise floating-points) + +doubleView :: View Expr Double +doubleView = "num.double" @> makeView (fix matchDouble) fromDouble + +doubleNF :: View Expr Double +doubleNF = "num.double.nf" @> makeView (optionNegate f) fromDouble + where + f (Number d) = Just d + f _ = Nothing + +matchDouble :: (Expr -> Maybe Double) -> Expr -> Maybe Double +matchDouble f expr = + case expr of + Number d -> Just d + a :/: b -> join (liftM2 safeDiv (f a) (f b)) + Sqrt a -> f a >>= safeSqrt + Sym s [a, b] + | isPowerSymbol s -> join (liftM2 safePower (f a) (f b)) + | isRootSymbol s -> join (liftM2 safeRoot (f a) (f b)) + Sym s [a, b, c] + | isMixedFractionSymbol s -> f (a+b/c) + _ -> matchNum f expr + +------------------------------------------------------------------- +-- Helper functions + +optionNegate :: Num a => (Expr -> Maybe a) -> Expr -> Maybe a +optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b) +optionNegate f a = f a + +fix :: (a -> a) -> a +fix f = f (fix f) diff --git a/src/Domain/Math/Polynomial/Balance.hs b/src/Domain/Math/Polynomial/Balance.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Balance.hs @@ -0,0 +1,263 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Balance (balanceExercise) where + +import Common.Library +import Common.Utils (fixpoint) +import Common.Utils.Uniplate +import Control.Monad +import Data.Function +import Data.Maybe +import Data.Ratio +import Domain.Math.Data.Relation +import Domain.Math.Data.WithBool +import Domain.Math.Equation.BalanceRules +import Domain.Math.Equation.Views +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.BalanceUtils +import Domain.Math.Polynomial.BuggyBalance +import Domain.Math.Polynomial.Examples +import Domain.Math.Polynomial.Generators +import Domain.Math.Polynomial.Rules (conditionVarsRHS, flipEquation) +import Domain.Math.Polynomial.Views +import Test.QuickCheck (sized) + +------------------------------------------------------------ +-- Exercise + +balanceExercise :: Exercise (WithBool (Equation Expr)) +balanceExercise = makeExercise + { exerciseId = describe "Solve a linear equation using only balance rules." $ + newId "algebra.equations.linear.balance" + , status = Provisional + , parser = parseBoolEqExpr + , similarity = withoutContext ((==) `on` cleaner) + , equivalence = withoutContext (viewEquivalent eqView) + , suitable = predicateView (traverseView linearEquationView) + , ready = predicateView (traverseView (equationSolvedWith mixedFractionNF)) + <||> predicateView (traverseView (equationSolvedWith rationalNF)) + <||> predicateView (traverseView (equationSolvedWith doubleNF)) + , strategy = balanceStrategy + , extraRules = map use buggyBalanceRules + , ruleOrdering = ruleOrderingWithId (balanceOrder ++ buggyPriority) + , navigation = termNavigator + , testGenerator = Just $ liftM2 (\a b -> singleton (a :==: b)) (sized linearGen) (sized linearGen) + , examples = map (mapSecond singleton) linearExamples + } + +balanceOrder :: [Id] +balanceOrder = + [ getId removeDivision, getId collect + , getId varRightMinus, getId varRightPlus + , getId conLeftMinus, getId conLeftPlus + , getId varLeftMinus, getId varLeftPlus + , getId conRightMinus, getId conRightPlus + , getId scaleToOne, getId flipEquation + , getId divideCommonFactor, getId distribute + , getId collect, getId divisionToFraction + ] + +------------------------------------------------------------ +-- Strategy + +balanceStrategy :: LabeledStrategy (Context (WithBool (Equation Expr))) +balanceStrategy = cleanUpStrategyAfter (applyTop cleaner) $ + label "Balance equation" $ + label "Phase 1" (repeatS + ( use collect + <|> use distribute + <|> use removeDivision + <|> somewhere (use divisionToFraction) + )) + <*> label "Phase 2" (repeatS + ( use varLeftMinus <|> use varLeftPlus + <|> use conRightMinus <|> use conRightPlus + <|> (check p2 <*> (use varRightMinus <|> use varRightPlus)) + <|> (check p1 <*> (use conLeftMinus <|> use conLeftPlus) + )) + <*> try (use scaleToOne) + <*> try (use calculate)) + -- flip sides of an equation (at most once) + <%> try (atomic (use conditionVarsRHS <*> use flipEquation)) + -- divide by a common factor (but not as final "scale-to-one" step) + <%> many (notS (use scaleToOne) <*> use divideCommonFactor) + where + -- move constants to left only if there are no variables on the left + p1 = maybe False (either (const False) (hasNoVar . leftHandSide) . fromWithBool) . fromContext + p2 ceq = fromMaybe False $ do + wb <- fromContext ceq + lhs :==: rhs <- either (const Nothing) Just (fromWithBool wb) + (x1, a, _) <- matchLin lhs + (x2, b, _) <- matchLin rhs + return (x1 == x2 && b > a && a /= 0) + +------------------------------------------------------------ +-- Rules + +calculate :: Rule (WithBool (Equation Expr)) +calculate = makeSimpleRule (linbal, "calculate") $ checkForChange $ + Just . cleaner + +-- factor is always positive due to lcm function +removeDivision :: Rule (Equation Expr) +removeDivision = doAfter (fmap distributeTimes) $ + describe "remove division" $ + makeRule (linbal, "remove-div") $ useSimpleRecognizer isTimesT $ + supply1 "factor" removeDivisionArg timesT + where + removeDivisionArg (lhs :==: rhs) = do + xs <- match simpleSumView lhs + ys <- match simpleSumView rhs + -- also consider parts without variables + -- (but at least one participant should have a variable) + zs <- mapM getFactor (xs++ys) + let (b, result) = foldr op (False, 1) zs + op (b1, a1) (b2, a2) = (b1 || b2, a1 `lcm` a2) + guard (b && result > 1) + return (fromInteger result) + + getFactor (Negate a) = getFactor a + getFactor expr = do + (b, c) <- match (divView >>> second integerView) expr + return (hasSomeVar b, c) + `mplus` do + r <- match rationalView expr + return (False, denominator r) + `mplus` do + (r, c) <- match (timesView >>> first rationalView) expr + return (hasSomeVar c, denominator r) + `mplus` do + (b, r) <- match (timesView >>> second rationalView) expr + return (hasSomeVar b, denominator r) + `mplus` do + (_, ps) <- match simpleProductView expr + guard (any (`belongsTo` rationalView) ps) + return (False, 1) + `mplus` do + guard (isVariable expr) + return (False, 1) + +divisionToFraction :: Rule Expr +divisionToFraction = + describe "turn a division into a multiplication with a fraction" $ + makeSimpleRule (linbal, "div-to-fraction") $ \expr -> do + (a, r) <- match (divView >>> second rationalView) expr + guard (hasSomeVar a && r /= 0) + return (fromRational (1/r)*a) + +divideCommonFactor :: Rule (Equation Expr) +divideCommonFactor = doAfter (fmap distributeDiv) $ + describe "divide by common factor" $ + makeRule (linbal, "smart-div") $ useSimpleRecognizer isTimesT $ + supply1 "factor" getArg divisionT + where + getArg (lhs :==: rhs) + | all (/=0) ns && n > 1 = Just (fromInteger n) + | otherwise = Nothing + where + xs = from sumView lhs ++ from sumView rhs + ns = map getFactor xs + n = foldr1 gcd ns + + getFactor expr + | hasNoVar expr = fromMaybe 1 $ match integerView expr + | otherwise = fromMaybe 1 $ do + (a, b) <- match timesView expr + case (match integerView a, match integerView b) of + (Just n, _) | hasSomeVar b -> return n + (_, Just n) | hasSomeVar a -> return n + _ -> Nothing + +varLeftMinus, varLeftPlus :: Rule (Equation Expr) +varLeftMinus = varLeft True (linbal, "var-left-minus") +varLeftPlus = varLeft False (linbal, "var-left-plus") + +varLeft :: IsId a => Bool -> a -> Rule (Equation Expr) +varLeft useMinus rid = doAfter (fmap collectLocal) $ + makeRule rid $ useSimpleRecognizer isPlusT $ + supply1 "term" varLeftArg (if useMinus then minusT else plusT) + where + varLeftArg :: Equation Expr -> Maybe Expr + varLeftArg (lhs :==: rhs) = do + guard (hasSomeVar lhs) + (x, a, _) <- matchLin rhs + guard (if useMinus then a > 0 else a < 0) + return (fromRational (abs a) .*. x) + +conRightMinus, conRightPlus :: Rule (Equation Expr) +conRightMinus = conRight True (linbal, "con-right-minus") +conRightPlus = conRight False (linbal, "con-right-plus") + +conRight :: IsId a => Bool -> a -> Rule (Equation Expr) +conRight useMinus rid = doAfter (fmap collectLocal) $ + makeRule rid $ useSimpleRecognizer isPlusT $ + supply1 "term" conRightArg (if useMinus then minusT else plusT) + where + conRightArg :: Equation Expr -> Maybe Expr + conRightArg (lhs :==: _) = do + guard (hasSomeVar lhs) + (_, _, b) <- matchLin lhs + guard (if useMinus then b > 0 else b < 0) + return (fromRational (abs b)) + +varRightMinus, varRightPlus :: Rule (Equation Expr) +varRightMinus = flipped (linbal, "var-right-minus") varLeftMinus +varRightPlus = flipped (linbal, "var-right-plus") varLeftPlus + +conLeftMinus, conLeftPlus :: Rule (Equation Expr) +conLeftMinus = flipped (linbal, "con-left-minus") conRightMinus +conLeftPlus = flipped (linbal, "con-left-plus") conRightPlus + +flipped :: IsId a => a -> Rule (Equation b) -> Rule (Equation b) +flipped rid = liftRule flipView . changeId (const (newId rid)) + where flipView = makeView (Just . flipSides) flipSides + +scaleToOne :: Rule (Equation Expr) +scaleToOne = doAfter (fmap distributeDiv) $ + makeRule (linbal, "scale-to-one") $ useSimpleRecognizer isTimesT $ + supply1 "factor" scaleToOneArg divisionT + where + scaleToOneArg :: Equation Expr -> Maybe Expr + scaleToOneArg (lhs :==: rhs) = f lhs rhs `mplus` f rhs lhs + + f :: Expr -> Expr -> Maybe Expr + f expr c = do + (_, a1, b1) <- matchLin expr + guard (a1 /= 0 && a1 /= 1 && b1 == 0 && hasNoVar c) + return (fromRational a1) + +collect :: Rule (Equation Expr) +collect = makeSimpleRule (linbal, "collect") $ + -- don't use this rule just for cleaning up + checkForChange (Just . fmap collectGlobal) . fmap cleanerExpr + +distribute :: Rule (Equation Expr) +distribute = makeSimpleRule (linbal, "distribute") $ checkForChange $ + Just . fmap (fixpoint f) + where + f (a :*: (b :+: c)) = f (a*b+a*c) + f (a :*: (b :-: c)) = f (a*b-a*c) + f ((a :+: b) :*: c) = f (a*c+b*c) + f ((a :-: b) :*: c) = f (a*c-b*c) + f (Negate (a :+: b)) = f (-a-b) + f (Negate (a :-: b)) = f (-a+b) + f (Negate (Negate a)) = f a + f (a :-: (b :+: c)) = f (a-b-c) + f (a :-: (b :-: c)) = f (a-b+c) + f (a :-: Negate b) = f (a+b) + f a = descend f a + +-- for debugging +{- +go = printDerivation balanceExercise $ singleton $ let x=Var "x" in + (x+2+7/2*x)/(3/2) :==: -3/2*x/4*0 -} diff --git a/src/Domain/Math/Polynomial/BalanceUtils.hs b/src/Domain/Math/Polynomial/BalanceUtils.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/BalanceUtils.hs @@ -0,0 +1,245 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.BalanceUtils + ( eqView, minusView, negView + , matchLin, matchPlusCon + , cleaner, cleanerExpr + , linbal, checkForChange + , termArg, factorArg, factorArgs + , buggyBalanceRule, buggyBalanceRuleArgs + , buggyBalanceExprRule, buggyBalanceRecognizer + , collectLocal, collectGlobal + , distributeDiv, distributeTimes + , isPlusT, diffPlus + , isTimesT, diffTimes + ) where + +import Common.Library +import Common.Utils (fixpoint) +import Common.Utils.Uniplate +import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.Data.Polynomial +import Domain.Math.Data.Relation +import Domain.Math.Data.WithBool +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Views +import Domain.Math.Safe +import Domain.Math.Simplification (mergeAlikeSum) + +eqView :: View (WithBool (Equation Expr)) (WithBool (String, Rational)) +eqView = makeView (either (Just . fromBool) f . fromWithBool) (fmap g) + where + f (lhs :==: rhs) = do + (s, p) <- match (polyViewWith rationalView) (lhs-rhs) + case degree p of + 0 -> Just $ fromBool $ coefficient 0 p == 0 + 1 -> Just $ singleton (s, - coefficient 0 p / coefficient 1 p) + _ -> Nothing + g (s, r) = Var s :==: fromRational r + +minusView :: View Expr (Expr, Expr) +minusView = makeView isMinus (uncurry (:-:)) + +negView :: View Expr Expr +negView = makeView isNegate Negate + +matchLin :: Expr -> Maybe (Expr, Rational, Rational) +matchLin expr = do + (s, p) <- match (polyNormalForm rationalView) expr + guard (degree p == 1) + return (Var s, coefficient 1 p, coefficient 0 p) + +matchPlusCon :: Expr -> Maybe (Expr, Rational) +matchPlusCon expr = + match (plusView >>> second rationalView) expr + `mplus` + match (plusView >>> toView swapView >>> second rationalView) expr + +------------------------------------------------------------ +-- Strategy + +cleaner :: WithBool (Equation Expr) -> WithBool (Equation Expr) +cleaner = join . fmap (trivial . fmap cleanerExpr) + +cleanerExpr :: Expr -> Expr +cleanerExpr = transform f -- no fixpoint is needed + where + f (a :/: Nat 1) = f a + f (a :/: Negate (Nat 1)) = f $ Negate a + f (Negate a :/: Negate b) = f (a/b) + f (a :/: Negate b) = f $ Negate (a/b) + f (Negate a :/: b) = f $ Negate (a/b) + f (Negate (Negate a)) = f a + f e = cleanSum (cleanProduct (simplify rationalView e)) + + cleanSum = + let g x y = canonical rationalView (x :+: y) + in simplifyWith (adjacent g) simpleSumView + + cleanProduct = + let g x y = canonical rationalView (x :*: y) + in simplifyWith (mapSecond (adjacent g)) simpleProductView + +adjacent :: (a -> a -> Maybe a) -> [a] -> [a] +adjacent f = rec + where + rec (x:y:rest) = + case f x y of + Just xy -> rec (xy:rest) + Nothing -> x:rec (y:rest) + rec xs = xs + +trivial :: Equation Expr -> WithBool (Equation Expr) +trivial eq@(lhs :==: rhs) = + case (match rationalView lhs, match rationalView rhs) of + (Just r1, Just r2) + | r1 == r2 -> true + | otherwise -> false + _ | any nonsense [lhs, rhs] -> false + | lhs == rhs -> true + | otherwise -> singleton eq + +nonsense :: Expr -> Bool +nonsense = any p . universe + where + p (_ :/: a) = maybe False (==0) (match rationalView a) + p _ = False + +------------------------------------------------------------ +-- Arguments + +termArg :: Expr -> ArgValues +termArg expr = [ArgValue (makeArgDescr "term") expr] + +factorArg :: Expr -> ArgValues +factorArg expr = [ArgValue (makeArgDescr "factor") expr] + +factorArgs :: [Expr] -> ArgValues +factorArgs = + let f = ArgValue . makeArgDescr . ("factor" ++) . show + in zipWith f [1::Int ..] + +------------------------------------------------------------ +-- Rules + +linbal :: Id +linbal = newId "algebra.equations.linear.balance" + +checkForChange :: (MonadPlus m, Eq a) => (a -> m a) -> a -> m a +checkForChange f a = f a >>= \b -> guard (a /= b) >> return b + +buggyBalanceRule :: IsId n => n -> (Equation Expr -> Maybe (Equation Expr)) -> Rule (Equation Expr) +buggyBalanceRule n f = buggyBalanceRuleArgs n (fmap (\x -> (x, [])) . f) + +buggyBalanceRuleArgs :: IsId n => n -> (Equation Expr -> Maybe (Equation Expr, ArgValues)) -> Rule (Equation Expr) +buggyBalanceRuleArgs n f = bugbalRule n (fmap fst . f) $ \old (a1 :==: a2) -> do + (b1 :==: b2, as) <- f old + let h = viewEquivalent (polyViewWith rationalView) + guard (h a1 b1 && h a2 b2) + return as + +buggyBalanceExprRule :: IsId n => n -> (Expr -> Maybe Expr) -> Rule (Equation Expr) +buggyBalanceExprRule n f = buggyBalanceRule n $ \(lhs :==: rhs) -> + let -- to do: deal with associativity + rec = msum . map (\(a,h) -> liftM h (f a)) . contexts + in liftM (:==: rhs) (rec lhs) `mplus` liftM (lhs :==:) (rec rhs) + +buggyBalanceRecognizer :: IsId n => n -> (a -> a -> Maybe ArgValues) -> Rule a +buggyBalanceRecognizer n = bugbalRule n(const Nothing) + +-- generalized helper +bugbalRule :: IsId n => n -> (a -> Maybe a) -> (a -> a -> Maybe ArgValues) -> Rule a +bugbalRule n f p = + buggyRule $ makeRule (linbal, "buggy", n) $ useRecognizer p $ makeTrans f + +------------------------------------------------------------ +-- Helpers + +collectLocal :: Expr -> Expr +collectLocal = simplifyWith (mapSecond f) simpleProductView + . simplifyWith mergeAlikeSum simpleSumView + where + f xs | length ys > 1 = ys++zs + | otherwise = xs + where + (ys, zs) = partition hasNoVar xs + +collectGlobal :: Expr -> Expr +collectGlobal = fixpoint (transform collectLocal) + +distributeDiv :: Expr -> Expr +distributeDiv expr = fromMaybe expr $ do + (a, r) <- match (divView >>> second rationalView) expr + return $ simplifyWith (fmap (`divide` r)) simpleSumView a + where + divide x r = fromMaybe (x/fromRational r) $ do + (y, z) <- match (timesView >>> first rationalView) x + new <- y `safeDiv` r + return (fromRational new * z) + `mplus` do + (y, z) <- match (timesView >>> second rationalView) x + new <- z `safeDiv` r + return (y * fromRational new) + +distributeTimes :: Expr -> Expr +distributeTimes expr = fromMaybe expr $ do + (r, a) <- match (timesView >>> first rationalView) expr + `mplus` + match (timesView >>> second rationalView >>> toView swapView) expr + return $ simplifyWith (fmap (times r)) simpleSumView a + where + times r x = fromMaybe (fromRational r*x) $ do + (a, b) <- match (divView >>> second rationalView) x + guard (b /= 0) + return (fromRational (r/b) * a) + +isPlusT :: Equation Expr -> Equation Expr -> Bool +isPlusT old new = isJust (diffPlusEq old new) + +diffPlusEq :: Equation Expr -> Equation Expr -> Maybe Expr +diffPlusEq (a1 :==: a2) (b1 :==: b2) = do + d1 <- diffPlus a1 b1 + d2 <- diffPlus a2 b2 + guard (d1 == d2) + return d1 + +diffPlus :: Expr -> Expr -> Maybe Expr +diffPlus a b = do + let myView = polyViewWith rationalView + (x, pa) <- matchM myView a + (y, pb) <- matchM myView b + guard (x==y) + let d = pb - pa + return $ build myView (x, d) + +isTimesT :: Equation Expr -> Equation Expr -> Bool +isTimesT old new = isJust (diffTimesEq old new) + +diffTimesEq :: Equation Expr -> Equation Expr -> Maybe Expr +diffTimesEq (a1 :==: a2) (b1 :==: b2) = do + d1 <- diffTimes a1 b1 + d2 <- diffTimes a2 b2 + guard (d1 == d2) + return d1 + +diffTimes :: Expr -> Expr -> Maybe Expr +diffTimes a b = do + let myView = polyViewWith rationalView + (x, pa) <- matchM myView a + (y, pb) <- matchM myView b + guard (x==y) + if pa==0 && pb==0 then return 1 else do + d <- pb `safeDiv` pa + return $ build myView (x, d) diff --git a/src/Domain/Math/Polynomial/BuggyBalance.hs b/src/Domain/Math/Polynomial/BuggyBalance.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/BuggyBalance.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.BuggyBalance + ( buggyBalanceRules, buggyPriority + ) where + +import Common.Library +import Control.Monad +import Data.Ratio +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.BalanceUtils +import Domain.Math.Polynomial.Views + +buggyBalanceRules :: [Rule (Equation Expr)] +buggyBalanceRules = + [ rule121, rule122, rule1231, rule1232, rule1234 + , rule1311, rule1312, rule1314, rule1321, rule1322 + , rule133, rule134, rule135, rule136, rule137 + , rule201 + , rule2111, rule2112, rule2113, rule2114 + , rule2121, rule2122, rule2131, rule2132 + , rule2141, rule2142 + , rule221, rule222, rule2231, rule2232, rule2233, rule227 + , rule311, rule321, rule322, rule323 + ] + +buggyPriority :: [Id] +buggyPriority = map getId + [rule1312, rule121, rule221, rule222, rule2232, rule2233, rule227, rule323] + +------------------------------------------------------------------- +-- 1.2 Fout bij vermenigvuldigen + +-- (a*b)/c -> a/(b*c) +rule121 :: Rule (Equation Expr) +rule121 = describe "1.2.1: fout bij vermenigvuldigen" $ + buggyBalanceExprRule "multiply1" f + where + f (expr :/: c) = do + (a, b) <- match timesView expr + return $ a/(b*c) + f _ = Nothing + +-- a*(bx+c) -> x/(ab) + ac +rule122 :: Rule (Equation Expr) +rule122 = describe "1.2.2: fout bij vermenigvuldigen" $ + buggyBalanceExprRule "multiply2" f + where + f (a :*: expr) = do + ((b, x), c) <- match (plusView >>> first timesView) expr + return $ x/(a*b) + a*c + f _ = Nothing + +-- a(b-cx) -> ab+acx +rule1231 :: Rule (Equation Expr) +rule1231 = describe "1.2.3.1: fout bij vermenigvuldigen; min raakt kwijt" $ + buggyBalanceExprRule "multiply3" f + where + f (a :*: expr) = do + (b, (c, x)) <- match (minusView >>> second timesView) expr + return $ a*b+a*c*x + f _ = Nothing + +-- -a*(x-b) -> -ax-ab +rule1232 :: Rule (Equation Expr) +rule1232 = describe "1.2.3.2: fout bij vermenigvuldigen; min te veel" $ + buggyBalanceExprRule "multiply4" f + where + f expr = do + (a, (x, b)) <- match (timesView >>> negView *** minusView) expr + return $ -a*x-a*b + +-- -ax=b -> x=b/a +rule1234 :: Rule (Equation Expr) +rule1234 = describe "1.2.3.4: fout bij vermenigvuldigen; delen door negatief getal" $ + buggyBalanceRule "multiply5" f + where + f (expr :==: b) = do + (a, x) <- match (timesView >>> first negView) expr + return $ x :==: b/a + +------------------------------------------------------------------- +-- 1.3 Fout bij haakjes wegwerken + +-- a(x-b) -> ax-b (verruimt naar +) +rule1311 :: Rule (Equation Expr) +rule1311 = describe "1.3.1.1: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $ + buggyBalanceExprRule "par1" f + where + f expr = do + (a, (x, b)) <- match (timesView >>> second plusView) expr + return $ a*x+b + +-- 1/a*(x-b) -> 1/a*x-b (specialized version of par1) +rule1312 :: Rule (Equation Expr) +rule1312 = describe "1.3.1.2: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $ + buggyBalanceExprRule "par2" f + where + f (e1 :*: e2) = do + (n, a) <- match (divView >>> first integerView) e1 + guard (n==1) + (x, b) <- match plusView e2 + return $ 1/a*x+b + f _ = Nothing + +-- a(b-cx) -> ab-cx +{- zie par1 +rule1313 :: Rule (Equation Expr) +rule1313 = describe "1.3.1.3: fout bij haakjes wegwerken; haakjes staan e +r niet voor niets" $ + + buggyBalanceExprRule "par3") f + where + f (a :*: expr) = do + (b, (c, x)) <- match (minusView >>> second timesView) expr + return $ a*b-c*x + f _ = Nothing -} + +-- -(a+b) -> -a+b +rule1314 :: Rule (Equation Expr) +rule1314 = describe "1.3.1.4: fout bij haakjes wegwerken met unaire min; haakjes staan er niet voor niets" $ + buggyBalanceExprRule "par11" f + where + f expr = do + (a, b) <- match (negView >>> plusView) expr + return $ -a+b + +-- a(bx+c) -> ax+ac +rule1321 :: Rule (Equation Expr) +rule1321 = describe "1.3.2.1: fout bij haakjes wegwerken; haakjes goed uitwerken" $ + buggyBalanceExprRule "par4" f + where + f (a :*: expr) = do + ((_, x), c) <- match (plusView >>> first timesView) expr + return $ a*x+a*c + f _ = Nothing + +-- a(b-cx) -> ab-ax +rule1322 :: Rule (Equation Expr) +rule1322 = describe "1.3.2.2: fout bij haakjes wegwerken; haakjes goed uitwerken" $ + buggyBalanceExprRule "par5" f + where + f (a :*: expr) = do + (b, (_, x)) <- match (minusView >>> second timesView) expr + return $ a*b-a*x + f _ = Nothing + +-- a(bx+c) -> bx+ac +rule133 :: Rule (Equation Expr) +rule133 = describe "1.3.3: fout bij haakjes wegwerken; haakjes goed uitwerken" $ + buggyBalanceExprRule "par6" f + where + f (a :*: expr) = do + ((b, x), c) <- match (plusView >>> first timesView) expr + return $ b*x+a*c + f _ = Nothing + +-- a-(b+c) -> a-b+c +rule134 :: Rule (Equation Expr) +rule134 = describe "1.3.4: fout bij haakjes wegwerken; haakjes goed uitwerken" $ + buggyBalanceExprRule "par7" f + where + f expr = do + (a, (b, c)) <- match (minusView >>> second plusView) expr + return $ a-b+c + +-- a*(b-c)-d -> ab-ac-ad +rule135 :: Rule (Equation Expr) +rule135 = describe "1.3.5: fout bij haakjes wegwerken; kijk goed waar de haakjes staan" $ + buggyBalanceExprRule "par8" f + where + f expr = do + ((a, (b, c)), d) <- match (minusView >>> first (timesView >>> second minusView)) expr + return $ a*b-a*c-a*d + +-- a(bx+c) -> (a+b)x+ac +rule136 :: Rule (Equation Expr) +rule136 = describe "1.3.6: fout bij haakjes wegwerken; haakjes goed uitwerken" $ + buggyBalanceExprRule "par9" f + where + f (a :*: expr) = do + ((b, x), c) <- match (plusView >>> first timesView) expr + return $ (a+b)*x+a*c + f _ = Nothing + +-- a+b(x-c) -> (a+b)(x-c) +rule137 :: Rule (Equation Expr) +rule137 = describe "1.3.7: fout bij haakjes wegwerken; denk aan 'voorrangsregels'" $ + buggyBalanceExprRule "par10" f + where + f (a :+: expr) = do + (b, (x, c)) <- match (timesView >>> second plusView) expr + return $ (a+b)*(x+c) + f _ = Nothing + +------------------------------------------------------------------- +-- 2.0 Links en rechts hetzelfde doen, of verwisselen + +-- a=b-c -> c-b=a +rule201 :: Rule (Equation Expr) +rule201 = describe "2.0.1: Links en rechts alleen maar verwisseld?" $ + buggyBalanceRule "flip1" f + where + f (a :==: rhs) = do + (b, c) <- match minusView rhs + return $ c-b :==: a + +------------------------------------------------------------------- +-- 2.1 Links en rechts hetzelfde optellen/aftrekken + +{- schema addbal regels: (telkens paren met positief/negatief argument) + 1+2 constante naar rechts + 3+4 variabele naar links + 7+8 variabele naar rechts + 9+10 constante naar links + --- + 5/6 constante links weggehaald, maar rechts onveranderd gelaten +-} + +-- ax+b=[cx]+d -> ax=[cx]+d+b +rule2111 :: Rule (Equation Expr) +rule2111 = describe "2.1.1.1: Links en rechts hetzelfde optellen; links +b en rechts -b" $ + buggyBalanceRuleArgs "addbal1" f + where + f (lhs :==: rhs) = do + (ax, b) <- matchPlusCon lhs + guard (b>0) + return (ax :==: rhs+fromRational b, termArg (fromRational b)) + +-- ax-b=[cx]+d -> ax=[cx+d-b +rule2112 :: Rule (Equation Expr) +rule2112 = describe "2.1.1.2: Links en rechts hetzelfde optellen; links -b en rechts +b" $ + buggyBalanceRuleArgs "addbal2" f + where + f (lhs :==: rhs) = do + (ax, b) <- matchPlusCon lhs + guard (b<0) + return (ax :==: rhs+fromRational b, termArg (fromRational (abs b))) + +-- a=cx+d -> a+d=cx +rule2113 :: Rule (Equation Expr) +rule2113 = describe "2.1.1.3: Je trekt er rechts {?} vanaf, maar links tel je {?} erbij op." $ + buggyBalanceRuleArgs "addbal9" f + where + f (lhs :==: rhs) = do + (cx, d) <- matchPlusCon rhs + guard (d>0) + return (lhs+fromRational d :==: cx, termArg (fromRational d)) + +-- a=cx-d -> a-d=cx +rule2114 :: Rule (Equation Expr) +rule2114 = describe "2.1.1.4: Je telt er rechts {?} bij op, maar links trek je {?} er vanaf." $ + buggyBalanceRuleArgs "addbal10" f + where + f (lhs :==: rhs) = do + (cx, d) <- matchPlusCon rhs + guard (d<0) + return (lhs+fromRational d :==: cx, termArg (fromRational (abs d))) + +-- ax[+b]=cx+d -> (a+c)x[+b]=d +rule2121 :: Rule (Equation Expr) +rule2121 = describe "2.1.2.1: Links en rechts hetzelfde optellen; links +cx en rechts -cx" $ + buggyBalanceRuleArgs "addbal3" f + where + f (lhs :==: rhs) = do + (x, a, b) <- matchLin lhs + (y, c, d) <- matchLin rhs + guard (c>0 && x==y) + return ( fromRational (a+c)*x+fromRational b :==: fromRational d + , termArg (fromRational c*x) + ) + +-- ax[+b]=-cx+d -> (a-c)x[+b]=d +rule2122 :: Rule (Equation Expr) +rule2122 = describe "2.1.2.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $ + buggyBalanceRuleArgs "addbal4" f + where + f (lhs :==: rhs) = do + (x, a, b) <- matchLin lhs + (y, c, d) <- matchLin rhs + guard (c<0 && x==y) + return ( fromRational (a+c)*x+fromRational b :==: fromRational d + , termArg (fromRational (abs c)*x) + ) + +-- ax+b=[cx]+d -> ax=[cx]+d +rule2131 :: Rule (Equation Expr) +rule2131 = describe "2.1.3.1: Links en rechts hetzelfde optellen; links -b rechts niet(s)" $ + buggyBalanceRuleArgs "addbal5" f + where + f (lhs :==: rhs) = do + (ax, b) <- matchPlusCon lhs + guard (b > 0) + return (ax :==: rhs, termArg (fromRational b)) + +-- ax-b=[cx]+d -> ax=[cx]+d +rule2132 :: Rule (Equation Expr) +rule2132 = describe "2.1.3.2: Links en rechts hetzelfde optellen; links+b en rechts niet(s)" $ + buggyBalanceRuleArgs "addbal6" f + where + f (lhs :==: rhs) = do + (ax, b) <- matchPlusCon lhs + guard (b < 0) + return (ax :==: rhs, termArg (fromRational (abs b))) + +-- ax+b=cx+d -> b=(a+c)*x+d +rule2141 :: Rule (Equation Expr) +rule2141 = describe "2.1.4.1: Links en rechts hetzelfde optellen; links -ax en rechts +ax" $ + buggyBalanceRuleArgs "addbal7" f + where + f (lhs :==: rhs) = do + (x, a, b) <- matchLin lhs + (y, c, d) <- matchLin rhs + guard (a>0 && x==y) + return ( fromRational b :==: fromRational (a+c)*x+fromRational d + , termArg (fromRational a*x) + ) + +-- -ax+b=cx+d -> b=(-a+c)*x+d +rule2142 :: Rule (Equation Expr) +rule2142 = describe "2.1.4.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $ + buggyBalanceRuleArgs "addbal8" f + where + f (lhs :==: rhs) = do + (x, a, b) <- matchLin lhs + (y, c, d) <- matchLin rhs + guard (a<0 && x==y) + return ( fromRational b :==: fromRational (a+c)*x+fromRational d + , termArg (fromRational (abs a)*x) + ) + +------------------------------------------------------------------- +-- 2.2 Links en rechts hetzelfde vermenigvuldigen/delen + +-- ax=c -> x=a/c +rule221 :: Rule (Equation Expr) +rule221 = describe "2.2.1: Links en rechts hetzelfde vermenigvuldigen; verkeerd om gedeeld" $ + buggyBalanceRule "mulbal1" f + where + f (expr :==: c) = do + (a, x) <- match timesView expr + return $ x :==: a/c + +-- 1/*a+b=2/c*x+d -> x+ba -> 2x+cd +rule222 :: Rule (Equation Expr) +rule222 = describe "2.2.2: Links en rechts hetzelfde vermenigvuldigen; links *a; rechts *b" $ + buggyBalanceRuleArgs "mulbal2" f + where + f (lhs :==: rhs) = do + (x, ra, b) <- matchLin lhs + (y, rc, d) <- matchLin rhs + let a = denom ra + c = denom rc + denom = fromInteger . denominator + num = fromInteger . numerator + guard (a /= c && (a /= 1 || c /= 1)) + return ( num ra*x+fromRational b*a :==: num rc*y+c*fromRational d + , factorArgs [a, c] + ) + +-- ax-b=cx+d -> pax-pb=cx+d +rule2231 :: Rule (Equation Expr) +rule2231 = describe "2.2.3.1: Links en rechts hetzelfde vermenigvuldigen; links *p, rechts niet (of andersom)" $ + buggyBalanceRecognizer "mulbal3" p + where -- currently, symmetric + p (a1 :==: a2) (b1 :==: b2) = do + dl <- diffTimes a1 b1 + dr <- diffTimes a2 b2 + if dl == 1 && dr /= 1 + then return (factorArg dr) + else if dl /= 1 && dr == 1 + then return (factorArg dl) + else Nothing + +-- (x+a)/b=c -> x+a=c +rule2232 :: Rule (Equation Expr) +rule2232 = describe "2.2.3.2: Links en rechts hetzelfde vermenigvuldigen; links /p, rechts niet" $ + buggyBalanceRuleArgs "mulbal4" f + where + f (expr :==: c) = do + (a, b) <- match divView expr + return (a :==: c, factorArg b) + +-- a+b=c -> -a-b=c +rule2233 :: Rule (Equation Expr) +rule2233 = describe "2.2.3.3: Links en rechts hetzelfde vermenigvuldigen; links en rechts *-1" $ + buggyBalanceRule "mulbal5" f + where + f (expr :==: c) = do + (a, b) <- match plusView expr + return $ -a-b :==: c + +-- pa+pb=c -> a+b=c +rule227 :: Rule (Equation Expr) +rule227 = describe "2.2.7: Links en rechts hetzelfde vermenigvuldigen; een kant door p delen, andere kant niets" $ + buggyBalanceRecognizer "mulbal6" p + where -- currently, symmetric + p (a1 :==: a2) (b1 :==: b2) = do + dl <- diffTimes a1 b1 + dr <- diffTimes a2 b2 + rl <- match rationalView dl + rr <- match rationalView dr + if rl == 1 && rr /= 1 && numerator rr == 1 + then return (factorArg (fromIntegral (denominator rr))) + else if rl /= 1 && rr == 1 && numerator rl == 1 + then return (factorArg (fromIntegral (denominator rl))) + else Nothing + +------------------------------------------------------------------- +-- 3.1 Doe je wat je wilt doen? + +-- ax-b=cx-d -> (c-a)x-b=-d +rule311 :: Rule (Equation Expr) +rule311 = describe "3.1.1: Doe je wat je wilt doen?" $ + buggyBalanceRule "misc1" f + where + f (lhs :==: rhs) = do + (x, a, b) <- matchLin lhs + (y, c, d) <- matchLin rhs + guard (x==y) + return (fromRational (c-a)*x+fromRational b :==: fromRational d) + +-- ax-b=cd+d -> pax-b=pcx+pd +rule321 :: Rule (Equation Expr) +rule321 = describe "3.2.1: Doe je wat je wilt doen? vermenigvuldig de hele linkerkant met p" $ + buggyBalanceRecognizer "misc2" p + where -- currently, not symmetric + p (a1 :==: a2) (b1 :==: b2) = do + d <- diffTimes a2 b2 + let as = from simpleSumView a1 + guard (d `notElem` [1, -1] && length as > 1) + guard $ flip any (take (length as) [0..]) $ \i -> + let (xs,y:ys) = splitAt i as + aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys + in viewEquivalent (polyViewWith rationalView) aps b1 + return (factorArg d) + +-- a-b=c -> -a-b=-c +rule322 :: Rule (Equation Expr) +rule322 = describe "3.2.2: Doe je wat je wilt doen? neem het tegengestelde van de hele linkerkant" $ + buggyBalanceRule "misc3" f + where + f (expr :==: c) = do + (a, b) <- match minusView expr + return $ -a-b :==: -c + +-- pax+pb=pc -> ax+pb=c +rule323 :: Rule (Equation Expr) +rule323 = describe "3.2.3: Doe je wat je wilt doen? Deel de hele linkerkant door p" $ + buggyBalanceRecognizer "misc4" p + -- REFACTOR: code copied from rule misc2 + where -- currently, not symmetric + p (a1 :==: a2) (b1 :==: b2) = do + d <- diffTimes a2 b2 + dr <- match rationalView d + let as = from simpleSumView a1 + guard (dr `notElem` [0, 1, -1] && numerator dr == 1 && length as > 1) + guard $ flip any (take (length as) [0..]) $ \i -> + let (xs,y:ys) = splitAt i as + aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys + in viewEquivalent (polyViewWith rationalView) aps b1 + return (factorArg (fromRational (1/dr))) diff --git a/src/Domain/Math/Polynomial/BuggyRules.hs b/src/Domain/Math/Polynomial/BuggyRules.hs --- a/src/Domain/Math/Polynomial/BuggyRules.hs +++ b/src/Domain/Math/Polynomial/BuggyRules.hs @@ -1,468 +1,463 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Some buggy rules catching common misconceptions (also on the abc-formula) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.BuggyRules where - -import Prelude hiding ((^)) -import Common.Id -import Domain.Math.Expr -import Domain.Math.Data.Relation -import Domain.Math.Data.OrList -import Domain.Math.Polynomial.Views -import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Numeric.Views -import Domain.Math.Data.Polynomial -import Domain.Math.Equation.CoverUpRules -import Common.Classes -import Common.Context -import Common.Rewriting -import Common.View -import Common.Transformation (Rule, buggyRule, siblingOf, Transformation, useRecognizer, supply1, makeTransList) -import Control.Monad -import qualified Common.Transformation as Rule - -makeRule :: IsId n => n -> Transformation a -> Rule a -makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a -makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a -ruleList :: (RuleBuilder f a, Rewrite a, IsId n) => n -> [f] -> Rule a - -makeRule = buggyName Rule.makeRule -makeSimpleRule = buggyName Rule.makeSimpleRule -makeSimpleRuleList = buggyName Rule.makeSimpleRuleList -ruleList = buggyName Rule.ruleList - -buggyName :: IsId n => (Id -> a) -> n -> a -buggyName f s = f ("algebra.equations.buggy" # s) - -buggyRulesExpr :: [Rule Expr] -buggyRulesExpr = - map (siblingOf distributeTimes) - [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign - , buggyDistrTimesTooMany, buggyDistrTimesDenom - ] ++ - [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined - ] - -buggyRulesEquation :: [Rule (Equation Expr)] -buggyRulesEquation = - [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide - , buggyNegateAll - , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus - , buggyMultiplyOneSide, buggyMultiplyForgetOne - ] - -buggyPlus :: Rule (Equation Expr) -buggyPlus = describe "Moving a term from the left-hand side to the \ - \right-hand side (or the other way around), but forgetting to change \ - \the sign." $ - buggyRule $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do - (a, b) <- matchM plusView lhs - [ a :==: rhs + b, b :==: rhs + a ] - `mplus` do - (a, b) <- matchM plusView rhs - [ lhs + a :==: b, lhs + b :==: a ] - -buggyNegateOneSide :: Rule (Equation Expr) -buggyNegateOneSide = describe "Negate terms on one side only." $ - buggyRule $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) -> - [ -lhs :==: rhs, lhs :==: -rhs ] - -buggyFlipNegateOneSide :: Rule (Equation Expr) -buggyFlipNegateOneSide = describe "Negate terms on one side only." $ - buggyRule $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) -> - [ -rhs :==: lhs, rhs :==: -lhs ] - -buggyNegateAll :: Rule (Equation Expr) -buggyNegateAll = describe "Negating all terms (on both sides of the equation, \ - \but forgetting one term." $ - buggyRule $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do - xs <- matchM sumView lhs - ys <- matchM sumView rhs - let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys) - makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys) - makeEq as bs = build sumView as :==: build sumView bs - f i j = if i==j then id else negate - len as = let n = length as in if n < 2 then -1 else n - map makeL [0 .. len xs] ++ map makeR [0 .. len ys] - -buggyDivNegate :: Rule (Equation Expr) -buggyDivNegate = describe "Dividing, but wrong sign." $ - buggyRule $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do - (a, b) <- matchM timesView lhs - [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ] - `mplus` do - (a, b) <- matchM timesView rhs - [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ] - -buggyDivNumDenom :: Rule (Equation Expr) -buggyDivNumDenom = describe "Dividing both sides, but swapping \ - \numerator/denominator." $ - buggyRule $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do - (a, b) <- matchM timesView lhs - [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ] - `mplus` do - (a, b) <- matchM timesView rhs - [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ] - -buggyDistrTimes :: Rule Expr -buggyDistrTimes = describe "Incorrect distribution of times over plus: one \ - \term is not multiplied." $ - buggyRule $ makeSimpleRuleList "distr-times-plus" $ \expr -> do - (a, (b, c)) <- matchM (timesView >>> second plusView) expr - [ a*b+c, b+a*c ] - `mplus` do - ((a, b), c) <- matchM (timesView >>> first plusView) expr - [ a*c+b, a+b*c ] - -buggyDistrTimesForget :: Rule Expr -buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \ - \one term is forgotten." $ - buggyRule $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do - (a, (b, c)) <- matchM (timesView >>> second plusView) expr - [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ] - `mplus` do - ((a, b), c) <- matchM (timesView >>> first plusView) expr - [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b] - where - forget :: Expr -> [Expr] - forget expr = - case match productView expr of - Just (b, xs) | n > 1 -> - [ build productView (b, make i) | i <- [0..n-1] ] - where - make i = [ x | (j, x) <- zip [0..] xs, i/=j ] - n = length xs - _ -> [0] - -buggyDistrTimesSign :: Rule Expr -buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \ - \changing sign of addition." $ - buggyRule $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do - (a, (b, c)) <- matchM (timesView >>> second plusView) expr - [ a.*.b .-. a.*.c ] - `mplus` do - ((a, b), c) <- matchM (timesView >>> first plusView) expr - [ a.*.c .-. b.*.c ] - -buggyDistrTimesTooMany :: Rule Expr -buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \ - \a*(b+c)+d, where 'a' is also multiplied to d." $ - buggyRule $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do - ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr - [cleanUpExpr $ a*b+a*c+a*d] - -buggyDistrTimesDenom :: Rule Expr -buggyDistrTimesDenom = describe "Incorrct distribution of times over plus: \ - \one of the terms is a fraction, and the outer expression is multiplied by \ - \the fraction's denominator." $ - buggyRule $ makeSimpleRuleList "distr-times-denom" $ \expr -> do - (a, (b, c)) <- matchM (timesView >>> second plusView) expr - [(1/a)*b + a*c, a*b + (1/a)*c] - `mplus` do - ((a, b), c) <- matchM (timesView >>> first plusView) expr - [a*(1/c) + b*c, a*c + b*(1/c)] - -buggyMinusMinus :: Rule Expr -buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \ - \change sign." $ - buggyRule $ makeSimpleRule "minus-minus" $ \expr -> - case expr of - a :-: (b :-: c) -> Just (a-b-c) - Negate (a :-: b) -> Just (a-b) - _ -> Nothing - -buggyCancelMinus :: Rule (Equation Expr) -buggyCancelMinus = describe "Cancel terms on both sides, but terms have \ - \different signs." $ - buggyRule $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do - xs <- matchM sumView lhs - ys <- matchM sumView rhs - [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys - , cleanUpExpr x == cleanUpExpr (-y) - , let f n as = build sumView $ take n as ++ drop (n+1) as - , let eq = f i xs :==: f j ys - ] - -buggyPriorityTimes :: Rule Expr -buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \ - \ignoring some parentheses." $ - buggyRule $ makeSimpleRuleList "priority-times" $ \expr -> do - (a, (b, c)) <- matchM (plusView >>> second timesView) expr - [(a+b)*c] - `mplus` do - ((a, b), c) <- matchM (plusView >>> first timesView) expr - [a*(b+c)] - -buggyMultiplyOneSide :: Rule (Equation Expr) -buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $ - buggyRule $ makeRule "multiply-one-side" $ - useRecognizer recognizeEq $ supply1 (const (Just 2)) multiplyOneSide - where - recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) = - let p r = r `notElem` [-1, 0, 1] && - any (myEq eq2) (applyAll (multiplyOneSide r) eq1) - in maybe False p (recognizeMultiplication a1 b1) - || maybe False p (recognizeMultiplication a2 b2) - -recognizeMultiplication :: Expr -> Expr -> Maybe Rational -recognizeMultiplication a b = do - (_, pa) <- match (polyViewWith rationalView) a - (_, pb) <- match (polyViewWith rationalView) b - let d = coefficient (degree pa) pa - guard (d /= 0) - return (coefficient (degree pb) pb / d) - -multiplyOneSide :: Rational -> Transformation (Equation Expr) -multiplyOneSide r = makeTransList $ \(lhs :==: rhs) -> do - xs <- matchM sumView lhs - ys <- matchM sumView rhs - let f = map (*fromRational r) - [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)] - -buggyMultiplyForgetOne :: Rule (Equation Expr) -buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \ - \equation, but forget one." $ - buggyRule $ makeRule "multiply-forget-one" $ - useRecognizer recognizeEq $ supply1 (const (Just 2)) multiplyForgetOne - where - recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) = - let p r = r `notElem` [-1, 0, 1] && - any (myEq eq2) (applyAll (multiplyForgetOne r) eq1) - in maybe False p (recognizeMultiplication a1 b1) - || maybe False p (recognizeMultiplication a2 b2) - -multiplyForgetOne :: Rational -> Transformation (Equation Expr) -multiplyForgetOne r = makeTransList $ \(lhs :==: rhs) -> do - xs <- matchM sumView lhs - ys <- matchM sumView rhs - let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys) - makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys) - f as bs = build sumView as :==: build sumView bs - mul b = if b then (*fromRational r) else id - do guard (length xs > 1) - map makeL [0 .. length xs-1] - `mplus` do - guard (length ys > 1) - map makeR [0 .. length ys-1] - --- Redundant function; should come from exercise -myEq :: Equation Expr -> Equation Expr -> Bool -myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr) - ---------------------------------------------------------- --- Quadratic and Higher-Degree Polynomials - -buggyQuadratic :: IsTerm a => [Rule (Context a)] -buggyQuadratic = - map use - [ buggyCoverUpTimesMul, buggyCoverUpEvenPower - , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth - , buggyDivisionByVarZero - ] ++ - map use - [ buggyDistributionSquare, buggyDistributionSquareForget - , buggySquareMultiplication - ] ++ - map use - [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget - , buggyCoverUpSquareMinus - ] - -buggyCoverUpEvenPower :: Rule (Equation Expr) -buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \ - \the negative root" $ buggyRule $ siblingOf coverUpPower $ - makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) -> - make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs - where - make equals ab c = do - (a, b) <- isBinary powerSymbol ab - n <- matchM integerView b - guard (n > 0 && even n) - return (a `equals` root c (fromInteger n)) - -buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr)) -buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \ - \but there is some other operation to be done first. Example: x^2+1=9" $ - buggyRule $ siblingOf coverUpPower $ - makeSimpleRuleList "coverup.even-power-too-early" $ - oneDisjunct $ helperBuggyCUPower True - -buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr)) -buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \ - \but there is some other operation to be done first. Example: 9*x^2=81, \ - \ and rewriting this into x=9 or x=-9." $ - buggyRule $ siblingOf coverUpPower $ - makeSimpleRuleList "coverup.even-power-forget" $ - oneDisjunct $ helperBuggyCUPower False - -helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)] -helperBuggyCUPower mode (lhs :==: rhs) = - make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs - where - make equals ab c = do - (sym, xs) <- getFunction ab - (i, x) <- zip [0..] xs - (a, b) <- isBinary powerSymbol x - n <- matchM integerView b - guard (n > 0 && even n) - let opa | mode = function sym (take i xs ++ [a] ++ drop (i+1) xs) - | otherwise = a - rb = root c (fromInteger n) - return $ orList [opa `equals` rb, opa `equals` (-rb)] - -buggyCoverUpTimesMul :: Rule (Equation Expr) -buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \ - \dividing the right-hand side, multiplication is used." $ - buggyRule $ siblingOf coverUpTimes $ - makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do - guard (rhs /= 0) - (a, b) <- isTimes lhs - [a :==: rhs*b, b :==: rhs*a] - `mplus` do - guard (lhs /= 0) - (a, b) <- isTimes rhs - [lhs*a :==: b, lhs*b :==: a] - -buggyDistributionSquare :: Rule Expr -buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \ - \addition: forgetting the 2ab term" $ - buggyRule $ siblingOf distributionSquare $ - ruleList "distr-square" - [ \a b -> (a+b)^2 :~> a^2+b^2 - , \a b -> (a-b)^2 :~> a^2-b^2 - , \a b -> (a-b)^2 :~> a^2+b^2 - ] - -buggyDistributionSquareForget :: Rule Expr -buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \ - \addition: squaring only one term" $ - buggyRule $ siblingOf distributionSquare $ - ruleList "distr-square-forget" - [ \a b -> (a+b)^2 :~> a^2+b - , \a b -> (a+b)^2 :~> a+b^2 - , \a b -> (a-b)^2 :~> a^2-b - , \a b -> (a-b)^2 :~> a-b^2 - ] - -buggySquareMultiplication :: Rule Expr -buggySquareMultiplication = describe "Incorrect square of a term that involves \ - \a multiplication." $ buggyRule $ - ruleList "square-multiplication" - [ \a b -> (a*b)^2 :~> a*b^2 - , \a b -> (a*b)^2 :~> a^2*b - , \a b -> a*b^2 :~> (a*b)^2 - , \a b -> a^2*b :~> (a*b)^2 - ] - -buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr)) -buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \ - \on the right-hand side, resulting in an error in the signs" $ - buggyRule $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq -> - case eq of - Sym s [a, 2] :==: b | isPowerSymbol s -> - Just $ orList [a :==: sqrt b, a :==: sqrt (-b)] - _ -> Nothing - -buggyCoverUpTimesWithPlus :: Rule (Equation Expr) -buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \ - \addition on the other side. Only one of the terms is divided." $ - buggyRule $ makeSimpleRuleList "coverup.times-with-plus" $ - \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs - where - make equals ab cd = do - (a, b) <- isTimes ab - (c, d) <- isPlus cd - [ a `equals` (c/b+d), a `equals` (c+d/b), - b `equals` (c/a+d), b `equals` (c+d/a) ] - -buggyDivisionByVarBoth :: Rule (Equation Expr) -buggyDivisionByVarBoth = describe "Divide both sides by variable, without \ - \introducing the x=0 alternative." $ - buggyRule $ makeSimpleRule "division-by-var-both" $ - \(lhs :==: rhs) -> do - (s1, p1) <- match polyView lhs - (s2, p2) <- match polyView rhs - let n = lowestDegree p1 `min` lowestDegree p2 - guard (n > 0 && s1==s2) - let f p = build polyView (s1, raise (-n) p) - return (f p1 :==: f p2) - -buggyDivisionByVarZero :: Rule (Equation Expr) -buggyDivisionByVarZero = describe "Divide both sides by variable, without \ - \introducing the x=0 alternative." $ - buggyRule $ makeSimpleRuleList "division-by-var-zero" $ - \(lhs :==: rhs) -> do - guard (rhs == 0) - (s, p) <- matchM polyView lhs - let n = lowestDegree p - guard (n > 0) - -- Quick fix to do some trivial steps for a linear equation, so that - -- buggy rules are recognized. - let eq = build polyView (s, raise (-n) p) :==: 0 - eq : applyM coverUpPlus eq - ---------------------------------------------------------- --- ABC formula misconceptions - -abcBuggyRules :: [Rule (OrList (Equation Expr))] -abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ] - -abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)]) - -> Transformation (OrList (Equation Expr)) -abcMisconception f = makeTransList $ - oneDisjunct $ \(lhs :==: rhs) -> do - guard (rhs == 0) - (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs - f x a b c - -minusB :: Rule (OrList (Equation Expr)) -minusB = buggyRule $ makeRule "abc.minus-b" $ - abcMisconception $ \x a b c -> do - let discr = sqrt (fromRational (b*b - 4 * a * c)) - f (?) buggy = - let minus = if buggy then id else negate - in Var x :==: (minus (fromRational b) ? discr) / (2 * fromRational a) - [ orList [ f (+) True, f (-) True ], - orList [ f (+) False, f (-) True ], - orList [ f (+) True, f (-) False ]] - - -twoA :: Rule (OrList (Equation Expr)) -twoA = buggyRule $ makeRule "abc.two-a" $ - abcMisconception $ \x a b c -> do - let discr = sqrt (fromRational (b*b - 4 * a * c)) - f (?) buggy = - let twice = if buggy then id else (2*) - in Var x :==: (-fromRational b ? discr) / twice (fromRational a) - [ orList [ f (+) True, f (-) True ], - orList [ f (+) False, f (-) True ], - orList [ f (+) True, f (-) False ]] - -minus4AC :: Rule (OrList (Equation Expr)) -minus4AC = buggyRule $ makeRule "abc.minus-4ac" $ - abcMisconception $ \x a b c -> do - let discr (?) = sqrt (fromRational ((b*b) ? (4 * a * c))) - f (?) buggy = - let op = if buggy then (+) else (-) - in Var x :==: (-fromRational b ? discr op) / (2 * fromRational a) - [ orList [ f (+) True, f (-) True ], - orList [ f (+) False, f (-) True ], - orList [ f (+) True, f (-) False ]] - -oneSolution :: Rule (OrList (Equation Expr)) -oneSolution = buggyRule $ makeRule "abc.one-solution" $ - abcMisconception $ \x a b c -> do - let discr = sqrt (fromRational (b*b - 4 * a * c)) - f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a) - [ return $ f (+), return $ f (-) ] +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Some buggy rules catching common misconceptions (also on the abc-formula) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.BuggyRules where + +import Common.Library hiding (makeRule, makeSimpleRule, makeSimpleRuleList, + ruleList, root) +import Control.Monad +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Polynomial +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Views +import Prelude hiding ((^)) +import qualified Common.Transformation as Rule + +makeRule :: IsId n => n -> Transformation a -> Rule a +makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a +makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a +ruleList :: (RuleBuilder f a, IsId n) => n -> [f] -> Rule a + +makeRule = buggyName Rule.makeRule +makeSimpleRule = buggyName Rule.makeSimpleRule +makeSimpleRuleList = buggyName Rule.makeSimpleRuleList +ruleList = buggyName Rule.ruleList + +buggyName :: IsId n => (Id -> a) -> n -> a +buggyName f s = f ("algebra.equations.buggy" # s) + +buggyRulesExpr :: [Rule Expr] +buggyRulesExpr = + map (siblingOf distributeTimes) + [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign + , buggyDistrTimesTooMany, buggyDistrTimesDenom + ] ++ + [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined + ] + +buggyRulesEquation :: [Rule (Equation Expr)] +buggyRulesEquation = + [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide + , buggyNegateAll + , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus + , buggyMultiplyOneSide, buggyMultiplyForgetOne + ] + +buggyPlus :: Rule (Equation Expr) +buggyPlus = describe "Moving a term from the left-hand side to the \ + \right-hand side (or the other way around), but forgetting to change \ + \the sign." $ + buggyRule $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do + (a, b) <- matchM plusView lhs + [ a :==: rhs + b, b :==: rhs + a ] + `mplus` do + (a, b) <- matchM plusView rhs + [ lhs + a :==: b, lhs + b :==: a ] + +buggyNegateOneSide :: Rule (Equation Expr) +buggyNegateOneSide = describe "Negate terms on one side only." $ + buggyRule $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) -> + [ -lhs :==: rhs, lhs :==: -rhs ] + +buggyFlipNegateOneSide :: Rule (Equation Expr) +buggyFlipNegateOneSide = describe "Negate terms on one side only." $ + buggyRule $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) -> + [ -rhs :==: lhs, rhs :==: -lhs ] + +buggyNegateAll :: Rule (Equation Expr) +buggyNegateAll = describe "Negating all terms (on both sides of the equation, \ + \but forgetting one term." $ + buggyRule $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys) + makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys) + makeEq as bs = build sumView as :==: build sumView bs + f i j = if i==j then id else negate + len as = let n = length as in if n < 2 then -1 else n + map makeL [0 .. len xs] ++ map makeR [0 .. len ys] + +buggyDivNegate :: Rule (Equation Expr) +buggyDivNegate = describe "Dividing, but wrong sign." $ + buggyRule $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do + (a, b) <- matchM timesView lhs + [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ] + `mplus` do + (a, b) <- matchM timesView rhs + [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ] + +buggyDivNumDenom :: Rule (Equation Expr) +buggyDivNumDenom = describe "Dividing both sides, but swapping \ + \numerator/denominator." $ + buggyRule $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do + (a, b) <- matchM timesView lhs + [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ] + `mplus` do + (a, b) <- matchM timesView rhs + [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ] + +buggyDistrTimes :: Rule Expr +buggyDistrTimes = describe "Incorrect distribution of times over plus: one \ + \term is not multiplied." $ + buggyRule $ makeSimpleRuleList "distr-times-plus" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [ a*b+c, b+a*c ] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [ a*c+b, a+b*c ] + +buggyDistrTimesForget :: Rule Expr +buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \ + \one term is forgotten." $ + buggyRule $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b] + where + forget :: Expr -> [Expr] + forget expr = + case match productView expr of + Just (b, xs) | n > 1 -> + [ build productView (b, make i) | i <- [0..n-1] ] + where + make i = [ x | (j, x) <- zip [0..] xs, i/=j ] + n = length xs + _ -> [0] + +buggyDistrTimesSign :: Rule Expr +buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \ + \changing sign of addition." $ + buggyRule $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [ a.*.b .-. a.*.c ] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [ a.*.c .-. b.*.c ] + +buggyDistrTimesTooMany :: Rule Expr +buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \ + \a*(b+c)+d, where 'a' is also multiplied to d." $ + buggyRule $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do + ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr + [cleanUpExpr $ a*b+a*c+a*d] + +buggyDistrTimesDenom :: Rule Expr +buggyDistrTimesDenom = describe "Incorrct distribution of times over plus: \ + \one of the terms is a fraction, and the outer expression is multiplied by \ + \the fraction's denominator." $ + buggyRule $ makeSimpleRuleList "distr-times-denom" $ \expr -> do + (a, (b, c)) <- matchM (timesView >>> second plusView) expr + [(1/a)*b + a*c, a*b + (1/a)*c] + `mplus` do + ((a, b), c) <- matchM (timesView >>> first plusView) expr + [a*(1/c) + b*c, a*c + b*(1/c)] + +buggyMinusMinus :: Rule Expr +buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \ + \change sign." $ + buggyRule $ makeSimpleRule "minus-minus" $ \expr -> + case expr of + a :-: (b :-: c) -> Just (a-b-c) + Negate (a :-: b) -> Just (a-b) + _ -> Nothing + +buggyCancelMinus :: Rule (Equation Expr) +buggyCancelMinus = describe "Cancel terms on both sides, but terms have \ + \different signs." $ + buggyRule $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys + , cleanUpExpr x == cleanUpExpr (-y) + , let f n as = build sumView $ take n as ++ drop (n+1) as + , let eq = f i xs :==: f j ys + ] + +buggyPriorityTimes :: Rule Expr +buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \ + \ignoring some parentheses." $ + buggyRule $ makeSimpleRuleList "priority-times" $ \expr -> do + (a, (b, c)) <- matchM (plusView >>> second timesView) expr + [(a+b)*c] + `mplus` do + ((a, b), c) <- matchM (plusView >>> first timesView) expr + [a*(b+c)] + +buggyMultiplyOneSide :: Rule (Equation Expr) +buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $ + buggyRule $ makeRule "multiply-one-side" $ + useSimpleRecognizer recognizeEq $ supply1 "factor" (const (Just 2)) multiplyOneSide + where + recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) = + let p r = r `notElem` [-1, 0, 1] && + any (myEq eq2) (applyAll (multiplyOneSide (fromRational r)) eq1) + in maybe False p (recognizeMultiplication a1 b1) + || maybe False p (recognizeMultiplication a2 b2) + +recognizeMultiplication :: Expr -> Expr -> Maybe Rational +recognizeMultiplication a b = do + (_, pa) <- match (polyViewWith rationalView) a + (_, pb) <- match (polyViewWith rationalView) b + let d = coefficient (degree pa) pa + guard (d /= 0) + return (coefficient (degree pb) pb / d) + +multiplyOneSide :: Expr -> Transformation (Equation Expr) +multiplyOneSide r = makeTransList $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + let f = map (*r) + [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)] + +buggyMultiplyForgetOne :: Rule (Equation Expr) +buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \ + \equation, but forget one." $ + buggyRule $ makeRule "multiply-forget-one" $ + useSimpleRecognizer recognizeEq $ supply1 "factor" (const (Just 2)) multiplyForgetOne + where + recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) = + let p r = r `notElem` [-1, 0, 1] && + any (myEq eq2) (applyAll (multiplyForgetOne (fromRational r)) eq1) + in maybe False p (recognizeMultiplication a1 b1) + || maybe False p (recognizeMultiplication a2 b2) + +multiplyForgetOne :: Expr -> Transformation (Equation Expr) +multiplyForgetOne r = makeTransList $ \(lhs :==: rhs) -> do + xs <- matchM sumView lhs + ys <- matchM sumView rhs + let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys) + makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys) + f as bs = build sumView as :==: build sumView bs + mul b = if b then (*r) else id + do guard (length xs > 1) + map makeL [0 .. length xs-1] + `mplus` do + guard (length ys > 1) + map makeR [0 .. length ys-1] + +-- Redundant function; should come from exercise +myEq :: Equation Expr -> Equation Expr -> Bool +myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr) + +--------------------------------------------------------- +-- Quadratic and Higher-Degree Polynomials + +buggyQuadratic :: IsTerm a => [Rule (Context a)] +buggyQuadratic = + map use + [ buggyCoverUpTimesMul, buggyCoverUpEvenPower + , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth + , buggyDivisionByVarZero + ] ++ + map use + [ buggyDistributionSquare, buggyDistributionSquareForget + , buggySquareMultiplication + ] ++ + map use + [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget + , buggyCoverUpSquareMinus + ] + +buggyCoverUpEvenPower :: Rule (Equation Expr) +buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \ + \the negative root" $ buggyRule $ siblingOf coverUpPower $ + makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) -> + make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs + where + make equals ab c = do + (a, b) <- isBinary powerSymbol ab + n <- matchM integerView b + guard (n > 0 && even n) + return (a `equals` root c (fromInteger n)) + +buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr)) +buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \ + \but there is some other operation to be done first. Example: x^2+1=9" $ + buggyRule $ siblingOf coverUpPower $ + makeSimpleRuleList "coverup.even-power-too-early" $ + oneDisjunct $ helperBuggyCUPower True + +buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr)) +buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \ + \but there is some other operation to be done first. Example: 9*x^2=81, \ + \ and rewriting this into x=9 or x=-9." $ + buggyRule $ siblingOf coverUpPower $ + makeSimpleRuleList "coverup.even-power-forget" $ + oneDisjunct $ helperBuggyCUPower False + +helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)] +helperBuggyCUPower mode (lhs :==: rhs) = + make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs + where + make equals ab c = do + (sym, xs) <- getFunction ab + (i, x) <- zip [0..] xs + (a, b) <- isBinary powerSymbol x + n <- matchM integerView b + guard (n > 0 && even n) + let opa | mode = function sym (take i xs ++ [a] ++ drop (i+1) xs) + | otherwise = a + rb = root c (fromInteger n) + return $ toOrList [opa `equals` rb, opa `equals` (-rb)] + +buggyCoverUpTimesMul :: Rule (Equation Expr) +buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \ + \dividing the right-hand side, multiplication is used." $ + buggyRule $ siblingOf coverUpTimes $ + makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do + guard (rhs /= 0) + (a, b) <- isTimes lhs + [a :==: rhs*b, b :==: rhs*a] + `mplus` do + guard (lhs /= 0) + (a, b) <- isTimes rhs + [lhs*a :==: b, lhs*b :==: a] + +buggyDistributionSquare :: Rule Expr +buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \ + \addition: forgetting the 2ab term" $ + buggyRule $ siblingOf distributionSquare $ + ruleList "distr-square" + [ \a b -> (a+b)^2 :~> a^2+b^2 + , \a b -> (a-b)^2 :~> a^2-b^2 + , \a b -> (a-b)^2 :~> a^2+b^2 + ] + +buggyDistributionSquareForget :: Rule Expr +buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \ + \addition: squaring only one term" $ + buggyRule $ siblingOf distributionSquare $ + ruleList "distr-square-forget" + [ \a b -> (a+b)^2 :~> a^2+b + , \a b -> (a+b)^2 :~> a+b^2 + , \a b -> (a-b)^2 :~> a^2-b + , \a b -> (a-b)^2 :~> a-b^2 + ] + +buggySquareMultiplication :: Rule Expr +buggySquareMultiplication = describe "Incorrect square of a term that involves \ + \a multiplication." $ buggyRule $ + ruleList "square-multiplication" + [ \a b -> (a*b)^2 :~> a*b^2 + , \a b -> (a*b)^2 :~> a^2*b + , \a b -> a*b^2 :~> (a*b)^2 + , \a b -> a^2*b :~> (a*b)^2 + ] + +buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr)) +buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \ + \on the right-hand side, resulting in an error in the signs" $ + buggyRule $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq -> + case eq of + Sym s [a, 2] :==: b | isPowerSymbol s -> + Just $ toOrList [a :==: sqrt b, a :==: sqrt (-b)] + _ -> Nothing + +buggyCoverUpTimesWithPlus :: Rule (Equation Expr) +buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \ + \addition on the other side. Only one of the terms is divided." $ + buggyRule $ makeSimpleRuleList "coverup.times-with-plus" $ + \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs + where + make equals ab cd = do + (a, b) <- isTimes ab + (c, d) <- isPlus cd + [ a `equals` (c/b+d), a `equals` (c+d/b), + b `equals` (c/a+d), b `equals` (c+d/a) ] + +buggyDivisionByVarBoth :: Rule (Equation Expr) +buggyDivisionByVarBoth = describe "Divide both sides by variable, without \ + \introducing the x=0 alternative." $ + buggyRule $ makeSimpleRule "division-by-var-both" $ + \(lhs :==: rhs) -> do + (s1, p1) <- match polyView lhs + (s2, p2) <- match polyView rhs + let n = lowestDegree p1 `min` lowestDegree p2 + guard (n > 0 && s1==s2) + let f p = build polyView (s1, raise (-n) p) + return (f p1 :==: f p2) + +buggyDivisionByVarZero :: Rule (Equation Expr) +buggyDivisionByVarZero = describe "Divide both sides by variable, without \ + \introducing the x=0 alternative." $ + buggyRule $ makeSimpleRuleList "division-by-var-zero" $ + \(lhs :==: rhs) -> do + guard (rhs == 0) + (s, p) <- matchM polyView lhs + let n = lowestDegree p + guard (n > 0) + -- Quick fix to do some trivial steps for a linear equation, so that + -- buggy rules are recognized. + let eq = build polyView (s, raise (-n) p) :==: 0 + eq : applyM coverUpPlus eq + +--------------------------------------------------------- +-- ABC formula misconceptions + +abcBuggyRules :: [Rule (OrList (Equation Expr))] +abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ] + +abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)]) + -> Transformation (OrList (Equation Expr)) +abcMisconception f = makeTransList $ + oneDisjunct $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs + f x a b c + +minusB :: Rule (OrList (Equation Expr)) +minusB = buggyRule $ makeRule "abc.minus-b" $ + abcMisconception $ \x a b c -> do + let discr = sqrt (fromRational (b*b - 4 * a * c)) + f (?) buggy = + let minus = if buggy then id else negate + in Var x :==: (minus (fromRational b) ? discr) / (2 * fromRational a) + [ toOrList [ f (+) True, f (-) True ], + toOrList [ f (+) False, f (-) True ], + toOrList [ f (+) True, f (-) False ]] + +twoA :: Rule (OrList (Equation Expr)) +twoA = buggyRule $ makeRule "abc.two-a" $ + abcMisconception $ \x a b c -> do + let discr = sqrt (fromRational (b*b - 4 * a * c)) + f (?) buggy = + let twice = if buggy then id else (2*) + in Var x :==: (-fromRational b ? discr) / twice (fromRational a) + [ toOrList [ f (+) True, f (-) True ], + toOrList [ f (+) False, f (-) True ], + toOrList [ f (+) True, f (-) False ]] + +minus4AC :: Rule (OrList (Equation Expr)) +minus4AC = buggyRule $ makeRule "abc.minus-4ac" $ + abcMisconception $ \x a b c -> do + let discr (?) = sqrt (fromRational ((b*b) ? (4 * a * c))) + f (?) buggy = + let op = if buggy then (+) else (-) + in Var x :==: (-fromRational b ? discr op) / (2 * fromRational a) + [ toOrList [ f (+) True, f (-) True ], + toOrList [ f (+) False, f (-) True ], + toOrList [ f (+) True, f (-) False ]] + +oneSolution :: Rule (OrList (Equation Expr)) +oneSolution = buggyRule $ makeRule "abc.one-solution" $ + abcMisconception $ \x a b c -> + let discr = sqrt (fromRational (b*b - 4 * a * c)) + f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a) + in [ singleton $ f (+), singleton $ f (-) ] diff --git a/src/Domain/Math/Polynomial/CleanUp.hs b/src/Domain/Math/Polynomial/CleanUp.hs deleted file mode 100644 --- a/src/Domain/Math/Polynomial/CleanUp.hs +++ /dev/null @@ -1,210 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.CleanUp - ( cleanUpRelations, cleanUpRelation, cleanUpExpr - , cleanUpSimple, collectLikeTerms - , acExpr, smart - ) where - -import Common.Utils (fixpoint) -import Common.Uniplate -import Common.View -import Control.Monad -import Data.List -import Data.Maybe -import Data.Ord -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Data.SquareRoot (fromSquareRoot) -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Power.OldViews -import Domain.Math.Simplification hiding (simplify, simplifyWith) -import Domain.Math.SquareRoot.Views -import Prelude hiding ((^), recip) -import qualified Prelude -import Data.Ratio - ----------------------------------------------------------------------- --- Root simplification - -simplerRoot :: Rational -> Integer -> Expr -simplerRoot a b - | b < 0 = 1 ./. simplerRoot a (abs b) - | a < 0 && odd b = neg (simplerRoot (abs a) b) - | otherwise = f (numerator a) b ./. f (denominator a) b - where - f x y - | x == 0 = 0 - | y == 0 || x <= 0 = root (fromIntegral x) (fromIntegral y) - | e Prelude.^ y == x = fromIntegral e - | otherwise = root (fromIntegral x) (fromIntegral y) - where - e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y)) - ----------------------------------------------------------------------- --- Expr normalization - -collectLikeTerms :: Expr -> Expr -collectLikeTerms = simplifyWith f sumView - where - f = mergeAlikeSum . map (simplifyWith (second mergeAlikeProduct) productView) - ------------------------------------------------------------- --- Cleaning up - -cleanUpSimple :: Expr -> Expr -cleanUpSimple = fixpoint (transform (f2 . f1)) - where - use v = simplifyWith (assocPlus v) sumView - f1 = use rationalView - f2 = smartConstructors - -cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr) -cleanUpRelations = idempotent . join . fmap cleanUpRelation - -cleanUpRelation :: Relation Expr -> OrList (Relation Expr) -cleanUpRelation = f . fmap cleanUpBU - where - f rel - | any falsity (universe a ++ universe b) = false - | a == b = fromBool (relationType rel `elem` equals) - | otherwise = - case (match rationalView a, match rationalView b) of - (Just r, Just s) -> fromBool (eval (relationType rel) r s) - _ -> return rel - where - (a, b) = (leftHandSide rel, rightHandSide rel) - - equals = - [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately] - - falsity :: Expr -> Bool - falsity (Sqrt e) = maybe False (<0) (match rationalView e) - falsity (_ :/: e) = maybe False (==0) (match rationalView e) - falsity _ = False - --- also simplify square roots -cleanUpExpr :: Expr -> Expr -cleanUpExpr = fixpoint $ - cleanUpBU . transform (simplify (squareRootViewWith rationalView)) - --- normalize expr with associativity and commutative rules for + and * -acExpr :: Expr -> Expr -acExpr expr = - case (match sumView expr, match productView expr) of - (Just xs, _) | length xs > 1 -> - build sumView $ sort $ map acExpr xs - (_, Just (b, xs)) | length xs > 1 -> - build productView (b, sort $ map acExpr xs) - _ -> - descend acExpr expr - ------------------------------------------------------------- --- Technique 1: fixed points of views -{- -cleanUpFix :: Expr -> Expr -cleanUpFix = fixpoint (f4 . f3 . f2 . f1) - where - use v = transform (simplifyWith (assoPlus v) sumView) - - f1 = use rationalView - f2 = use (squareRootViewWith rationalView) - f3 = use (powerFactorViewWith rationalView) - f4 = smartConstructors --} -assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr] -assocPlus = assocOp (+) -assocTimes = assocOp (*) - -assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr] -assocOp op v = rec . map (simplify v) - where - rec (x:y:zs) = - case canonical v (op x y) of - Just a -> rec (a:zs) - Nothing -> x:rec (y:zs) - rec xs = xs - ------------------------------------------------------------- --- Fixpoint of a bottom-up traversal - -cleanUpBU :: Expr -> Expr -cleanUpBU = {- fixpoint $ -} transform $ \e -> - simplify myView $ - fromMaybe (smart e) $ - canonical rationalView e - `mplus` do - a <- canonical specialSqrtOrder e - -- Just simplify order of terms with square roots for now - return (transform smart a) - `mplus` do - xs <- match sumView e - guard (length xs > 1) - return $ build sumView $ - assocPlus myView xs - `mplus` - canonical myView e - `mplus` do - (b, xs) <- match productView e - guard (length xs > 1) - return $ build productView - (b, assocTimes myView xs) - where - myView = powerFactorViewWith rationalView - -specialSqrtOrder :: View Expr [Expr] -specialSqrtOrder = sumView >>> makeView f id - where - make = match (squareRootViewWith rationalView) - g = isNothing . fromSquareRoot . snd - f xs = do - ys <- mapM make xs - return $ map fst $ sortBy (comparing g) $ zip xs ys - -smart :: Expr -> Expr -smart (a :*: b) = a .*. b -smart (a :/: b) = a ./. b -smart expr@(Sym s [x, y]) - | isPowerSymbol s = x .^. y - | isRootSymbol s = fromMaybe expr $ - liftM2 simplerRoot (match rationalView x) (match integerView y) -smart (Negate a) = neg a -smart (a :+: b) = a .+. b -smart (a :-: b) = a .-. b -smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2 --- smart (Sqrt a) = maybe (Sqrt a) (`simplerRoot` 2) (match rationalView a) -smart e = e - - ------------------------------------------------------------- --- Testing - -{- --- List with hard cases -hardCases = map cleanUpExpr $ let x=Var "x" in - [ -1/2*x*(x/1) - , (x/(-3)) - , (x/(-3))^2 - , (0-x)*(-x)/(-5/2) - , (x/(-1))^2 - , (x/(-1))^2-(-7/2)*x/(-1) - , (x^2+0)*3 - , -(49/9*x^2+0^2)*(3/16) - , (0*x-(-x^2))*(-3) - , x^2 - x^2 - , x^2-x^2-(x+x)*1 - , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1 - , (-7+7*x)^2-(x*0)^2/(-3) - , 1*(x+93)+4 - , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9 - ] -} 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,322 +1,277 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.Equivalence - ( linEq, quadrEqContext, highEqContext, simLogic, flipGT - , eqAfterSubstitution - ) where - -import Common.Classes -import Common.Context -import Common.Rewriting -import Common.Uniplate -import Common.View -import Control.Monad -import Data.List (sort, nub) -import Data.Maybe -import Data.Ord -import Domain.Logic.Formula hiding (Var, disjunctions) -import Domain.Math.Clipboard -import Domain.Math.Data.Interval -import Domain.Math.Data.Polynomial hiding (eval) -import Domain.Math.Data.Relation hiding (eval) -import Domain.Math.Data.SquareRoot -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Views -import Domain.Math.SquareRoot.Views -import Prelude hiding ((^), sqrt) -import qualified Domain.Logic.Formula as Logic - -relationIntervals :: Ord a => RelationType -> a -> Intervals a -relationIntervals relType a = - case relType of - EqualTo -> only singleton a - NotEqualTo -> except a - LessThan -> only lessThan a - GreaterThan -> only greaterThan a - LessThanOrEqualTo -> only lessThanOrEqualTo a - GreaterThanOrEqualTo -> only greaterThanOrEqualTo a - Approximately -> only singleton a -- i.e., equalTo - where - only f = fromList . return . f - -logicIntervals :: Ord a => Logic (Intervals a) -> Intervals a -logicIntervals = foldLogic - ( id - , \p q -> complement p `union` q -- p->q = ~p||q - , \p q -> (p `intersect` q) `union` (complement p `intersect` complement q) -- p<->q = (p&&q)||(~p&&~q) - , intersect - , union - , complement - , fromList [unbounded] - , fromList [empty] - ) - ------------------------------------------------------------ - -linEq :: Relation Expr -> Relation Expr -> Bool -linEq a b = fromMaybe False $ liftM2 (==) (linRel a) (linRel b) - -linRel :: Relation Expr -> Maybe (String, Intervals Rational) -linRel = linRelWith rationalView - -linRelWith :: (Ord a, Fractional a) - => View Expr a -> Relation Expr -> Maybe (String, Intervals a) -linRelWith v rel = - case match (linearViewWith v) (lhs - rhs) of - Nothing -> - case match (polyViewWith v) (lhs - rhs) of - Just (s, p) | degree p == 0 -> - case compare (coefficient 0 p) 0 of - LT | relationType rel `elem` [LessThan, LessThanOrEqualTo] -> - return (s, fromList [unbounded]) - | otherwise -> - return (s, fromList [empty]) - EQ | relationType rel `elem` [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo] -> - return (s, fromList [unbounded]) - | otherwise -> - return (s, fromList [empty]) - GT | relationType rel `elem` [GreaterThan, GreaterThanOrEqualTo] -> - return (s, fromList [unbounded]) - | otherwise -> - return (s, fromList [empty]) - _ -> Nothing - Just (s, a, b) - | a==0 -> - return (s, fromList [ unbounded | b==0 ]) - | otherwise -> do - let zero = -b/a - tp = relationType $ (if a<0 then flipSides else id) rel - return (s, relationIntervals tp zero) - where - lhs = leftHandSide rel - rhs = rightHandSide rel - -newtype Q = Q (SquareRoot Rational) deriving (Show, Eq, Num, Fractional) - --- Use normal (numeric) ordering on square roots -instance Ord Q where - Q a `compare` Q b = comparing f a b - where - f :: SquareRoot Rational -> Double - f = eval . fmap fromRational - -qView :: View (SquareRoot Rational) Q -qView = makeView (return . Q) (\(Q a) -> a) - -quadrEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool -quadrEqContext = eqContextWith (polyEq quadrRel) - -highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool -highEqContext = eqContextWith (polyEq highRel) - -eqContextWith :: (Logic (Relation Expr) -> Logic (Relation Expr) -> Bool) - -> Context (Logic (Relation Expr)) - -> Context (Logic (Relation Expr)) - -> Bool -eqContextWith eq a b = isJust $ do - termA <- fromContext a - termB <- fromContext b - guard $ - case (ineqOnClipboard a, ineqOnClipboard b) of - (Just x, Just y) -> eq x y && eq termA termB - (Just x, Nothing) -> eq (fmap toEq x) termA && eq x termB - (Nothing, Just y) -> eq (fmap toEq y) termB && eq termA y - (Nothing, Nothing) -> eq termA termB - where - toEq :: Relation Expr -> Relation Expr - toEq r = leftHandSide r .==. rightHandSide r - -ineqOnClipboard :: Context a -> Maybe (Logic (Relation Expr)) -ineqOnClipboard = evalCM $ const $ do - expr <- lookupClipboard "ineq" - fromExpr expr - -polyEq :: (Relation Expr -> Maybe (String, Intervals Q)) -> Logic (Relation Expr) -> Logic (Relation Expr) -> Bool -polyEq f p q = fromMaybe False $ do - xs <- switch (fmap f p) - ys <- switch (fmap f q) - let vs = map fst (crush xs ++ crush ys) - guard (null vs || all (==head vs) vs) - let ix = logicIntervals (fmap snd xs) - iy = logicIntervals (fmap snd ys) - if ix == iy then return True else return False - -cuPlus :: Relation Expr -> Maybe (Relation Expr) -cuPlus rel = do - (a, b) <- match plusView (leftHandSide rel) - guard (hasNoVar b && hasNoVar (rightHandSide rel)) - return $ constructor rel a (rightHandSide rel - b) - `mplus` do - (a, b) <- match plusView (leftHandSide rel) - guard (hasNoVar a && hasNoVar (rightHandSide rel)) - return $ constructor rel b (rightHandSide rel - a) - `mplus` do - a <- isNegate (leftHandSide rel) - return $ constructor (flipSides rel) a (-rightHandSide rel) - -cuTimes :: Relation Expr -> Maybe (Relation Expr) -cuTimes rel = do - (a, b) <- match timesView (leftHandSide rel) - r1 <- match rationalView a - r2 <- match rationalView (rightHandSide rel) - guard (r1 /= 0) - let make = if r1>0 then constructor rel else constructor (flipSides rel) - new = make b (build rationalView (r2/r1)) - return new - -cuPower :: Relation Expr -> Maybe (Logic (Relation Expr)) -cuPower rel = do - (a, b) <- isBinary powerSymbol (leftHandSide rel) - n <- match integerView b - guard (n > 0 && hasNoVar (rightHandSide rel)) - let expr = cleanUpExpr (root (rightHandSide rel) (fromIntegral n)) - new = constructor rel a expr - opp = constructor (flipSides rel) a (-expr) - rt = relationType rel - return $ if odd n - then Logic.Var new - else if rt `elem` [LessThan, LessThanOrEqualTo] - then Logic.Var new :&&: Logic.Var opp - else Logic.Var new :||: Logic.Var opp - -highRel2 :: Logic (Relation Expr) -> Maybe (String, Intervals Q) -highRel2 p = do - xs <- switch (fmap highRel p) - let vs = map fst (crush xs) - guard (null vs || all (==head vs) vs) - return (head vs, logicIntervals (fmap snd xs)) - -highRel :: Relation Expr -> Maybe (String, Intervals Q) -highRel rel = msum - [ cuTimes rel >>= highRel - , cuPower rel >>= highRel2 - , cuPlus rel >>= highRel - , quadrRel rel - ] - -quadrRel :: Relation Expr -> Maybe (String, Intervals Q) -quadrRel rel = - case match (quadraticViewWith rationalView) (lhs - rhs) of - Nothing -> - linRelWith (squareRootViewWith rationalView >>> qView) rel - Just (s, xa, xb, xc) -> do - let (tp, a, b, c) - | xa<0 = - (relationType (flipSides rel), -xa, -xb, -xc) - | otherwise = - (relationType rel, xa, xb, xc) - discr = b*b - 4*a*c - pa = Q ((-fromRational b-sqrtRational discr) / (2 * fromRational a)) - pb = Q ((-fromRational b+sqrtRational discr) / (2 * fromRational a)) - guard (a/=0) - (\is -> Just (s, is)) $ - case compare discr 0 of - LT | tp `elem` [NotEqualTo, GreaterThan, GreaterThanOrEqualTo] -> - fromList [unbounded] - | tp `elem` [EqualTo, Approximately, LessThan, LessThanOrEqualTo] -> - fromList [empty] - EQ | tp `elem` [EqualTo, Approximately, LessThanOrEqualTo] -> - fromList [singleton pa] - | tp == NotEqualTo -> - except pa - | tp == LessThan -> - fromList [empty] - | tp == GreaterThan -> - except pa - | tp == GreaterThanOrEqualTo -> - fromList [unbounded] - GT | tp `elem` [EqualTo, Approximately] -> - fromList [singleton pa, singleton pb] - | tp == NotEqualTo -> - except pa `intersect` except pb - | tp == LessThan -> - fromList [open pa pb] - | tp == LessThanOrEqualTo -> - fromList [closed pa pb] - | tp == GreaterThan -> - fromList [lessThan pa, greaterThan pb] - | tp == GreaterThanOrEqualTo -> - fromList [lessThanOrEqualTo pa, greaterThanOrEqualTo pb] - _ -> error "unknown case in quadrRel" - where - lhs = leftHandSide rel - rhs = rightHandSide rel - -flipGT :: Relation a -> Relation a -flipGT r - | relationType r == GreaterThan = - rightHandSide r .<. leftHandSide r - | relationType r == GreaterThanOrEqualTo = - rightHandSide r .<=. leftHandSide r - | otherwise = r - --- for similarity -simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool -simLogic f p0 q0 = rec (fmap f p0) (fmap f q0) - where - rec a b - | isOr a = - let collect = nub . sort . trueOr . collectOr - in recList (collect a) (collect b) - | isAnd a = - let collect = nub . sort . falseAnd . collectAnd - in recList (collect a) (collect b) - | otherwise = - shallowEq a b && recList (children a) (children b) - - recList xs ys = - length xs == length ys && and (zipWith rec xs ys) - - collectOr (p :||: q) = collectOr p ++ collectOr q - collectOr F = [] - collectOr a = [a] - - trueOr xs = if T `elem` xs then [] else xs - - collectAnd (p :&&: q) = collectAnd p ++ collectAnd q - collectAnd T = [] - collectAnd a = [a] - - falseAnd xs = if F `elem` xs then [] else xs - - shallowEq a b = - let g = descend (const T) - in g a == g b - - isOr (_ :||: _) = True - isOr _ = False - - isAnd (_ :||: _) = True - isAnd _ = False - - -eqAfterSubstitution :: (Functor f, Functor g) - => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool -eqAfterSubstitution eq ca cb = fromMaybe False $ do - a <- fromContext ca - b <- fromContext cb - let f = maybe id (fmap . fmap . substitute) . substOnClipboard - return (f ca a `eq` f cb b) - -substitute :: (String, Expr) -> Expr -> Expr -substitute (s, a) (Var b) | s==b = a -substitute pair expr = descend (substitute pair) expr - -substOnClipboard :: Context a -> Maybe (String, Expr) -substOnClipboard = evalCM $ const $ do - eq <- lookupClipboardG "subst" - case eq of - Var s :==: a -> return (s, a) +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Equivalence + ( linEq, quadrEqContext, highEqContext, simLogic, flipGT + , eqAfterSubstitution, intervalRelations + ) where + +import Common.Algebra.Boolean +import Common.Context +import Common.Rewriting +import Common.Utils.Uniplate +import Common.View +import Control.Monad +import Data.Maybe +import Data.Ord +import Domain.Logic.Formula hiding (Var) +import Domain.Math.CleanUp +import Domain.Math.Data.Interval +import Domain.Math.Data.Polynomial hiding (eval) +import Domain.Math.Data.Relation hiding (eval) +import Domain.Math.Data.SquareRoot +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Views +import Domain.Math.SquareRoot.Views +import Prelude hiding ((^), sqrt) +import qualified Data.Traversable as T +import qualified Domain.Logic.Formula as Logic +import qualified Domain.Logic.Generator as Logic + +relationInterval :: Ord a => RelationType -> a -> Interval a +relationInterval relType = + case relType of + EqualTo -> point + NotEqualTo -> except + LessThan -> lessThan + GreaterThan -> greaterThan + LessThanOrEqualTo -> lessThanOrEqualTo + GreaterThanOrEqualTo -> greaterThanOrEqualTo + Approximately -> point -- i.e., equalTo + +intervalRelations :: Eq a => a -> Interval a -> Logic (Relation a) +intervalRelations v = ors . map (ands . map Logic.Var . make) . segments + where + make pair = + case pair of + (Unbounded, Unbounded) -> [] + (Unbounded, Including b) -> [v .<=. b] + (Unbounded, Excluding b) -> [v .<. b] + (Including a, Unbounded) -> [v .>=. a] + (Excluding a, Unbounded) -> [v .>. a] + (Including a, Including b) + | a == b -> [v .==. a] + | otherwise -> [v .>=. a, v .<=. b] + (Including a, Excluding b) -> [v .>=. a, v .<. b] + (Excluding a, Including b) -> [v .>. a, v .<=. b] + (Excluding a, Excluding b) -> [v .>. a, v .<. b] + +logicInterval :: Ord a => Logic (Interval a) -> Interval a +logicInterval = + foldLogic (id, implies, equivalent, intersect, union, complement, true, false) + +----------------------------------------------------------- + +linEq :: Relation Expr -> Relation Expr -> Bool +linEq a b = fromMaybe False $ liftM2 (==) (linRel a) (linRel b) + +linRel :: Relation Expr -> Maybe (String, Interval Rational) +linRel = linRelWith rationalView + +linRelWith :: (Ord a, Fractional a) + => View Expr a -> Relation Expr -> Maybe (String, Interval a) +linRelWith v rel = + case match (linearViewWith v) (lhs - rhs) of + Nothing -> do + (s, p) <- match (polyViewWith v) (lhs - rhs) + guard (degree p == 0) + let list = case compare (coefficient 0 p) 0 of + LT -> [LessThan, LessThanOrEqualTo] + EQ -> [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo] + GT -> [GreaterThan, GreaterThanOrEqualTo] + return (s, fromBool $ relationType rel `elem` list) + Just (s, a, b) + | a==0 -> + return (s, fromBool (b==0)) + | otherwise -> do + let zero = -b/a + tp = relationType $ (if a<0 then flipSides else id) rel + return (s, relationInterval tp zero) + where + lhs = leftHandSide rel + rhs = rightHandSide rel + +newtype Q = Q (SquareRoot Rational) deriving (Show, Eq, Num, Fractional) + +-- Use normal (numeric) ordering on square roots +instance Ord Q where + Q a `compare` Q b = comparing f a b + where + f :: SquareRoot Rational -> Double + f = eval . fmap fromRational + +qView :: View (SquareRoot Rational) Q +qView = makeView (return . Q) (\(Q a) -> a) + +quadrEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool +quadrEqContext = eqContextWith (polyEq quadrRel) + +highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool +highEqContext = eqContextWith (polyEq highRel) + +eqContextWith :: (Logic (Relation Expr) -> Logic (Relation Expr) -> Bool) + -> Context (Logic (Relation Expr)) + -> Context (Logic (Relation Expr)) + -> Bool +eqContextWith eq a b = isJust $ do + termA <- fromContext a + termB <- fromContext b + guard $ + case (ineqOnClipboard a, ineqOnClipboard b) of + (Just x, Just y) -> eq x y && eq termA termB + (Just x, Nothing) -> eq (fmap toEq x) termA && eq x termB + (Nothing, Just y) -> eq (fmap toEq y) termB && eq termA y + (Nothing, Nothing) -> eq termA termB + where + toEq :: Relation Expr -> Relation Expr + toEq r = leftHandSide r .==. rightHandSide r + +ineqOnClipboard :: Context a -> Maybe (Logic (Relation Expr)) +ineqOnClipboard = evalCM $ const $ do + expr <- lookupClipboard "ineq" + fromExpr expr + +polyEq :: (Relation Expr -> Maybe (String, Interval Q)) -> Logic (Relation Expr) -> Logic (Relation Expr) -> Bool +polyEq f p q = fromMaybe False $ do + xs <- T.mapM f p + ys <- T.mapM f q + let vs = map fst (varsLogic xs ++ varsLogic ys) + guard (null vs || all (==head vs) vs) + let ix = logicInterval (fmap snd xs) + iy = logicInterval (fmap snd ys) + if ix == iy then return True else return False + +cuPlus :: Relation Expr -> Maybe (Relation Expr) +cuPlus rel = do + (a, b) <- match plusView (leftHandSide rel) + guard (hasNoVar b && hasNoVar (rightHandSide rel)) + return $ constructor rel a (rightHandSide rel - b) + `mplus` do + (a, b) <- match plusView (leftHandSide rel) + guard (hasNoVar a && hasNoVar (rightHandSide rel)) + return $ constructor rel b (rightHandSide rel - a) + `mplus` do + a <- isNegate (leftHandSide rel) + return $ constructor (flipSides rel) a (-rightHandSide rel) + +cuTimes :: Relation Expr -> Maybe (Relation Expr) +cuTimes rel = do + (a, b) <- match timesView (leftHandSide rel) + r1 <- match rationalView a + r2 <- match rationalView (rightHandSide rel) + guard (r1 /= 0) + let make = if r1>0 then constructor rel else constructor (flipSides rel) + new = make b (build rationalView (r2/r1)) + return new + +cuPower :: Relation Expr -> Maybe (Logic (Relation Expr)) +cuPower rel = do + (a, b) <- isBinary powerSymbol (leftHandSide rel) + n <- match integerView b + guard (n > 0 && hasNoVar (rightHandSide rel)) + let expr = cleanUpExpr (root (rightHandSide rel) (fromIntegral n)) + new = constructor rel a expr + opp = constructor (flipSides rel) a (-expr) + rt = relationType rel + return $ if odd n + then Logic.Var new + else if rt `elem` [LessThan, LessThanOrEqualTo] + then Logic.Var new :&&: Logic.Var opp + else Logic.Var new :||: Logic.Var opp + +highRel2 :: Logic (Relation Expr) -> Maybe (String, Interval Q) +highRel2 p = do + xs <- T.mapM highRel p + let vs = map fst (varsLogic xs) + guard (null vs || all (==head vs) vs) + return (head vs, logicInterval (fmap snd xs)) + +highRel :: Relation Expr -> Maybe (String, Interval Q) +highRel rel = msum + [ cuTimes rel >>= highRel + , cuPower rel >>= highRel2 + , cuPlus rel >>= highRel + , quadrRel rel + ] + +quadrRel :: Relation Expr -> Maybe (String, Interval Q) +quadrRel rel = + case match (quadraticViewWith rationalView) (lhs - rhs) of + Nothing -> + linRelWith (squareRootViewWith rationalView >>> qView) rel + Just (s, xa, xb, xc) -> do + let (tp, a, b, c) + | xa<0 = + (relationType (flipSides rel), -xa, -xb, -xc) + | otherwise = + (relationType rel, xa, xb, xc) + discr = b*b - 4*a*c + pa = Q ((-fromRational b-sqrtRational discr) / (2 * fromRational a)) + pb = Q ((-fromRational b+sqrtRational discr) / (2 * fromRational a)) + guard (a/=0) + (\is -> Just (s, is)) $ + case compare discr 0 of + LT -> fromBool $ tp `elem` [NotEqualTo, GreaterThan, GreaterThanOrEqualTo] + EQ | tp `elem` [EqualTo, Approximately, LessThanOrEqualTo] -> + point pa + | tp == NotEqualTo -> except pa + | tp == LessThan -> false + | tp == GreaterThan -> except pa + | tp == GreaterThanOrEqualTo -> true + GT | tp `elem` [EqualTo, Approximately] -> + point pa <||> point pb + | tp == NotEqualTo -> + except pa `intersect` except pb + | tp == LessThan -> + open pa pb + | tp == LessThanOrEqualTo -> + closed pa pb + | tp == GreaterThan -> + lessThan pa <||> greaterThan pb + | tp == GreaterThanOrEqualTo -> + lessThanOrEqualTo pa <||> greaterThanOrEqualTo pb + _ -> error "unknown case in quadrRel" + where + lhs = leftHandSide rel + rhs = rightHandSide rel + +flipGT :: Relation a -> Relation a +flipGT r + | relationType r == GreaterThan = + rightHandSide r .<. leftHandSide r + | relationType r == GreaterThanOrEqualTo = + rightHandSide r .<=. leftHandSide r + | otherwise = r + +-- for similarity +simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool +simLogic f p0 q0 = Logic.equalLogicACI (fmap f p0) (fmap f q0) + +eqAfterSubstitution :: (Functor f, Functor g) + => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool +eqAfterSubstitution eq ca cb = fromMaybe False $ do + a <- fromContext ca + b <- fromContext cb + let f = maybe id (fmap . fmap . substitute) . substOnClipboard + return (f ca a `eq` f cb b) + +substitute :: (String, Expr) -> Expr -> Expr +substitute (s, a) (Var b) | s==b = a +substitute pair expr = descend (substitute pair) expr + +substOnClipboard :: Context a -> Maybe (String, Expr) +substOnClipboard = evalCM $ const $ do + eq <- lookupClipboardG "subst" + case eq of + Var s :==: a -> return (s, a) _ -> fail "not a substitution" diff --git a/src/Domain/Math/Polynomial/Examples.hs b/src/Domain/Math/Polynomial/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Examples.hs @@ -0,0 +1,394 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Examples + ( linearExamples, quadraticExamples, higherDegreeExamples + , factorizeExamples, expandExamples + , ineqLin1, ineqQuad1, ineqQuad2, extraIneqQuad, ineqHigh + ) where + +import Common.Exercise +import Common.Rewriting +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Prelude hiding ((^)) + +x :: Expr +x = variable "x" + +linearExamples :: Examples (Equation Expr) +linearExamples = + level Easy -- applet level 1 + [ 5*x + 3 :==: 18 + , 11*x - 12 :==: 21 + , 19 - 3*x :==: -5 + , -12 + 5*x :==: 33 + , 15 - 9*x :==: 6 + , 4*x + 18 :==: 0 + , 11*x - 12 :==: -34 + , -2*x - 3 :==: -4 + , 6*x - 12 :==: 2 + , -4*x - 13 :==: -11 + ] ++ + level Easy -- applet level 2 + [ 6*x-2 :==: 2*x+14 + , 3+6*x :==: 3*x+24 + , 5*x+7 :==: 2*x - 10 + , 2*x-8 :==: 18 - x + , 4*x - 6 :==: 7*x - 14 + , -1 -5*x :==: 3*x - 20 + , 4*x - 7 :==: -5*x - 24 + , 4*x - 18 :==: 14 + 11*x + , 17 :==: 4 - 10*x + , -5*x + 6 :==: 2 - 3*x + ] ++ + level Medium -- applet level 3 + [ 4*(x-1) :==: 11*x - 12 + , 4*(x-4) :==: 5*(2*x+1) + , 2*(5-3*x) :==: 6-x + , 4*x - (x-2) :==: 12 + 5*(x-1) + , -3*(x-2) :==: 3*(x+4) - 7 + , 3*(4*x-1) + 3 :==: 7*x - 14 + , 4*(4*x - 1) - 2 :==: -3*x + 3*(2*x -5) + , 2*x - (3*x + 5) :==: 10 + 5*(x-1) + , -5*(x+1) :==: 9*(x+4)-5 + , 18 - 2*(4*x + 2) :==: 7*x - 4*(4*x -2) + ] ++ + level Medium -- applet level 4 + [ (1/2)*x - 4 :==: 2*x + mixed 2 1 2 + , (1/4)*x + (1/2) :==: (5/2)*x + 2 + , (1/4)*x - (3/4) :==: 2*x + (1/2) + , -(1/2)*x + (3/4) :==: (5/2)*x + 3 + , -(1/2)*x + mixed 1 1 2 :==: 2*x - 5 + , -(1/3)*x + (3/4) :==: (1/4)*x + (1/6) + , (3/4)*x - (1/3) :==: (2/3)*x - (3/4) + , (2/5)*x - (1/4) :==: (1/2)*x + (3/4) + , (2/3)*x - 2 :==: (1/5)*x - (3/5) + , (-mixed 1 2 5)*x + mixed 3 1 2 :==: (3/5)*x + (9/10) + ] ++ + level Medium -- applet level 4 + [ (1/4)*(x-3) :==: (1/2)*x - 4 + , (x+3)/2 :==: 5*((1/2)*x + mixed 1 1 2) + , (1/2)*(7-(2/3)*x) :==: 2 + (1/9)*x + , (3/4)*x - (x-1) :==: 3 + mixed 2 1 2*(x-1) + , -(5/4)*(x-7) :==: (3/4)*(x+2) - mixed 4 1 2 + , 3*((1/5)*x - 1) + 5 :==: 7*x - 14 + , ((5*x - 1) / 6) - 2 :==: -4*x + (3*x - 6)/2 + , 2*x - ((2*x+2)/5) :==: 12 + (x-1)/6 + , (-3*(x+2))/6 :==: 9*((2/3)*x + (1/3)) - (5/3) + , 1 - ((4*x + 2)/3) :==: 3*x - ((5*x - 1) / 4) + ] + +quadraticExamples :: Examples (Equation Expr) +quadraticExamples = + level Easy -- applet level 1 + [ x^2 :==: 2 + , x^2+3 :==: 52 + , x^2-7 :==: 0 + , 9*x^2 - 6 :==: 75 + , 32 - 2*x^2 :==: 14 + , 2*(x^2 - 3) :==: 12 + , (1/4)*x^2 + 12 :==: 16 + , (x-1)^2 :==: 100 + , 14 - 2*x^2 :==: 6 + , (1/4)*(17-x^2) :==: 2 + ] ++ + level Medium -- applet level 2 + [ (x-7)^2 + 3 :==: 11 + , (6-2*x)^2 :==: 81 + , (1/2)*(x+9)^2 :==: 4 + , (3-x^2)/10 :==: 2 + , 5*x^2 + 3*x :==: 3*x + 2 + , 11 - (2*x + 1)^2 :==: 5 + , (6*x - 3)^2 + 6 :==: 12 + , (7+2*x)^2 :==: 7 + , 4 - (x^2 / 10) :==: 6 + , 12 - (2*x + 3)^2 :==: 6 + ] ++ + level Medium -- applet level 3 + [ x^2 :==: 5*x + , x^2 - 6*x :==: 0 + , 6*x + x^2 :==: 0 + , x*(x+4) :==: 0 + , x*(2*x-4) :==: 0 + , 3*x^2 :==: 6*x + , 3*x :==: 2*x^2 + , x*(1-6*x) :==: 0 + , (x+5)*(x-8) :==: 0 + , (3*x-1)*(x+3) :==: 0 + ] ++ + level Medium -- applet level 4 + [ x^2-2*x :==: 3 + , x^2+12*x+20 :==: 0 + , x^2-x :==: 30 + , x*(x+2) :==: 8 + , x*(x-3) :==: 4 + , 2*x+15 :==: x^2 + , 4*x :==: 12 - x^2 + , x^2 :==: 15 - 8*x + , x^2-9*x+18 :==: 0 + , x^2+14*x+24 :==: 0 + ] ++ + level Difficult -- applet level 5 + [ (3*x+5)^2+(x-5)^2 :==: 40 + , 4*(10-x^2) :==: -2*x*(2*x + 10) + , x*(x+12) :==: 2*x^2 + , 3*(x-2)*(x+6) :==: 12*x + , 8*x^2+4*x-24 :==: (x+3)*(x-8) + , 3*x^2 - 11 :==: (3+2*x)^2 + , 2*x*(x-3)-3 :==: (x+2)*(x+6) + , 12*(x^2-3*x)+8 :==: 56 + , 4*x^2-6*x :==: x^2+9 + , (x+1)*(x-5) :==: (x-2)*(x-3) + ] ++ + level Difficult -- applet level 6 + [ x^2+4*x-4 :==: 0 + , x^2-6*x :==: 4 + , x^2-12*x+34 :==: 0 + , 2*x^2+4*x-8 :==: 0 + , (x-4)*(x-1) :==: 11 + , (x-(7/2))^2 :==: 2*(x+4) + , x^2-3*x :==: 3*(x-2) + , (4-x)*(1-x) :==: 3*x + , 2*x^2 :==: x*(x+2)+7 + , (1-x)^2 :==: x+2 + ] + +factorizeExamples :: Examples Expr +factorizeExamples = + level Easy + [ -- (buiten haakjes brengen) + 4*x^2 -4*x + , 36*x^2+30*x + , -6*x^2-18*x + , 14*x^2-10*x + --(product-som methode) + , x^2+11*x+24 + , x^2-8*x+15 + , x^2-x-2 + , x^2-11*x+28 + ] + +expandExamples :: Examples Expr +expandExamples = level Easy + [ 5*(x+1), -3*(x-3), (x-1)*7 + , 4*(3-2*x), (x+1)*(x-3), (x+1)*(1-x) + , x*(x-1), 3*(x-2)*2*x + , (x-1)^2, (x+1)^2, (x-1)^2*(x+1) + , (x+1)^3, (x-1)^3*x, (x-1)*(x+3)*(x-5) + , x/2, (x+1)/2, (x+1)/2 + (x+2)/3, ((x+1)/2) * ((x+2)/3) + ] + +-------------------------------------------------------------------- +-- Algemene applet + +higherDegreeExamples :: Examples (Equation Expr) +higherDegreeExamples = + -- Havo B hoofdstuk 3, Hogeregraadsvgl. + level Easy + [ -- level 1 + (1/3)*x^3 :==: 9 + , x^5 - 12 :==: 20 + , 1 - 8*x^3 :==: -124 + , 16 - 32*x^5 :==: - 227 + -- level 2 + , 3*x^4 :==: 48 + , (1/9)*x^6 + 12 :==: 93 + , 39 - 8*x^2 :==: 21 + , (1/2)*x^4 - 13 :==: 27.5 + -- level 3 + , 3*(2*x-1)^3 + 11 :==: 659 + , 0.5*(3*x-4)^5 + 7 :==: 23 + , 2*(0.5*x+3)^7 - 11 :==: -9 + , 5*(1-4*x)^3 + 4 :==: -621 + -- level 4 + , 3*(2*x + 5)^2 + 9 :==: 21 + , 2*(3*x-6)^6 - 24 :==: -22 + , -2*(4*x-5)^4 + 192 :==: -8000 + , (3-2*x)^4 + 23 :==: 279 + ] ++ + level Easy + [ -- level 1 + 2*x^3 + 9 :==: 19 + , 4*x^5 - 17 :==: 27 + , 3*x^7 + 9 :==: 62 + , 5*x^3 - 1 :==: 9 + , 6 - 5*x^3 :==: 76 + , 11 - 7*x^5 :==: 53 + , 4 - 0.2*x^7 :==: 9 + , 18 - 11*x^7 :==: 62 + -- level 2 + , 0.5*x^4 + 5 :==: 12 + , 5*x^6 - 37 :==: 68 + , 4*x^8 - 19 :==: 9 + , 5*x^6 + 7 :==: 97 + , 18 - 7*x^4 :==: -38 + , 3 + (1/3)*x^6 :==: 7 + , 1 - (1/9)*x^8 :==: -4 + , 47 + 15*x^8 :==: 77 + -- level 3 + , 18*x^8 - 11 :==: 7 + , (1/4)*x^6 + 14 :==: 30 + , 5*x^4 + 67 :==: 472 + , 5*x^4 - 1 :==: 4 + , (1/8)*x^7 + 24 :==: 40 + , 0.2*x^3 + 27 :==: 52 + , 32*x^3 + 18 :==: 22 + , 4*x^3 - 8 :==: 100 + -- level 4 + , 14 -2*x^3 :==: 700 + , 4-3*x^5 :==: 100 + , 14 - 11*x^7 :==: 25 + , 1 - 3*x^5 :==: 97 + , 3*(x-2)^4 + 7 :==: 37 + , 6 - (2*x-1)^3 :==: 1 + , (1/3)*(x+5)^6 - 4 :==: 3 + , 6 - 0.5*(x-1)^5 :==: 10 + -- level 5 + , (1/2)*(3*x-1)^4 :==: 8 + , 100-(1/3)*(4*x-3)^5 :==: 19 + , 4*(0.5*x+2)^6 + 5 :==: 9 + , 3*(2*x + 7)^3 + 11 :==: 35 + ] ++ + level Medium + -- (Ontbinden applet) + [ -- level 1 + x^3 - 5*x^2 + 4*x :==: 0 + , x^3 :==: 3*x^2 + 10*x + , 14*x :==: x^3 + 5*x^2 + , (1/2)*x^3 + 3*x^2 + 4*x :==: 0 + , x^3 + 6*x^2 + 9*x :==: 0 + , 5*x^2 :==: x^3 + 6*x + , x^3 - 5*x^2 :==: 6*x + , x^3 :==: 4*x^2 + 12*x + -- level 2 + , x^4 + 36 :==: 13*x^2 + , x^4 - 9*x^2 + 20 :==: 0 + , x^4 :==: 2*x^2 + 3 + , x^4 + 2*x^2 :==: 24 + , 7*x^2 + 18 :==: x^4 + , x^4 :==: x^2 + 12 + , 29*x^2 :==: x^4 + 100 + , 2*x^4 + 2*x^2 :==: 12 + -- (abc-form applet) + -- level 1 + , 4*x^4 + 4 :==: 17*x^2 + , 16*x^4 + 225 :==: 136*x^2 + , 2*x^4 - 15*x^2 + 25 :==: 0 + , 9*x^4 - 28*x^2 + 3 :==: 0 + , 3*x^4 - 14*x^2 - 5 :==: 0 + , 2*x^4 :==: x^2 + 3 + , 9*x^4 + 14*x^2 :==: 8 + , 4*x^4 - 29*x^2 - 24 :==: 0 + -- level 2 + , 8*x^6 - 9*x^3 + 1 :==: 0 + , 27*x^6 + 8 :==: 217*x^3 + , 2*x^6 + x^3 - 1 :==: 0 + , 8*x^6 + 31*x^3 :==: 4 + , 3*x^6 - 80*x^3 - 27 :==: 0 + , 5*x^6 :==: 39*x^3 + 8 + , 7*x^6 + 8*x^3 + 1 :==: 0 + , 4*x^6 + 2 :==: -9*x^3 + ] ++ + level Difficult + [ x^3 + x^2 :==: 0 + , x^3 - 5*x :==: 0 + , x^3 - 11*x^2 + 18*x :==: 0 + , x^3 + 36*x :==: 13*x^2 + , x^3 + 2*x^2 :==: 24*x + , 7*x^3 :==: 8*x^2 + , x^4 :==: 9*x^2 + , 64*x^7 :==: x^5 + , x^3 - 4*x^2 - 9*x :==: 0 + , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2 + ] + +-------------------------------------------------------------------- +-- Havo applets + +-- Havo B Voorkennis: lineaire ongelijkheden +ineqLin1 :: [[Inequality Expr]] +ineqLin1 = + let a = Var "a" in + [ [ 7*x - 12 :<: 5*x + 3 + , 4*(x-3) :>: 3*(x-4) + , 6*(a+1) :<: 3*(a-2)+4 + , 5 - 2*(a-3) :>: 5*(3-a) + ] + , [ 4*x+5 :<: 5*x - 3 + , (1/3)*x+10 :>: (1/2)*x + , 3*x+1 :<: 7*x + 5 + , x+6 :>: 2 - (3/4)*x + ] + , [ 5*(x-1) :<: 7*x - 1 + , -3*(4*x-1) :>: 2-(x-1) + , 2*(3*x-1) :<: 5-(2-9*x) + , 2*(x-1)-3*(x-2) :>: 6 + ] + ] + +-- Havo B Voorkennis: kwadratische ongelijkheden +-- (door eerst gelijkheid op te lossen) +-- (level 2 uit Hoofdstuk 3) +ineqQuad1 :: [[Inequality Expr]] +ineqQuad1 = + [ [ x^2 +3*x-4 :<: 0 + , x^2-4*x-12 :>: 0 + , -x^2 - 4*x + 5 :<: 0 + , -x^2 + 3*x + 18 :>: 0 + , (1/2)*x^2 - 3*x - 8 :<: 0 + , -2*x^2 + 10*x :>: 0 + ] + , [ x^2 + 9*x :<: 3*x - 5 + , x^2 - x :>: 12 + , x^2 - 4.5*x :<: 7-3*x + , 2*x^2 - 10*x :>: x^2 - 3*x + , 4*x^2 + 6*x :<: x^2 + 3*x + 18 + , 2*x^2 + 6*x - 10 :>: x^2 + 2*x - 5 + ] + ] + +-- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact +-- (door eerst gelijkheid op te lossen) +ineqHigh :: [Inequality Expr] +ineqHigh = + [ 2*x^3 :>: 54 + , -0.5*x^4 :<: -40.5 + , 1 - 2*x^5 :<: -485 + , (2*x-3)^4 :>: 1 + , -(0.5*x+2)^3 :<: -1 + , 0.25*(0.5*x-2)^4 :<: 4 + ] + +-------------------------------------------------------------------- +-- VWO A/C applets + +-- hoofdstuk 2 +ineqQuad2 :: [Inequality Expr] +ineqQuad2 = + [ x^2 + 9*x :<: 3*x - 5 + , x^2 - x :>: 12 + , x^2 - 4.5*x :<: 7 - 3*x + , 2*x^2 - 10*x :>: x^2 - 3*x + , 4*x^2 + 6*x :<: x^2 + 3*x + 18 + , 2*x^2 + 6*x - 10 :>: x^2 +2*x - 5 + ] + +-------------------------------------------------------------------- +-- Extra test cases + +extraIneqQuad :: [Inequality Expr] +extraIneqQuad = + [ x^2-x-7 :>: -100, x^2-x-7 :<: -100, x^2 :<: x^2, x :>=: x + , x^2 :>=: 0, x^2 :>: 0, x^2 :<: 0, x^2 :<=: 0 + ] diff --git a/src/Domain/Math/Polynomial/Exercises.hs b/src/Domain/Math/Polynomial/Exercises.hs --- a/src/Domain/Math/Polynomial/Exercises.hs +++ b/src/Domain/Math/Polynomial/Exercises.hs @@ -1,237 +1,220 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.Exercises where - -import Domain.Math.Approximation -import Common.Context -import Common.Exercise -import Common.Rewriting -import Common.Strategy -import Common.Classes -import Common.Uniplate -import Common.View -import Data.Maybe -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Equation.Views -import Domain.Math.Examples.DWO1 -import Domain.Math.Examples.DWO2 -import Domain.Math.Expr -import Domain.Math.Polynomial.BuggyRules -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.Strategies -import Domain.Math.Polynomial.Views -import Domain.Math.Polynomial.Equivalence -import Domain.Math.Numeric.Views -import Domain.Math.Equation.CoverUpRules -import Control.Monad - ------------------------------------------------------------- --- Exercises - -linearExercise :: Exercise (Equation Expr) -linearExercise = makeExercise - { exerciseId = describe "solve a linear equation" $ - newId "algebra.equations.linear" - , status = Provisional - , parser = parseExprWith (pEquation pExpr) - , similarity = eqRelation (acExpr . cleanUpExpr) - , equivalence = viewEquivalent linearEquationView - , isSuitable = (`belongsTo` linearEquationView) - , isReady = solvedRelationWith $ \a -> - a `belongsTo` mixedFractionNormalForm || - a `belongsTo` rationalNormalForm - , extraRules = map use buggyRulesEquation ++ - map use buggyRulesExpr - , ruleOrdering = ruleOrderingWithId - [ getId coverUpTimes, getId flipEquation - , getId removeDivision - ] - , strategy = linearStrategy - , navigation = termNavigator - , examples = concat (linearEquations ++ [specialCases]) - } - where - specialCases = - let x = Var "x" - in [5 :==: x, 5 :==: x + 1, x - 1/5 :==: 2] - -linearMixedExercise :: Exercise (Equation Expr) -linearMixedExercise = linearExercise - { exerciseId = describe "solve a linear equation with mixed fractions" $ - newId "algebra.equations.linear.mixed" - , isReady = solvedRelationWith (`belongsTo` mixedFractionNormalForm) - , strategy = linearMixedStrategy - } - -quadraticExercise :: Exercise (OrList (Relation Expr)) -quadraticExercise = makeExercise - { exerciseId = describe "solve a quadratic equation" $ - newId "algebra.equations.quadratic" - , status = Provisional - , parser = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of - Left err -> Left err - Right xs -> Right (build (switchView equationView) xs) - , similarity = eqOrList cleanUpExpr - , equivalence = equivalentRelation (viewEquivalent quadraticEquationsView) - , isSuitable = (`belongsTo` (switchView equationView >>> quadraticEquationsView)) - , isReady = solvedRelations - , extraRules = map use abcBuggyRules ++ buggyQuadratic ++ - map use buggyRulesEquation ++ map use buggyRulesExpr - , ruleOrdering = ruleOrderingWithId $ - quadraticRuleOrder ++ [getId buggySquareMultiplication] - , strategy = quadraticStrategy - , navigation = termNavigator - , examples = map (orList . return . build equationView) (concat quadraticEquations) - } - -higherDegreeExercise :: Exercise (OrList (Relation Expr)) -higherDegreeExercise = makeExercise - { exerciseId = describe "solve an equation (higher degree)" $ - newId "algebra.equations.polynomial" - , status = Provisional - , parser = parser quadraticExercise - , similarity = eqOrList cleanUpExpr - , eqWithContext = Just $ eqAfterSubstitution $ - equivalentRelation (viewEquivalent higherDegreeEquationsView) - , isSuitable = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView)) - , isReady = solvedRelations - , extraRules = map use abcBuggyRules ++ buggyQuadratic ++ - map use buggyRulesEquation ++ map use buggyRulesExpr - , ruleOrdering = ruleOrderingWithId quadraticRuleOrder - , strategy = higherDegreeStrategy - , navigation = termNavigator - , examples = map (orList . return . build equationView) - (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations]) - } - -quadraticNoABCExercise :: Exercise (OrList (Relation Expr)) -quadraticNoABCExercise = quadraticExercise - { exerciseId = describe "solve a quadratic equation without abc-formula" $ - newId "algebra.equations.quadratic.no-abc" - , status = Alpha - , strategy = configure cfg quadraticStrategy - } - where - cfg = [ (byName prepareSplitSquare, Reinsert) - , (byName bringAToOne, Reinsert) - , (byName (newId "abc form"), Remove) - , (byName simplerPolynomial, Remove) - ] - -quadraticWithApproximation :: Exercise (OrList (Relation Expr)) -quadraticWithApproximation = quadraticExercise - { exerciseId = describe "solve a quadratic equation with approximation" $ - newId "algebra.equations.quadratic.approximate" - , status = Alpha - , parser = parseExprWith (pOrList (pRelation pExpr)) - , strategy = configure cfg quadraticStrategy - , equivalence = equivalentApprox - } - where - cfg = [ (byName (newId "approximate result"), Reinsert) - , (byName (newId "square root simplification"), Remove) - ] - -findFactorsExercise :: Exercise Expr -findFactorsExercise = makeExercise - { exerciseId = describe "factorize the expression" $ - newId "algebra.manipulation.polynomial.factor" - , status = Provisional - , parser = parseExprWith pExpr - , similarity = \a b -> cleanUpExpr a == cleanUpExpr b - , equivalence = viewEquivalent (polyViewWith rationalView) - , isReady = (`belongsTo` linearFactorsView) - , strategy = findFactorsStrategy - , navigation = termNavigator - , extraRules = map liftToContext buggyRulesExpr - , examples = concat findFactors - } - -linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)]) -linearFactorsView = productView >>> second (listView myLinearView) - where - myLinearView :: View Expr (String, Expr, Expr) - myLinearView = makeView f (build linearView) - - f expr = do - triple@(_, e1, e2) <- match linearView expr - a <- match integerView e1 - b <- match integerView e2 - guard (a > 0 && gcd a b == 1) -- gcd 0 0 is undefined - return triple - `mplus` do - guard (expr `belongsTo` rationalView) - return ("x", 0, expr) - --------------------------------------------- --- Equality - -equivalentApprox :: OrList (Relation Expr) -> OrList (Relation Expr) -> Bool -equivalentApprox a b - | hasApprox a || hasApprox b = - let norm = liftM ( normOrList cleanUpExpr - . fmap toApprox - . simplify quadraticEquationsView - ) . switch . fmap toEq - in fromMaybe False $ liftM2 (==) (norm a) (norm b) - | otherwise = - equivalentRelation (viewEquivalent quadraticEquationsView) a b - where - hasApprox = maybe False (any isApproximately) . disjunctions - isApproximately = (==Approximately) . relationType - toEq rel | relationType rel `elem` [EqualTo, Approximately] = - Just (leftHandSide rel :==: rightHandSide rel) - | otherwise = Nothing - -toApprox :: Equation Expr -> Relation Expr -toApprox (a :==: b) = f a .~=. f b - where - f x = maybe x (Number . precision 4) (match doubleView x) - - -equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool -equivalentRelation f ra rb = fromMaybe False $ do - a <- switch (fmap (match equationView) ra) - b <- switch (fmap (match equationView) rb) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Exercises + ( linearExercise, linearMixedExercise + , quadraticExercise, quadraticNoABCExercise + , quadraticWithApproximation + , higherDegreeExercise + , findFactorsExercise, expandExercise + ) where + +import Common.Library +import Control.Monad +import Data.Function +import Data.Maybe +import Domain.Math.Approximation +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Equation.Views +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.BuggyRules +import Domain.Math.Polynomial.Equivalence +import Domain.Math.Polynomial.Examples +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.Polynomial.Views +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +------------------------------------------------------------ +-- Exercises + +linearExercise :: Exercise (Equation Expr) +linearExercise = makeExercise + { exerciseId = describe "solve a linear equation" $ + newId "algebra.equations.linear" + , status = Stable + , parser = parseEqExpr + , similarity = withoutContext (viewEquivalent (traverseView cleanUpACView)) + , equivalence = withoutContext (viewEquivalent linearEquationView) + , suitable = predicateView linearEquationView + , ready = predicateView (equationSolvedWith mixedFractionNF) + <||> predicateView (equationSolvedWith rationalNF) + <||> predicateView (equationSolvedWith doubleNF) + , extraRules = map use buggyRulesEquation ++ + map use buggyRulesExpr + , ruleOrdering = ruleOrderingWithId + [ getId coverUpTimes, getId flipEquation + , getId removeDivision + ] + , strategy = linearStrategy + , navigation = termNavigator + , examples = linearExamples + } + +linearMixedExercise :: Exercise (Equation Expr) +linearMixedExercise = linearExercise + { exerciseId = describe "solve a linear equation with mixed fractions" $ + newId "algebra.equations.linear.mixed" + , status = Provisional + , ready = predicateView (equationSolvedWith mixedFractionNF) + , strategy = linearMixedStrategy + } + +quadraticExercise :: Exercise (OrList (Relation Expr)) +quadraticExercise = makeExercise + { exerciseId = describe "solve a quadratic equation" $ + newId "algebra.equations.quadratic" + , status = Stable + , parser = parseOrsEqExpr + >>> right (build (traverseView equationView)) + , similarity = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView))) + , equivalence = withoutContext (equivalentRelation (viewEquivalent quadraticEquationsView)) + , suitable = predicateView (traverseView equationView >>> quadraticEquationsView) + , ready = predicateView relationsSolvedForm + , extraRules = map use abcBuggyRules ++ buggyQuadratic ++ + map use buggyRulesEquation ++ map use buggyRulesExpr + , ruleOrdering = ruleOrderingWithId $ + quadraticRuleOrder ++ [getId buggySquareMultiplication] + , strategy = quadraticStrategy + , navigation = termNavigator + , examples = mapExamples (singleton . build equationView) quadraticExamples + } + +higherDegreeExercise :: Exercise (OrList (Relation Expr)) +higherDegreeExercise = makeExercise + { exerciseId = describe "solve an equation (higher degree)" $ + newId "algebra.equations.polynomial" + , status = Stable + , parser = parser quadraticExercise + , similarity = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView))) + , equivalence = eqAfterSubstitution $ + equivalentRelation (viewEquivalent higherDegreeEquationsView) + , suitable = predicateView (traverseView equationView >>> higherDegreeEquationsView) + , ready = predicateView relationsSolvedForm + , extraRules = map use abcBuggyRules ++ buggyQuadratic ++ + map use buggyRulesEquation ++ map use buggyRulesExpr + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , strategy = higherDegreeStrategy + , navigation = termNavigator + , examples = mapExamples (singleton . build equationView) higherDegreeExamples + } + +quadraticNoABCExercise :: Exercise (OrList (Relation Expr)) +quadraticNoABCExercise = quadraticExercise + { exerciseId = describe "solve a quadratic equation without abc-formula" $ + newId "algebra.equations.quadratic.no-abc" + , status = Provisional + , strategy = configure cfg quadraticStrategy + } + where + cfg = [ (byName prepareSplitSquare, Reinsert) + , (byName bringAToOne, Reinsert) + , (byName (newId "abc form"), Remove) + , (byName simplerPolynomial, Remove) + ] + +quadraticWithApproximation :: Exercise (OrList (Relation Expr)) +quadraticWithApproximation = quadraticExercise + { exerciseId = describe "solve a quadratic equation with approximation" $ + newId "algebra.equations.quadratic.approximate" + , status = Provisional + , parser = parseOrsRelExpr + , strategy = configure cfg quadraticStrategy + , equivalence = withoutContext equivalentApprox + } + where + cfg = [ (byName (newId "approximate result"), Reinsert) + , (byName (newId "square root simplification"), Remove) + ] + +findFactorsExercise :: Exercise Expr +findFactorsExercise = makeExercise + { exerciseId = describe "factorize the expression" $ + newId "algebra.manipulation.polynomial.factor" + , status = Provisional + , parser = parseExpr + , similarity = withoutContext ((==) `on` cleanUpExpr) + , equivalence = withoutContext (viewEquivalent (polyViewWith rationalView)) + , ready = predicateView linearFactorsView + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , strategy = findFactorsStrategy + , navigation = termNavigator + , extraRules = map liftToContext buggyRulesExpr + , examples = factorizeExamples + } + +expandExercise :: Exercise Expr +expandExercise = makeExercise + { exerciseId = describe "expand an expression to polynomial normal form" $ + newId "algebra.manipulation.polynomial.expand" + , status = Provisional + , parser = parseExpr + , similarity = withoutContext ((==) `on` cleanUpExpr) + , equivalence = withoutContext (viewEquivalent (polyViewWith rationalView)) + , ready = predicateView (polyNormalForm rationalView) + , ruleOrdering = ruleOrderingWithId (getId fractionProduct:quadraticRuleOrder) + , strategy = expandStrategy + , navigation = termNavigator + , extraRules = map liftToContext buggyRulesExpr + , examples = expandExamples + } + +linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)]) +linearFactorsView = toView productView >>> second (listView myLinearView) + where + myLinearView :: View Expr (String, Expr, Expr) + myLinearView = makeView f (build linearView) + + f expr = do + triple@(_, e1, e2) <- match linearView expr + a <- match integerView e1 + b <- match integerView e2 + guard (a > 0 && gcd a b == 1) -- gcd 0 0 is undefined + return triple + `mplus` do + guard (expr `belongsTo` rationalView) + return ("x", 0, expr) + +-------------------------------------------- +-- Equality + +equivalentApprox :: OrList (Relation Expr) -> OrList (Relation Expr) -> Bool +equivalentApprox a b + | hasApprox a || hasApprox b = + let norm = liftM ( simplify orSetView + . fmap (fmap (acExpr . cleanUpExpr) . toApprox) + . simplify quadraticEquationsView + ) . T.mapM toEq + in fromMaybe False $ liftM2 (==) (norm a) (norm b) + | otherwise = + equivalentRelation (viewEquivalent quadraticEquationsView) a b + where + hasApprox = F.any isApproximately + isApproximately = (==Approximately) . relationType + toEq rel | relationType rel `elem` [EqualTo, Approximately] = + Just (leftHandSide rel :==: rightHandSide rel) + | otherwise = Nothing + +toApprox :: Equation Expr -> Relation Expr +toApprox (a :==: b) = f a .~=. f b + where + f x = maybe x (fromDouble . precision 4) (match doubleView x) + +equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool +equivalentRelation f ra rb = fromMaybe False $ do + a <- T.mapM (match equationView) ra + b <- T.mapM (match equationView) rb return (f a b) - -eqOrList :: (Relational f, Ord (f Expr)) => - (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -> Bool -eqOrList f x y = normOrList f x == normOrList f y - -eqRelation :: (Relational f, Eq (f Expr)) => (Expr -> Expr) -> f Expr -> f Expr -> Bool -eqRelation f x y = fmap f x == fmap f y - --- Normalize the order of disjunctions. Simplify the expression with the function --- passed as argument, but do not change (flip) the sides of the relation. -normOrList :: (Relational f, Ord (f Expr)) => - (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -normOrList f = normalize . fmap (fmap (normExpr f)) - -normExpr :: (Expr -> Expr) -> Expr -> Expr -normExpr f = rec . f - where - plusOperator = makeCommutative $ monoid - (makeBinary (getId plusSymbol) (+) isPlus) - (simpleConstant "zero" 0) - timesOperator = makeCommutative $ monoid - (makeBinary (getId timesSymbol) (*) isTimes) - (simpleConstant "one" 1) - make = simplifyWith (map rec) . magmaListView - - rec expr = - case expr of - _ :+: _ -> make plusOperator expr - _ :*: _ -> make timesOperator expr - _ -> descend rec expr diff --git a/src/Domain/Math/Polynomial/Generators.hs b/src/Domain/Math/Polynomial/Generators.hs --- a/src/Domain/Math/Polynomial/Generators.hs +++ b/src/Domain/Math/Polynomial/Generators.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,16 +9,16 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.Math.Polynomial.Generators +module Domain.Math.Polynomial.Generators ( polynomialGen, polynomialDegreeGen - , cubicGen, quadraticGen, linearGen + , cubicGen, quadraticGen, linearGen ) where -import Prelude hiding ((^)) +import Control.Monad import Domain.Math.Expr import Domain.Math.Numeric.Generators +import Prelude hiding ((^)) import Test.QuickCheck -import Control.Monad polynomialGen :: Int -> Gen Expr polynomialGen n = do @@ -30,8 +30,8 @@ polynomialDegreeGen :: Int -> Int -> Gen Expr polynomialDegreeGen d n | d==0 = ratGen - | n==0 && d==1 = return (Var "x") - | n==0 = return (Var "x" ^ fromIntegral d) + | n==0 && d==1 = return (Var "x") + | n==0 = return (Var "x" ^ fromIntegral d) | otherwise = oneof $ [ timesGen, plusGen , liftM2 (:/:) (rec d) ratGenNZ @@ -42,17 +42,17 @@ d1 <- choose (0, d) a <- rec d1 b <- rec d - oneof $ map return [a :+: b, b :+: a, a :-: b, b :-: a, Negate b] + elements [a :+: b, b :+: a, a :-: b, b :-: a, Negate b] timesGen = do d1 <- choose (0, d) a <- rec d1 b <- rec (d-d1) return (a :*: b) powerGen = do - i <- oneof [ return i | i <- [2..d], d `mod` i == 0 ] + i <- elements [ i | i <- [2..d], d `mod` i == 0 ] a <- rec (d `div` i) return (a ^ fromIntegral i) - + cubicGen, quadraticGen, linearGen :: Int -> Gen Expr cubicGen = polynomialDegreeGen 3 quadraticGen = polynomialDegreeGen 2 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 @@ -1,336 +1,306 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.IneqExercises - ( ineqLinearExercise, ineqQuadraticExercise, ineqHigherDegreeExercise - ) where - -import Common.Context -import Common.Exercise -import Common.Rewriting -import Common.Strategy hiding (not) -import Common.Transformation -import Common.Uniplate (descend) -import Common.View -import Control.Monad -import Data.List (nub, sort) -import Data.Maybe (fromMaybe) -import Domain.Math.Data.Interval -import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic) -import Domain.Math.Clipboard -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) -import Domain.Math.Polynomial.Exercises (eqRelation, normExpr) -import Domain.Math.Equation.Views -import Domain.Math.Examples.DWO2 -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.Strategies -import Domain.Math.Polynomial.Equivalence -import Domain.Math.SquareRoot.Views -import Prelude hiding (repeat) -import qualified Domain.Logic.Formula as Logic -import qualified Domain.Logic.Views as Logic - -ineqLinearExercise :: Exercise (Relation Expr) -ineqLinearExercise = makeExercise - { exerciseId = describe "solve a linear inequation" $ - newId "algebra.inequalities.linear" - , status = Provisional - , parser = parseExprWith (pRelation pExpr) - , isReady = solvedRelation - , equivalence = linEq - , similarity = eqRelation cleanUpExpr - , strategy = ineqLinear - , navigation = termNavigator - , examples = let x = Var "x" - extra = (x-12) / (-2) :>: (x+3)/3 - in map (build inequalityView) (concat ineqLin1 ++ [extra]) - } - -ineqQuadraticExercise :: Exercise (Logic (Relation Expr)) -ineqQuadraticExercise = makeExercise - { exerciseId = describe "solve a quadratic inequation" $ - newId "algebra.inequalities.quadratic" - , status = Provisional - , parser = parseExprWith (pLogicRelation pExpr) - , prettyPrinter = showLogicRelation - , isReady = solvedRelations - , eqWithContext = Just quadrEqContext - , similarity = simLogic (fmap (normExpr cleanUpExpr) . flipGT) - , strategy = ineqQuadratic - , navigation = termNavigator - , ruleOrdering = ruleOrderingWithId quadraticRuleOrder - , examples = map (Logic.Var . build inequalityView) - (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad]) - } - -ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr)) -ineqHigherDegreeExercise = makeExercise - { exerciseId = describe "solve an inequation of higher degree" $ - newId "algebra.inequalities.polynomial" - , status = Provisional - , parser = parseExprWith (pLogicRelation pExpr) - , prettyPrinter = showLogicRelation - , isReady = solvedRelations - , eqWithContext = Just highEqContext - , similarity = simLogic (fmap (normExpr cleanUpExpr) . flipGT) - , strategy = ineqHigherDegree - , navigation = termNavigator - , ruleOrdering = ruleOrderingWithId quadraticRuleOrder - , examples = map (Logic.Var . build inequalityView) ineqHigh - } - -ineq :: String -ineq = "algebra.inequalities" - -showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String -showLogicRelation logic = - case logic of - Logic.T -> "true" - Logic.F -> "false" - Logic.Var a -> show a - p :||: q -> showLogicRelation p ++ " or " ++ showLogicRelation q - p :&&: q -> case match betweenView logic of - Just (x, o1, y, o2, z) -> - let f b = if b then "<=" else "<" - in unwords [show x, f o1, show y, f o2, show z] - _ -> showLogicRelation p ++ " and " ++ showLogicRelation q - _ -> show logic - -betweenView :: Eq a => View (Logic (Relation a)) (a, Bool, a, Bool, a) -betweenView = makeView f h - where - f (Logic.Var r1 :&&: Logic.Var r2) = do - ineq1 <- match inequalityView r1 - ineq2 <- match inequalityView r2 - let g (a :>=: b) = b :<=: a - g (a :>: b) = b :<: a - g e = e - make (g ineq1) (g ineq2) - f _ = Nothing - - make a b - | la == rb && ra /= lb = make b a - | ra == lb = - Just (la, op a, ra, op b, rb) - | otherwise = Nothing - where - (la, ra) = (leftHandSide a, rightHandSide a) - (lb, rb) = (leftHandSide b, rightHandSide b) - op (_ :<=: _) = True - op _ = False - - h (x, o1, y, o2, z) = - let g b = if b then (.<=.) else (.<.) - in Logic.Var (g o1 x y) :&&: Logic.Var (g o2 y z) - -ineqLinear :: LabeledStrategy (Context (Relation Expr)) -ineqLinear = cleanUpStrategy (applyTop (fmap cleanUpSimple)) ineqLinearG - -ineqLinearG :: IsTerm a => LabeledStrategy (Context a) -ineqLinearG = label "Linear inequation" $ - label "Phase 1" (repeat - ( use removeDivision - <|> multi (showId distributeTimes) - (somewhere (useC parentNotNegCheck <*> use distributeTimes)) - <|> multi (showId merge) (once (use merge)) - )) - <*> - label "Phase 2" - ( try (use varToLeft) - <*> try coverUpPlus - <*> try (use flipSign) - <*> try (use coverUpTimesPositive) - ) - --- helper strategy (todo: fix needed, because the original rules do not --- work on relations) -coverUpPlus :: IsTerm a => Strategy (Context a) -coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps) - where - coverUps :: [ConfigCoverUp -> Rule (Relation Expr)] - coverUps = - [ coverUpBinaryRule "plus" (commOp . isPlus) (-) - , coverUpBinaryRule "minus-left" isMinus (+) - , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-)) - ] - -coverUpTimesPositive :: Rule (Relation Expr) -coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp - where - m expr = do - (a, b) <- matchM timesView expr - r <- matchM rationalView a - guard (r>0) - return (a, b) - -flipSign :: Rule (Relation Expr) -flipSign = describe "Flip sign of inequality" $ - makeSimpleRule (ineq, "flip-sign") $ \r -> do - let lhs = leftHandSide r - rhs = rightHandSide r - guard (isNegative lhs) - return $ constructor (flipSides r) (neg lhs) (neg rhs) - where - isNegative (Negate _) = True - isNegative expr = - maybe False fst (match productView expr) - -ineqQuadratic :: LabeledStrategy (Context (Logic (Relation Expr))) -ineqQuadratic = cleanUpStrategy (applyTop cleanUpLogicRelation) $ - label "Quadratic inequality" $ - use trivialRelation - |> try (useC turnIntoEquation) - <*> quadraticStrategyG - <*> useC solutionInequation - -ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr))) -ineqHigherDegree = cleanUpStrategy (applyTop cleanUpLogicRelation) $ - label "Inequality of a higher degree" $ - use trivialRelation - |> try (useC turnIntoEquation) - <*> higherDegreeStrategyG - <*> useC solutionInequation - --- First, cleanup expression. Then, cleanup equations only (there is an --- explicit rule for the other relations). Finally, simplify the logical --- proposition (including impotency or). -cleanUpLogicRelation :: Logic (Relation Expr) -> Logic (Relation Expr) -cleanUpLogicRelation = - let f a | relationType a == EqualTo = build orListView (cleanUpRelation a) - | otherwise = Logic.Var a - in simplifyWith idempotent orListView . Logic.simplify - . catLogic . fmap (f . fmap cleanUpExpr) - -trivialRelation :: Rule (OrList (Relation Expr)) -trivialRelation = - makeSimpleRule (ineq, "trivial") $ oneDisjunct $ \a -> do - let new = cleanUpRelation a - guard (isTrue new || isFalse new) - return new - -turnIntoEquation :: Rule (Context (Relation Expr)) -turnIntoEquation = describe "Turn into equation" $ - makeSimpleRule (ineq, "to-equation") $ withCM $ \r -> do - guard (relationType r `elem` ineqTypes) - addToClipboard "ineq" (toExpr r) - return (leftHandSide r .==. rightHandSide r) - where - ineqTypes = - [LessThan, GreaterThan, LessThanOrEqualTo, GreaterThanOrEqualTo] - --- Todo: cleanup this function -solutionInequation :: Rule (Context (Logic (Relation Expr))) -solutionInequation = describe "Determine solution for inequality" $ - makeSimpleRule (ineq, "give-solution") $ withCM $ \r -> do - inEquation <- lookupClipboard "ineq" >>= fromExpr - removeClipboard "ineq" - orv <- maybeCM (matchM orListView r) - case disjunctions orv of - Nothing -> -- both sides are the same - if relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] - then return Logic.T - else return Logic.F - Just [] -> do -- no solutions found for equations - let vs = vars (toExpr inEquation) - guard (not (null vs)) - if evalIneq inEquation (head vs) 0 - then return Logic.T - else return Logic.F - Just xs -> do - (vs, ys) <- liftM unzip $ matchM (listView (equationView >>> equationSolvedForm)) xs - let v = head vs - zs = nub $ map (simplify (squareRootViewWith rationalView)) ys - ds <- matchM (listView doubleView) zs - guard (all (==v) vs) - let rs = makeRanges including (sort (zipWith A ds zs)) - including = relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] - return $ fromIntervals v fromDExpr $ - fromList [ this | (d, isP, this) <- rs, isP || evalIneq inEquation v d ] - where - makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)] - makeRanges b xs = - [makeLeft $ head xs] - ++ concatMap (uncurry makeMiddle) (zip xs (drop 1 xs)) - ++ [makePoint (last xs) | b] - ++ [makeRight $ last xs] - where - makeLeft a@(A d _) - | b = (d-1, False, lessThanOrEqualTo a) - | otherwise = (d-1, False, lessThan a) - makeRight a@(A d _) - | b = (d+1, False, greaterThanOrEqualTo a) - | otherwise = (d+1, False, greaterThan a) - makePoint a@(A d _) = (d, True, singleton a) - makeMiddle a1@(A d1 _) a2@(A d2 _) = - [ makePoint a1 | b ] ++ - [ ( (d1+d2)/2 - , False - , open a1 a2 - ) - ] - - evalIneq :: Relation Expr -> String -> Double -> Bool - evalIneq r v d = fromMaybe False $ - liftM2 (evalType (relationType r)) (useSide leftHandSide) (useSide rightHandSide) - where - useSide f = match doubleView (sub (f r)) - - evalType tp = - case tp of - EqualTo -> (==) - NotEqualTo -> (/=) - LessThan -> (<) - GreaterThan -> (>) - LessThanOrEqualTo -> (<=) - GreaterThanOrEqualTo -> (>=) - Approximately -> \a b -> abs (a-b) < 0.001 - - sub (Var x) | x==v = Number d - sub expr = descend sub expr - -data DExpr = A Double Expr - -instance Eq DExpr where - A d1 _ == A d2 _ = d1==d2 - -instance Ord DExpr where - A d1 _ `compare` A d2 _ = d1 `compare` d2 - -fromDExpr :: DExpr -> Expr +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.IneqExercises + ( ineqLinearExercise, ineqQuadraticExercise, ineqHigherDegreeExercise + ) where + +import Common.Library hiding (isEmpty) +import Common.Utils.Uniplate (descend) +import Control.Monad +import Data.Foldable (toList) +import Data.Function +import Data.List +import Data.Maybe (fromMaybe) +import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic) +import Domain.Math.CleanUp +import Domain.Math.Data.Interval +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) +import Domain.Math.Equation.Views +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Equivalence +import Domain.Math.Polynomial.Examples +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.SquareRoot.Views +import qualified Domain.Logic.Formula as Logic +import qualified Domain.Logic.Views as Logic + +ineqLinearExercise :: Exercise (Relation Expr) +ineqLinearExercise = makeExercise + { exerciseId = describe "solve a linear inequation" $ + newId "algebra.inequalities.linear" + , status = Provisional + , parser = parseRelExpr + , ready = predicateView relationSolvedForm + , equivalence = withoutContext linEq + , similarity = withoutContext (viewEquivalent (traverseView cleanUpView)) + , strategy = ineqLinear + , navigation = termNavigator + , examples = let x = Var "x" + extra = (x-12) / (-2) :>: (x+3)/3 + in level Medium $ + map (build inequalityView) (concat ineqLin1 ++ [extra]) + } + +ineqQuadraticExercise :: Exercise (Logic (Relation Expr)) +ineqQuadraticExercise = makeExercise + { exerciseId = describe "solve a quadratic inequation" $ + newId "algebra.inequalities.quadratic" + , status = Provisional + , parser = parseLogicRelExpr + , prettyPrinter = showLogicRelation + , ready = predicateView relationsSolvedForm + , equivalence = quadrEqContext + , similarity = simIneqContext + , strategy = ineqQuadratic + , navigation = termNavigator + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , examples = level Medium $ + map (Logic.Var . build inequalityView) + (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad]) + } + +ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr)) +ineqHigherDegreeExercise = makeExercise + { exerciseId = describe "solve an inequation of higher degree" $ + newId "algebra.inequalities.polynomial" + , status = Provisional + , parser = parseLogicRelExpr + , prettyPrinter = showLogicRelation + , ready = predicateView relationsSolvedForm + , equivalence = highEqContext + , similarity = simIneqContext + , strategy = ineqHigherDegree + , navigation = termNavigator + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , examples = level Medium $ map (Logic.Var . build inequalityView) ineqHigh + } + +ineq :: String +ineq = "algebra.inequalities" + +simIneqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool +simIneqContext a b = + sameClipboard a b && + withoutContext (simLogic (fmap cleanUpExpr . flipGT)) a b + where + sameClipboard = (==) `on` evalCM (const (lookupClipboard "ineq")) + +--inEquation <- lookupClipboard "ineq" >>= fromExpr + +showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String +showLogicRelation logic = + case logic of + Logic.T -> "true" + Logic.F -> "false" + Logic.Var a -> show a + p :||: q -> showLogicRelation p ++ " or " ++ showLogicRelation q + p :&&: q -> case match betweenView logic of + Just (x, o1, y, o2, z) -> + let f b = if b then "<=" else "<" + in unwords [show x, f o1, show y, f o2, show z] + _ -> showLogicRelation p ++ " and " ++ showLogicRelation q + _ -> show logic + +betweenView :: Eq a => View (Logic (Relation a)) (a, Bool, a, Bool, a) +betweenView = makeView f h + where + f (Logic.Var r1 :&&: Logic.Var r2) = do + ineq1 <- match inequalityView r1 + ineq2 <- match inequalityView r2 + let g (a :>=: b) = b :<=: a + g (a :>: b) = b :<: a + g e = e + make (g ineq1) (g ineq2) + f _ = Nothing + + make a b + | la == rb && ra /= lb = make b a + | ra == lb = + Just (la, op a, ra, op b, rb) + | otherwise = Nothing + where + (la, ra) = (leftHandSide a, rightHandSide a) + (lb, rb) = (leftHandSide b, rightHandSide b) + op (_ :<=: _) = True + op _ = False + + h (x, o1, y, o2, z) = + let g b = if b then (.<=.) else (.<.) + in Logic.Var (g o1 x y) :&&: Logic.Var (g o2 y z) + +ineqLinear :: LabeledStrategy (Context (Relation Expr)) +ineqLinear = cleanUpStrategyAfter (applyTop (fmap cleanUpSimple)) ineqLinearG + +ineqLinearG :: IsTerm a => LabeledStrategy (Context a) +ineqLinearG = label "Linear inequation" $ + label "Phase 1" (repeatS + ( use removeDivision + <|> multi (showId distributeTimes) + (somewhere (useC parentNotNegCheck <*> use distributeTimes)) + <|> multi (showId merge) (once (use merge)) + )) + <*> + label "Phase 2" + ( try (use varToLeft) + <*> try coverUpPlus + <*> try (use flipSign) + <*> try (use coverUpTimesPositive) + ) + +-- helper strategy (todo: fix needed, because the original rules do not +-- work on relations) +coverUpPlus :: IsTerm a => Strategy (Context a) +coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps) + where + coverUps :: [ConfigCoverUp -> Rule (Relation Expr)] + coverUps = + [ coverUpBinaryRule "plus" (commOp . isPlus) (-) + , coverUpBinaryRule "minus-left" isMinus (+) + , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-)) + ] + +coverUpTimesPositive :: Rule (Relation Expr) +coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp + where + m expr = do + (a, b) <- matchM timesView expr + r <- matchM rationalView a + guard (r>0) + return (a, b) + +flipSign :: Rule (Relation Expr) +flipSign = describe "Flip sign of inequality" $ + makeSimpleRule (ineq, "flip-sign") $ \r -> do + let lhs = leftHandSide r + rhs = rightHandSide r + guard (isNegative lhs) + return $ constructor (flipSides r) (neg lhs) (neg rhs) + where + isNegative (Negate _) = True + isNegative expr = + maybe False fst (match productView expr) + +ineqQuadratic :: LabeledStrategy (Context (Logic (Relation Expr))) +ineqQuadratic = cleanUpStrategyAfter (applyTop cleanUpLogicRelation) $ + label "Quadratic inequality" $ + use trivialRelation + |> try (useC turnIntoEquation) + <*> quadraticStrategyG + <*> useC solutionInequation + +ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr))) +ineqHigherDegree = cleanUpStrategyAfter (applyTop cleanUpLogicRelation) $ + label "Inequality of a higher degree" $ + use trivialRelation + |> try (useC turnIntoEquation) + <*> higherDegreeStrategyG + <*> useC solutionInequation + +-- First, cleanup expression. Then, cleanup equations only (there is an +-- explicit rule for the other relations). Finally, simplify the logical +-- proposition (including impotency or). +cleanUpLogicRelation :: Logic (Relation Expr) -> Logic (Relation Expr) +cleanUpLogicRelation = + let f a | relationType a == EqualTo = build orListView (cleanUpRelation a) + | otherwise = Logic.Var a + in simplifyWith noDuplicates orListView . Logic.simplify + . catLogic . fmap (f . fmap cleanUpExpr) + +trivialRelation :: Rule (OrList (Relation Expr)) +trivialRelation = + makeSimpleRule (ineq, "trivial") $ oneDisjunct $ \a -> do + let new = cleanUpRelation a + guard (isTrue new || isFalse new) + return new + +turnIntoEquation :: Rule (Context (Relation Expr)) +turnIntoEquation = describe "Turn into equation" $ + makeSimpleRule (ineq, "to-equation") $ withCM $ \r -> do + guard (relationType r `elem` ineqTypes) + addToClipboard "ineq" (toExpr r) + return (leftHandSide r .==. rightHandSide r) + where + ineqTypes = + [LessThan, GreaterThan, LessThanOrEqualTo, GreaterThanOrEqualTo] + +-- Todo: cleanup this function +solutionInequation :: Rule (Context (Logic (Relation Expr))) +solutionInequation = describe "Determine solution for inequality" $ + makeSimpleRule (ineq, "give-solution") $ withCM $ \r -> do + inEquation <- lookupClipboard "ineq" >>= fromExpr + let rt = relationType inEquation + removeClipboard "ineq" + orv <- maybeCM (matchM orListView r) + case toList orv of + _ | isTrue orv -> + return $ fromBool $ + rt `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] + _ | isFalse orv -> do -- no solutions found for equations + let vs = vars (toExpr inEquation) + guard (not (null vs)) + return $ fromBool $ evalIneq inEquation (head vs) 0 + xs -> do + (vs, ys) <- liftM unzip $ matchM (listView (equationView >>> equationSolvedForm)) xs + let v = head vs + zs = nub $ map (simplify (squareRootViewWith rationalView)) ys + ds <- matchM (listView doubleView) zs + guard (all (==v) vs) + let rs = makeRanges including (sort (zipWith A ds zs)) + including = rt `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo] + return $ fmap (fmap fromDExpr) $ intervalRelations (A 0 (Var v)) $ + ors [ this | (d, isP, this) <- rs, isP || evalIneq inEquation v d ] + where + makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)] + makeRanges b xs = + [makeLeft $ head xs] + ++ concatMap (uncurry makeMiddle) (zip xs (drop 1 xs)) + ++ [makePoint (last xs) | b] + ++ [makeRight $ last xs] + where + makeLeft a@(A d _) + | b = (d-1, False, lessThanOrEqualTo a) + | otherwise = (d-1, False, lessThan a) + makeRight a@(A d _) + | b = (d+1, False, greaterThanOrEqualTo a) + | otherwise = (d+1, False, greaterThan a) + makePoint a@(A d _) = (d, True, point a) + makeMiddle a1@(A d1 _) a2@(A d2 _) = + [ makePoint a1 | b ] ++ + [ ( (d1+d2)/2 + , False + , open a1 a2 + ) + ] + + evalIneq :: Relation Expr -> String -> Double -> Bool + evalIneq r v d = fromMaybe False $ + liftM2 (eval (relationType r)) (useSide leftHandSide) (useSide rightHandSide) + where + useSide f = match doubleView (sub (f r)) + + sub (Var x) | x==v = fromDouble d + sub expr = descend sub expr + +data DExpr = A Double Expr + +instance Eq DExpr where + A d1 _ == A d2 _ = d1==d2 + +instance Ord DExpr where + A d1 _ `compare` A d2 _ = d1 `compare` d2 + +fromDExpr :: DExpr -> Expr fromDExpr (A _ e) = e - -fromIntervals :: Eq a => String -> (a -> Expr) -> Intervals a -> Logic (Relation Expr) -fromIntervals v f = ors . map (fromInterval v f) . toList - where - ors [] = Logic.F - ors xs = foldr1 (:||:) xs - -fromInterval :: Eq a => String -> (a -> Expr) -> Interval a -> Logic (Relation Expr) -fromInterval v f i - | isEmpty i = Logic.F - | otherwise = - case (leftPoint i, rightPoint i) of - (Unbounded, Unbounded) -> Logic.T - (Unbounded, Including b) -> Logic.Var (Var v .<=. f b) - (Unbounded, Excluding b) -> Logic.Var (Var v .<. f b) - (Including a, Unbounded) -> Logic.Var (Var v .>=. f a) - (Excluding a, Unbounded) -> Logic.Var (Var v .>. f a) - (Including a, Including b) - | a == b -> Logic.Var (Var v .==. f a) - | otherwise -> Logic.Var (Var v .>=. f a) :&&: Logic.Var (Var v .<=. f b) - (Including a, Excluding b) -> Logic.Var (Var v .>=. f a) :&&: Logic.Var (Var v .<. f b) - (Excluding a, Including b) -> Logic.Var (Var v .>. f a) :&&: Logic.Var (Var v .<=. f b) - (Excluding a, Excluding b) -> Logic.Var (Var v .>. f a) :&&: Logic.Var (Var v .<. f b) diff --git a/src/Domain/Math/Polynomial/LeastCommonMultiple.hs b/src/Domain/Math/Polynomial/LeastCommonMultiple.hs --- a/src/Domain/Math/Polynomial/LeastCommonMultiple.hs +++ b/src/Domain/Math/Polynomial/LeastCommonMultiple.hs @@ -1,138 +1,138 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.LeastCommonMultiple - ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM - , powerProductView - ) where - -import Prelude hiding ((^)) -import Common.TestSuite -import Common.View -import Control.Monad -import Data.List -import Data.Ratio -import Data.Maybe -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Power.Views -import Test.QuickCheck - --- | Returns the least common multiple of two expressions. -lcmExpr :: Expr -> Expr -> Expr -lcmExpr a b = fromMaybe (a*b) $ do - (ar, as) <- match powerProductView a - (br, bs) <- match powerProductView b - return $ build powerProductView (lcmR ar br, merge as bs) - where - lcmR :: Rational -> Rational -> Rational - lcmR r1 r2 = - let f r = numerator r * denominator r - in fromIntegral (lcm (f r1) (f r2)) - - merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)] - merge = foldr op id - where - op (e, n1) f ys = - let n2 = fromMaybe 0 (lookup e ys) - rest = filter ((/=e) . fst) ys - in (e, n1 `max` n2) : f rest - --- | Only succeeds if there is no remainder -divisionExpr :: Expr -> Expr -> Maybe Expr -divisionExpr a b = do - (ar, as) <- match powerProductView a - (br, bs) <- match powerProductView b - xs <- as `without` bs - return $ build powerProductView (ar/br, xs) - where - without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)] - without [] ys = - guard (null ys) >> return [] - without ((e,n1):xs) ys = - let n2 = fromMaybe 0 (lookup e ys) - rest = filter ((/=e) . fst) ys - in liftM ((e,n1-n2):) (without xs rest) - -powerProductView :: View Expr (Rational, [(Expr, Integer)]) -powerProductView = makeView f g - where - f expr = do - (b, xs) <- match productView expr - let (r, ys) = collectPairs xs - return (if b then -r else r, merge ys) - - g (r, xs) = - build productView (False, fromRational r : map (build pvn) xs) - - pvn :: View Expr (Expr, Integer) - pvn = powerView >>> second integerView - - collectPairs :: [Expr] -> (Rational, [(Expr, Integer)]) - collectPairs = foldr op (1, []) - where - op e (r, xs) = - let mr = match rationalView e - h r2 = (r*r2, xs) - pair = fromMaybe (e,1) (match pvn e) - in maybe (r, pair:xs) h mr - - merge :: [(Expr, Integer)] -> [(Expr, Integer)] - merge [] = [] - merge xs@((e, _) : _) = - let (xs1, xs2) = partition ((==e) . fst) xs - n = sum (map snd xs1) - in (e, n) : merge xs2 - -testLCM :: TestSuite -testLCM = suite "lcmExpr" $ do - addProperty "transitivity" $ f3 $ \a b c -> - lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c - addProperty "commutativity" $ f2 $ \a b -> - lcmExpr a b ~= lcmExpr b a - addProperty "idempotency" $ f1 $ \a -> - lcmExpr a a ~= absExpr a - addProperty "zero" $ f1 $ \a -> - lcmExpr a 0 ~= 0 - addProperty "one" $ f1 $ \a -> - lcmExpr a 1 ~= absExpr a - addProperty "sign" $ f2 $ \a b -> - lcmExpr a b ~= lcmExpr (-a) b - where - f1 g = liftM g genExpr - f2 g = liftM2 g genExpr genExpr - f3 g = liftM3 g genExpr genExpr genExpr - - genExpr, genTerm, genAtom :: Gen Expr - genExpr = do - n <- choose (0, 10) - b <- arbitrary - xs <- replicateM n genTerm - return $ build productView (b, xs) - - genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)] - - genAtom = do - v <- oneof $ map (return . Var) ["a", "b", "c"] - i <- choose (-10, 10) - n <- choose (0, 10) - p <- frequency [(3, return v), (1, return (v .+. fromInteger i))] - frequency [(3, return p), (1, return (p^fromInteger n))] - - (~=) = equalFactors - absExpr = simplifyWith (first (const False)) productView - -noCommonFactor :: Expr -> Expr -> Bool -noCommonFactor x y = lcmExpr x y `equalFactors` (x*y) - -equalFactors :: Expr -> Expr -> Bool -equalFactors x y = f x == f y - where f = simplifyWith (second sort) powerProductView +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.LeastCommonMultiple + ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM + , powerProductView + ) where + +import Common.Utils.TestSuite +import Common.View +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ratio +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Views +import Prelude hiding ((^)) +import Test.QuickCheck + +-- | Returns the least common multiple of two expressions. +lcmExpr :: Expr -> Expr -> Expr +lcmExpr a b = fromMaybe (a*b) $ do + (ar, as) <- match powerProductView a + (br, bs) <- match powerProductView b + return $ build powerProductView (lcmR ar br, merge as bs) + where + lcmR :: Rational -> Rational -> Rational + lcmR r1 r2 = + let f r = numerator r * denominator r + in fromIntegral (lcm (f r1) (f r2)) + + merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)] + merge = foldr op id + where + op (e, n1) f ys = + let n2 = fromMaybe 0 (lookup e ys) + rest = filter ((/=e) . fst) ys + in (e, n1 `max` n2) : f rest + +-- | Only succeeds if there is no remainder +divisionExpr :: Expr -> Expr -> Maybe Expr +divisionExpr a b = do + (ar, as) <- match powerProductView a + (br, bs) <- match powerProductView b + xs <- as `without` bs + return $ build powerProductView (ar/br, xs) + where + without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)] + without [] ys = + guard (null ys) >> return [] + without ((e,n1):xs) ys = + let n2 = fromMaybe 0 (lookup e ys) + rest = filter ((/=e) . fst) ys + in liftM ((e,n1-n2):) (without xs rest) + +powerProductView :: View Expr (Rational, [(Expr, Integer)]) +powerProductView = makeView f g + where + f expr = do + (b, xs) <- match productView expr + let (r, ys) = collectPairs xs + return (if b then -r else r, merge ys) + + g (r, xs) = + build productView (False, fromRational r : map (build pvn) xs) + + pvn :: View Expr (Expr, Integer) + pvn = powerView >>> second integerView + + collectPairs :: [Expr] -> (Rational, [(Expr, Integer)]) + collectPairs = foldr op (1, []) + where + op e (r, xs) = + let mr = match rationalView e + h r2 = (r*r2, xs) + pair = fromMaybe (e,1) (match pvn e) + in maybe (r, pair:xs) h mr + + merge :: [(Expr, Integer)] -> [(Expr, Integer)] + merge [] = [] + merge xs@((e, _) : _) = + let (xs1, xs2) = partition ((==e) . fst) xs + n = sum (map snd xs1) + in (e, n) : merge xs2 + +testLCM :: TestSuite +testLCM = suite "lcmExpr" $ do + addProperty "transitivity" $ f3 $ \a b c -> + lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c + addProperty "commutativity" $ f2 $ \a b -> + lcmExpr a b ~= lcmExpr b a + addProperty "idempotency" $ f1 $ \a -> + lcmExpr a a ~= absExpr a + addProperty "zero" $ f1 $ \a -> + lcmExpr a 0 ~= 0 + addProperty "one" $ f1 $ \a -> + lcmExpr a 1 ~= absExpr a + addProperty "sign" $ f2 $ \a b -> + lcmExpr a b ~= lcmExpr (-a) b + where + f1 g = liftM g genExpr + f2 g = liftM2 g genExpr genExpr + f3 g = liftM3 g genExpr genExpr genExpr + + genExpr, genTerm, genAtom :: Gen Expr + genExpr = do + n <- choose (0, 10) + b <- arbitrary + xs <- replicateM n genTerm + return $ build productView (b, xs) + + genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)] + + genAtom = do + v <- elements $ map Var ["a", "b", "c"] + i <- choose (-10, 10) + n <- choose (0, 10) + p <- frequency [(3, return v), (1, return (v .+. fromInteger i))] + frequency [(3, return p), (1, return (p^fromInteger n))] + + (~=) = equalFactors + absExpr = simplifyWith (first (const False)) productView + +noCommonFactor :: Expr -> Expr -> Bool +noCommonFactor x y = lcmExpr x y `equalFactors` (x*y) + +equalFactors :: Expr -> Expr -> Bool +equalFactors x y = f x == f y + where f = simplifyWith (second sort) powerProductView diff --git a/src/Domain/Math/Polynomial/RationalExamples.hs b/src/Domain/Math/Polynomial/RationalExamples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/RationalExamples.hs @@ -0,0 +1,166 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.RationalExamples + ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit + ) where + +import Common.Rewriting +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Prelude hiding ((^)) + +---------------------------------------------------------- +-- VWO B applets + +-- Hoofdstuk 1, gebroken vergelijkingen +brokenEquations :: [[Equation Expr]] +brokenEquations = + -- Bereken exact de oplossingen + let x = Var "x" in + [ [ (2*x^2-10) / (x^2+3) :==: 0 + , (7*x^2-21) / (2*x^2-5) :==: 0 + , (3*x^2-6) / (4*x^2+1) :==: 0 + , (4*x^2-24) / (6*x^2-2) :==: 0 + , x^2 / (x+4) :==: (3*x+4) / (x+4) + , (x^2+2) / (x-2) :==: (x+8) / (x-2) + , (x^2+6*x-6)/(x^2-1) :==: (4*x+9)/(x^2-1) + , (x^2+6)/(x^2-2) :==: (7*x)/(x^2-2) + ] + , [ (x^2+6*x)/(x^2-1) :==: (3*x+4)/(x^2-1) + , (x^2+6)/(x-3) :==: (5*x)/(x-3) + , (x^2+4*x)/(x^2-4) :==: (3*x + 6)/(x^2-4) + , (x^2+2*x-4)/(x-5) :==: (4*x+11)/(x-5) + , (5*x+2)/(2*x-1) :==: (5*x+2)/(3*x+5) + , (x^2-9)/(4*x-1) :==: (x^2-9)/(2*x+7) + , (3*x-2)/(2*x^2) :==: (3*x-2)/(x^2+4) + , (2*x+1)/(x^2+3*x) :==: (2*x+1)/(5*x+8) + ] + , [ (x^2-1)/(2*x+2) :==: (x^2-1)/(x+8) + , (x^2-4)/(3*x-6) :==: (x^2-4)/(2*x+1) + , (x^2+5*x)/(2*x^2) :==: (x^2+5*x)/(x^2+4) + , (x^2-3*x)/(2*x-6) :==: (x^2-3*x)/(4*x+2) + , x/(x+1) :==: 1 + 3/4 + , (x+2)/(3*x) :==: 1 + 1/3 + , (2*x+3)/(x-1) :==: 3 + 1/2 + , (x-3)/(1-x) :==: 1 + 2/5 + ] + , [ (x+4)/(x+3) :==: (x+1)/(x+2) + , (2*x+3)/(x-1) :==: (2*x-1) / (x-2) + , (3*x+6)/(3*x-1) :==: (x+4)/(x+1) + , (x+2)/(2*x+5) :==: (x+4)/(2*x-3) + , (x+5)/(2*x) + 2 :==: 5 + , (3*x+4)/(x+2) - 3 :==: 2 + , (x^2)/(5*x+6) + 4 :==: 5 + , (x^2)/(2*x-3) + 3 :==: 7 + ] + , [ (x-2)/(x-3) :==: x/2 + , (x+9)/(x-5) :==: 2/x + , (x+2)/(x+4) :==: 2/(x+1) + , (-3)/(x-5) :==: (x+3)/(x+1) + , (x+1)/(x+2) :==: (7*x+1)/(2*x-4) + , (2*x-7)/(5-x) :==: (x+1)/(3*x-7) + , (x+1)/(x-1) :==: (3*x-7)/(x-2) + , (3*x-7)/(x-2) :==: (7-x)/(3*x-3) + ] + ] + +-- Hoofdstuk 4, gebroken vorm herleiden (1 en 1a) +normBroken :: [[Expr]] +normBroken = + -- Herleid + let x = Var "x" in + let y = Var "y" in + let a = Var "a" in + let b = Var "b" in + [ [ 7/(2*x) + 3/(5*x), 3/(2*x) + 2/(3*x), 4/(5*x)-2/(3*x) + , 2/(7*x) - 1/(4*x), 5/(6*a)+3/(7*a), 3/(8*a)+5/(3*a) + , 7/(2*a)-2/(3*a), 9/(5*a)-1/(2*a) + ] + , [ 1/x+1/y, 2/(3*x)+1/(2*y), 3/(x^2*y) - 5/(2*x*y), 2/(x*y)-7/(5*y) + , 2/a - 3/b, 4/(3*a)-2/(5*b), 2/(a*b)+4/(3*a), 7/(4*a)+3/(4*b) + ] + , [ 3+1/(2*x), 2*x+(3/(5*x)), 5/(2*x)-3, 3-5/(7*x), 5/(3*a)+1 + , 4*a+3/(2*a), 2*a-1/(3*a), 7/(5*a)-2 + ] + , [ 5/(x+2)+4/(x+3), 3/(x-1)+2/(x+3), 4/(x+5)+2/(x-3), 3/(x-2)+2/(x-3) + , 4/(x+3)-6/(x+2), 1/(x+5)-3/(x-4), 7/(x-3)-2/(x+1), 6/(x-1)-3/(x-2) + ] + , [ (x+1)/(x+2)+(x+2)/(x-3), (x-2)/(x+3)+(x-1)/(x+2), (x+3)/(x-1)+(x+2)/(x-4) + , (x-4)/(x+5)+(x-2)/(x-3), (x-1)/(x+1)-(x+2)/(x-2), (x+5)/(x+3)-(x+3)/(x+5) + , (x-1)/(x+2)-(x+4)/(x+1), (x-3)/(x-1)-(x+2)/(x+4) + ] + , [ (2*x)/(x-1)+x/(x+2), (3*x)/(x-4)+(5*x)/(x-2) + , (4*x)/(x+2)-(2*x)/(x+1), x/(x+5)-(4*x)/(x+6) + ] + ] + +-- Hoofdstuk 4, gebroken vorm herleiden (2 en 2a) +normBroken2 :: [[Expr]] +normBroken2 = + -- Herleid + let x = Var "x" in + let a = Var "a" in + let p = Var "p" in + [ [ (x^2+4*x-5)/(x^2+5*x-6), (x^2+2*x-8)/(x^2+10*x+24) + , (x^2-7*x+12)/(x^2+x-20), (x^2+7*x+12)/(x^2+5*x+6) + , (a^2-a-2)/(a^2+4*a-12), (a^2-3*a-10)/(a^2-a-20) + , (a^2-2*a-15)/(a^2-3*a-18), (a^2+a-2)/(a^2+3*a+2) + ] + , [ (x^2-16)/(x^2+x-12), (x^2-2*x+1)/(x^2-1), (x^2-9)/(x^2+6*x+9) + , (x^2-7*x+6)/(x^2-1), (2*p^2+8*p)/(p^2-16), (-(p^2)+5*p)/(p^2-10*p+25) + , (p^2-4)/(4*p^2+8*p), (p^2-12*p+36)/(p^2-6*p) + ] + , [ (x^3+3*x^2+2*x)/(x^2+4*x+4), (x^3+10*x^2+24*x)/(x^2+7*x+6) + , (x^2+5*x+6)/(x^3-x^2-6*x), (x^2+3*x-4)/(x^3-6*x^2+5*x) + , (a^3+7*a^2+12*a)/(a^2+6*a+9), (a^3+7*a^2+10*a)/(a^2-a-6) + , (a^2-9)/(a^3-4*a^2+3*a), (a^2-2*a-15)/(a^3-3*a^2-10*a) + ] + ] + +deelUit :: [[Expr]] +deelUit = + let x = Var "x" in + let a = Var "a" in + let p = Var "p" in + let t = Var "t" in + [ -- laatste sommen van gebroken vorm herleiden (2), niveau 5 + [ (-6*a^2-1)/a, -2*p^2+3/(7*p), (7*t^2+4)/(-4*t), (9*x^2+8)/(8*x) + ] + , -- sommen (2a) + [ (-7*a^2-4*a-6)/(-6*a), (3*p^2+6*p-8)/p, (2*t^2-9*t-8)/(-2*t) + , (x^2+5*x+5)/(2*x), (5*a^3-4*a+2)/(9*a), (5*p^3-7*p^2+9)/(2*p) + , (-3*t^3+6*t-4)/(3*t), (4*x^3-3*x^2+4)/(7*x) + ] + ] + +-- Vervolg hoofdstuk 4, gebroken vorm herleiden (2 en 2a), vanaf niveau 4 +normBrokenCon :: [[Equation Expr]] +normBrokenCon = + -- Herleid + let a = Var "a" in + let p = Var "p" in + let t = Var "t" in + let ca = symbol (newSymbol "A") in + let ct = symbol (newSymbol "T") in + let cn = symbol (newSymbol "N") in + [ [ ca :==: (p^2+2*p)/(p^2-4), ca :==: (6*p^2-18*p)/(p^2-9) + , ca :==: (p^2-1)/(-2*p^2+2*p), ca :==: (p^2-16)/(4*p^2+16*p) + , ct :==: (t^3-2*t^2)/(t^2-4), ct :==: (t^3+4*t^2)/(t^2-16) + , ct :==: (t^2-1)/(t^3+t^2), ct :==: (t^2-25)/(t^3-5*t^2) + ] + , [ cn :==: (a^4+4*a^2-5)/(a^4-1), cn :==: (a^4+5*a^2+6)/(a^4+4*a^2+3) + , cn :==: (a^4-5*a^2+6)/(a^4-7*a^2+10), cn :==: (a^4-8*a^2+16)/(a^4-5*a^2+4) + ] + ] diff --git a/src/Domain/Math/Polynomial/RationalExercises.hs b/src/Domain/Math/Polynomial/RationalExercises.hs --- a/src/Domain/Math/Polynomial/RationalExercises.hs +++ b/src/Domain/Math/Polynomial/RationalExercises.hs @@ -1,313 +1,273 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.RationalExercises - ( rationalEquationExercise - , simplifyRationalExercise, divisionRationalExercise - , eqSimplifyRational - ) where - -import Common.Classes -import Common.Context -import Common.Exercise -import Common.Navigator -import Common.Rewriting -import Common.Strategy hiding (not) -import Common.Uniplate -import Common.Utils (fst3) -import Common.View -import Control.Monad -import Data.List hiding (repeat, replicate) -import Data.Maybe -import Domain.Logic.Formula hiding (disjunctions, Var) -import qualified Domain.Logic as Logic -import qualified Domain.Logic.Views as Logic -import Domain.Logic.Views hiding (simplify) -import Domain.Math.Clipboard -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Equation.CoverUpRules -import Domain.Math.Equation.Views -import Domain.Math.Examples.DWO4 -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Exercises (eqOrList) -import Domain.Math.Polynomial.LeastCommonMultiple -import Domain.Math.Polynomial.RationalRules -import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.Strategies -import Domain.Math.Polynomial.Views -import Domain.Math.SquareRoot.Views -import Domain.Math.Power.OldViews -import Prelude hiding (repeat, replicate, until, (^)) -import qualified Data.Set as S - -rationalEquationExercise :: Exercise (OrList (Equation Expr)) -rationalEquationExercise = makeExercise - { exerciseId = describe "solve a rational equation (with a variable in a divisor)" $ - newId "algebra.equations.rational" - , status = Provisional - , parser = parseExprWith (pOrList (pEquation pExpr)) - , isSuitable = isJust . rationalEquations - , isReady = solvedRelations - , eqWithContext = Just eqRationalEquation - , similarity = eqOrList cleanUpExpr - , strategy = rationalEquationStrategy - , ruleOrdering = ruleOrderingWithId quadraticRuleOrder - , navigation = termNavigator - , examples = map return (concat brokenEquations) - } - -simplifyRationalExercise :: Exercise Expr -simplifyRationalExercise = makeExercise - { exerciseId = describe "simplify a rational expression (with a variable in a divisor)" $ - newId "algebra.manipulation.rational.simplify" - , status = Alpha -- Provisional - , parser = parseExpr --- isSuitable - , isReady = simplifiedRational - -- , eqWithContext = Just eqSimplifyRational - , similarity = \x y -> cleanUpExpr x == cleanUpExpr y - , strategy = simplifyRationalStrategy - , ruleOrdering = ruleOrderingWithId quadraticRuleOrder - , navigation = termNavigator - , examples = concat (normBroken ++ normBroken2) - } - -divisionRationalExercise :: Exercise Expr -divisionRationalExercise = simplifyRationalExercise - { exerciseId = describe "divide a rational expression ('uitdelen')" $ - newId "math.divrational" - , strategy = label "divide broken fraction" succeed - , examples = concat deelUit - } - -rationalEquationStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) -rationalEquationStrategy = cleanUpStrategy (applyTop (fmap (fmap cleaner))) $ - label "Rational equation" $ - brokenFormToPoly <*> higherDegreeStrategyG <*> checkSolutionStrategy - where - -- a custom-made clean-up function. (Standard) cleanUpExpr function - -- has some strange interaction with the rules - cleaner = transform (simplify (powerFactorViewWith rationalView)) - . cleanUpSimple . transform smart - - brokenFormToPoly = label "rational form to polynomial" $ until allArePoly $ - ( useC divisionIsZero <|> useC divisionIsOne - <|> useC sameDivisor <|> useC sameDividend - <|> use coverUpPlus <|> use coverUpMinusLeft <|> use coverUpMinusRight - <|> use coverUpNegate - ) |> - ( useC crossMultiply <|> useC multiplyOneDiv ) - checkSolutionStrategy = label "check solutions" $ - try (multi (showId checkSolution) (somewhere checkSolution)) - -allArePoly :: Context (OrList (Equation Expr)) -> Bool -allArePoly = - let f a = a `belongsTo` polyView - in maybe False (all f . concatMap crush . crush) . fromContext - -simplifyRationalStrategy :: LabeledStrategy (Context Expr) -simplifyRationalStrategy = cleanUpStrategy (applyTop cleaner) $ - label "Simplify rational expression" $ - phaseOneDiv <*> phaseSimplerDiv - where - -- a custom-made clean-up function. (Standard) cleanUpExpr function - -- has some strange interaction with the rules - cleaner = transform (simplify (powerFactorViewWith rationalView)) . cleanUpSimple - - phaseOneDiv = label "Write as division" $ - until isDivC $ - use fractionPlus <|> use fractionScale <|> use turnIntoFraction - phaseSimplerDiv = label "Simplify division" $ - repeat $ - (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv) - <|> commit (onlyUpperDiv (repeat findFactorsStrategyG) <*> useC cancelTermsDiv)) - |> ( somewhere (use merge) - <|> multi (showId distributeTimes) (exceptLowerDiv (use distributeTimes)) - ) - -isDivC :: Context a -> Bool -isDivC = maybe False (isJust . isDivide :: Term -> Bool) . currentT - --- First check that the whole strategy can be executed. Cleaning up is not --- propagated correctly to predicate in check combinator, hence the use of --- cleanUpStrategy (which is not desirable here). -commit :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr) -commit s = let cs = cleanUpStrategy (applyTop cleanUpExpr) (label "" s) - f a = fromMaybe a (do b <- top a; c <- current a; return (change (const c) b)) - in check (applicable cs . f) <*> s - -exceptLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) -exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> - if isDivC a then [1] else [0 .. arity a-1] - -onlyUpperDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) -onlyUpperDiv = onceWith "only-upper-div" $ \a -> [ 1 | isDivC a ] - -onlyLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) -onlyLowerDiv = onceWith "only-lower-div" $ \a -> [ 2 | isDivC a ] - -simplifiedRational :: Expr -> Bool -simplifiedRational expr = - case expr of - Negate a -> simplifiedRational a - _ -> f expr - where - f (a :/: b) = inPolyForm a && noCommonFactor a b && inFactorForm b - f _ = False - - inPolyForm :: Expr -> Bool - inPolyForm a = - a `belongsTo` polyNormalForm identity || - S.size (varSet expr) > 1 - - inFactorForm :: Expr -> Bool - inFactorForm = flip belongsTo $ - let v = first (polyNormalForm identity >>> second linearPolyView) - in powerProductView >>> second (listView v) - -rationalEquations :: OrList (Equation Expr) -> Maybe (OrList Expr) -rationalEquations = maybe (return true) f . disjunctions - where - f xs = do - yss <- mapM rationalEquation xs - return (join (orList yss)) - -rationalEquation :: Equation Expr -> Maybe (OrList Expr) -rationalEquation eq = do - let (lhs :==: rhs) = coverUp eq - (a, b, c) = rationalExpr (lhs .-. rhs) - (_, as) <- match productView a - (_, bs) <- match productView b - let condition = foldr ((.&&.) . notZero) c bs - new1 <- match higherDegreeEquationsView $ orList $ map (:==: 0) as - return (restrictOrList condition new1) - -restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr -restrictOrList p0 = maybe true (orList . filter p) . disjunctions - where - p zeroExpr = - case coverUp (zeroExpr :==: 0) of - Var x :==: a -> -- returns true if a contradiction was not found - substVar x (cleanUpExpr a) p0 /= F - _ -> True - - substVar x a = Logic.simplify . catLogic . fmap (simpler . fmap (cleanUpExpr . subst)) - where - subst (Var s) | x == s = a - subst expr = descend subst expr - - simpler r = fromMaybe (Logic.Var r) $ do - a <- match (squareRootViewWith rationalView) (leftHandSide r) - b <- match (squareRootViewWith rationalView) (rightHandSide r) - case (a==b, relationType r) of - (True, EqualTo) -> return T - (False, EqualTo) -> return F - (True, NotEqualTo) -> return F - (False, NotEqualTo) -> return T - _ -> Nothing - -eqRationalEquation :: Context (OrList (Equation Expr)) -> Context (OrList (Equation Expr)) -> Bool -eqRationalEquation ca cb = fromMaybe False $ - liftM2 (==) (solve ca) (solve cb) - where - solve ctx = do - let f = fromMaybe T . conditionOnClipboard - a <- fromContext ctx - xs <- rationalEquations a - ys <- disjunctions (restrictOrList (f ctx) xs) - return (sort (nub ys)) - -eqSimplifyRational :: Context Expr -> Context Expr -> Bool -eqSimplifyRational ca cb = fromMaybe False $ do - a <- fromContext ca - b <- fromContext cb - let a1c = cleanUpExpr (fst3 (rationalExpr a)) - b1c = cleanUpExpr (fst3 (rationalExpr b)) - manyVars = S.size (varSet a `S.union` varSet b) > 1 - if manyVars then return True else do - p1 <- match (polyViewWith rationalView) a1c - p2 <- match (polyViewWith rationalView) b1c - return (manyVars || p1==p2) - -conditionOnClipboard :: Context a -> Maybe (Logic (Relation Expr)) -conditionOnClipboard = evalCM $ const $ - lookupClipboardG "condition" - --- write expression as a/b, under certain conditions -rationalExpr :: Expr -> (Expr, Expr, Logic (Relation Expr)) -rationalExpr expr = - case expr of - a :+: b -> rationalExpr a `fPlus` rationalExpr b - a :-: b -> rationalExpr (a :+: Negate b) - Negate a -> fNeg (rationalExpr a) - a :*: b -> rationalExpr a `fTimes` rationalExpr b - a :/: b -> rationalExpr a `fTimes` fRecip (rationalExpr b) - Sym s [a, b] | isPowerSymbol s -> - fPower (rationalExpr a) b - _ -> (expr, 1, T) - where - fNeg (a, b, p) = (neg a, b, p) - fRecip (a, b, p) = (b, a, notZero b .&&. p) - fPower (a, b, p) n = (a .^. n, b .^. n, p) - fTimes (a1, a2, p) (b1, b2, q) = (a1 .*. b1, a2 .*. b2, p .&&. q) - fPlus (a1, a2, p) (b1, b2, q) = - case (divisionExpr c2 a2, divisionExpr c2 b2) of - (Just a3, Just b3) - | a1 == b1 -> (a1 .*. (a3 .+. b3), c2, pq) - | a1 == neg b1 -> (a1 .*. (a3 .-. b3), c2, pq) - | otherwise -> (a1 .*. a3 .+. b1 .*. b3, c2, pq) - _ -> (a1 .*. b2 .+. b1 .*. a2, a2 .*. b2, pq) - where - c2 = lcmExpr a2 b2 - pq = p .&&. q - -notZero :: Expr -> Logic (Relation Expr) -notZero expr = - case match rationalView expr of - Just r | r /= 0 -> T - | otherwise -> F - _ -> Logic.Var (expr ./=. 0) - ------------------ --- test code - -{- -raar = brokenExpr $ x^2/(5*x+6) + 1 - where x = Var "x" -- -go0 = checkExercise rationalEquationExercise - -go = checkExercise simplifyRationalExercise - -see n = printDerivation ex (examples ex !! (n-1)) - where ex = --rationalEquationExercise - simplifyRationalExercise - -go4 = printDerivation findFactorsExercise $ -a + 4 - where x = Var "x" - a = Var "a" - -test = e4 - where - a = Var "a" - b = Var "b" - - e1 = 6*a*b*a - e2 = -4*b^2*a*2 - e3 = lcmExpr e1 e2 - e4 = divisionExpr e3 e1 - e5 = divisionExpr e3 e2 - -go = putStrLn $ unlines $ map show $ zip [1..] $ map (brokenEq []) (concat brokenEquations) --} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.RationalExercises + ( rationalEquationExercise + , simplifyRationalExercise, divisionRationalExercise + , eqSimplifyRational + ) where + +import Common.Library +import Common.Utils (fst3) +import Common.Utils.Uniplate +import Control.Monad +import Data.Maybe +import Domain.Logic.Formula hiding (Var) +import Domain.Logic.Views ((.&&.)) +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Equation.Views +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.LeastCommonMultiple +import Domain.Math.Polynomial.RationalExamples +import Domain.Math.Polynomial.RationalRules +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.Polynomial.Views +import Domain.Math.Power.OldViews (powerFactorViewWith) +import Domain.Math.SquareRoot.Views +import Prelude hiding ((^)) +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.Traversable as T +import qualified Domain.Logic as Logic +import qualified Domain.Logic.Views as Logic + +rationalEquationExercise :: Exercise (OrList (Equation Expr)) +rationalEquationExercise = makeExercise + { exerciseId = describe "solve a rational equation (with a variable in a divisor)" $ + newId "algebra.equations.rational" + , status = Provisional + , parser = parseOrsEqExpr + , suitable = predicate (isJust . rationalEquations) + , ready = predicateView relationsSolvedForm + , equivalence = eqRationalEquation + , similarity = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView))) + , strategy = rationalEquationStrategy + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , navigation = termNavigator + , examples = level Medium $ map singleton (concat brokenEquations) + } + +simplifyRationalExercise :: Exercise Expr +simplifyRationalExercise = makeExercise + { exerciseId = describe "simplify a rational expression (with a variable in a divisor)" $ + newId "algebra.manipulation.rational.simplify" + , status = Alpha + , parser = parseExpr + , ready = predicate simplifiedRational +-- , equivalence = withoutContext eqSimplifyRational + , similarity = withoutContext (viewEquivalent cleanUpView) + , strategy = simplifyRationalStrategy + , ruleOrdering = ruleOrderingWithId quadraticRuleOrder + , navigation = termNavigator + , examples = level Medium $ concat (normBroken ++ normBroken2) + } + +divisionRationalExercise :: Exercise Expr +divisionRationalExercise = simplifyRationalExercise + { exerciseId = describe "divide a rational expression ('uitdelen')" $ + newId "math.divrational" + , strategy = label "divide broken fraction" succeed + , examples = level Medium $ concat deelUit + } + +rationalEquationStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +rationalEquationStrategy = cleanUpStrategy (applyTop (fmap (fmap cleaner))) $ + label "Rational equation" $ + brokenFormToPoly <*> higherDegreeStrategyG <*> checkSolutionStrategy + where + -- a custom-made clean-up function. (Standard) cleanUpExpr function + -- has some strange interaction with the rules + cleaner = transform (simplify (powerFactorViewWith rationalView)) + . cleanUpSimple . transform smart + + brokenFormToPoly = label "rational form to polynomial" $ untilS allArePoly $ + ( useC divisionIsZero <|> useC divisionIsOne + <|> useC sameDivisor <|> useC sameDividend + <|> use coverUpPlus <|> use coverUpMinusLeft <|> use coverUpMinusRight + <|> use coverUpNegate + ) |> + ( useC crossMultiply <|> useC multiplyOneDiv ) + checkSolutionStrategy = label "check solutions" $ + try (multi (showId checkSolution) (somewhere checkSolution)) + +allArePoly :: Context (OrList (Equation Expr)) -> Bool +allArePoly = + let f a = a `belongsTo` polyView + in maybe False (all f . concatMap F.toList . F.toList) . fromContext + +simplifyRationalStrategy :: LabeledStrategy (Context Expr) +simplifyRationalStrategy = cleanUpStrategy (applyTop cleaner) $ + label "Simplify rational expression" $ + phaseOneDiv <*> phaseSimplerDiv + where + -- a custom-made clean-up function. (Standard) cleanUpExpr function + -- has some strange interaction with the rules + cleaner = transform (simplify (powerFactorViewWith rationalView)) . cleanUpSimple + + phaseOneDiv = label "Write as division" $ + untilS isDivC $ + use fractionPlus <|> use fractionScale <|> use turnIntoFraction + phaseSimplerDiv = label "Simplify division" $ + repeatS $ + (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv) + <|> commitS (onlyUpperDiv (repeatS findFactorsStrategyG) <*> useC cancelTermsDiv)) + |> ( somewhere (use merge) + <|> multi (showId distributeTimes) (exceptLowerDiv (use distributeTimes)) + ) + +isDivC :: Context a -> Bool +isDivC = maybe False (isJust . isDivide :: Term -> Bool) . currentT + +-- First check that the whole strategy can be executed. Cleaning up is not +-- propagated correctly to predicate in check combinator, hence the use of +-- cleanUpStrategy (which is not desirable here). +commitS :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr) +commitS s = + let cs = cleanUpStrategy (applyTop cleanUpExpr) (label "" s) + f a = fromMaybe a (do b <- top a; c <- current a; return (change (const c) b)) + in check (applicable cs . f) <*> s + +exceptLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) +exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> + if isDivC a then [1] else [0 .. arity a-1] + +onlyUpperDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) +onlyUpperDiv = onceWith "only-upper-div" $ \a -> [ 1 | isDivC a ] + +onlyLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a) +onlyLowerDiv = onceWith "only-lower-div" $ \a -> [ 2 | isDivC a ] + +simplifiedRational :: Expr -> Bool +simplifiedRational expr = + case expr of + Negate a -> simplifiedRational a + _ -> f expr + where + f (a :/: b) = inPolyForm a && noCommonFactor a b && inFactorForm b + f _ = False + + inPolyForm :: Expr -> Bool + inPolyForm a = + a `belongsTo` polyNormalForm identity || + S.size (varSet expr) > 1 + + inFactorForm :: Expr -> Bool + inFactorForm = flip belongsTo $ + let v = first (polyNormalForm identity >>> second linearPolyView) + in powerProductView >>> second (listView v) + +rationalEquations :: OrList (Equation Expr) -> Maybe (OrList Expr) +rationalEquations = fmap (F.foldMap id) . T.mapM rationalEquation + +rationalEquation :: Equation Expr -> Maybe (OrList Expr) +rationalEquation eq = do + let (lhs :==: rhs) = coverUp eq + (a, b, c) = rationalExpr (lhs .-. rhs) + (_, as) <- match productView a + (_, bs) <- match productView b + let condition = foldr ((.&&.) . notZero) c bs + new1 <- match higherDegreeEquationsView $ toOrList $ map (:==: 0) as + return (restrictOrList condition new1) + +restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr +restrictOrList p0 = catOrList . fmap f + where + f a | p a = singleton a + | otherwise = false + p zeroExpr = + case coverUp (zeroExpr :==: 0) of + Var x :==: a -> -- returns true if a contradiction was not found + substVar x (cleanUpExpr a) p0 /= F + _ -> True + + substVar x a = Logic.simplify . catLogic . fmap (simpler . fmap (cleanUpExpr . subst)) + where + subst (Var s) | x == s = a + subst expr = descend subst expr + + simpler r = fromMaybe (Logic.Var r) $ do + a <- match (squareRootViewWith rationalView) (leftHandSide r) + b <- match (squareRootViewWith rationalView) (rightHandSide r) + case (a==b, relationType r) of + (True, EqualTo) -> return true + (False, EqualTo) -> return false + (True, NotEqualTo) -> return false + (False, NotEqualTo) -> return true + _ -> Nothing + +eqRationalEquation :: Context (OrList (Equation Expr)) -> Context (OrList (Equation Expr)) -> Bool +eqRationalEquation ca cb = fromMaybe False $ + liftM2 (==) (solve ca) (solve cb) + where + solve ctx = do + let f = fromMaybe T . conditionOnClipboard + a <- fromContext ctx + xs <- rationalEquations a + return $ simplify orSetView $ restrictOrList (f ctx) xs + +eqSimplifyRational :: Expr -> Expr -> Bool +eqSimplifyRational a b = fromMaybe False $ do + let a1c = cleanUpExpr (fst3 (rationalExpr a)) + b1c = cleanUpExpr (fst3 (rationalExpr b)) + manyVars = S.size (varSet a `S.union` varSet b) > 1 + if manyVars then return True else do + p1 <- match (polyViewWith rationalView) a1c + p2 <- match (polyViewWith rationalView) b1c + return (p1==p2) + +conditionOnClipboard :: Context a -> Maybe (Logic (Relation Expr)) +conditionOnClipboard = evalCM $ const $ + lookupClipboardG "condition" + +-- write expression as a/b, under certain conditions +rationalExpr :: Expr -> (Expr, Expr, Logic (Relation Expr)) +rationalExpr expr = + case expr of + a :+: b -> rationalExpr a `fPlus` rationalExpr b + a :-: b -> rationalExpr (a :+: Negate b) + Negate a -> fNeg (rationalExpr a) + a :*: b -> rationalExpr a `fTimes` rationalExpr b + a :/: b -> rationalExpr a `fTimes` fRecip (rationalExpr b) + Sym s [a, b] | isPowerSymbol s -> + fPower (rationalExpr a) b + _ -> (expr, 1, T) + where + fNeg (a, b, p) = (neg a, b, p) + fRecip (a, b, p) = (b, a, notZero b .&&. p) + fPower (a, b, p) n = (a .^. n, b .^. n, p) + fTimes (a1, a2, p) (b1, b2, q) = (a1 .*. b1, a2 .*. b2, p .&&. q) + fPlus (a1, a2, p) (b1, b2, q) = + case (divisionExpr c2 a2, divisionExpr c2 b2) of + (Just a3, Just b3) + | a1 == b1 -> (a1 .*. (a3 .+. b3), c2, pq) + | a1 == neg b1 -> (a1 .*. (a3 .-. b3), c2, pq) + | otherwise -> (a1 .*. a3 .+. b1 .*. b3, c2, pq) + _ -> (a1 .*. b2 .+. b1 .*. a2, a2 .*. b2, pq) + where + c2 = lcmExpr a2 b2 + pq = p .&&. q + +notZero :: Expr -> Logic (Relation Expr) +notZero expr = + case match rationalView expr of + Just r | r /= 0 -> T + | otherwise -> F + _ -> Logic.Var (expr ./=. 0) + +{- +q = checkExercise simplifyRationalExercise +go = rationalExpr $ (a^2-2*a-15)/(a^3-3*a^2-10*a) + where a = Var "a" -} diff --git a/src/Domain/Math/Polynomial/RationalRules.hs b/src/Domain/Math/Polynomial/RationalRules.hs --- a/src/Domain/Math/Polynomial/RationalRules.hs +++ b/src/Domain/Math/Polynomial/RationalRules.hs @@ -1,186 +1,182 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.RationalRules - ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend - , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv - , fractionScale, turnIntoFraction, checkSolution - ) where - -import Common.Context -import Common.Id -import Common.Transformation -import Common.View -import Control.Monad -import Data.Maybe -import Domain.Logic.Formula hiding (disjunctions, Var) -import Domain.Logic.Views -import Domain.Math.Clipboard -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Equation.CoverUpRules -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.LeastCommonMultiple -import Domain.Math.Polynomial.Views -import Domain.Math.Power.Views -import qualified Domain.Logic.Formula as Logic - -ratId :: Id -ratId = newId "algebra.equations.rational" - ---------------------------------------------------------------- --- Rules for rational expressions and rational equations - --- a/b = 0 iff a=0 (and b/=0) -divisionIsZero :: Rule (Context (Equation Expr)) -divisionIsZero = makeSimpleRule (ratId, "division-zero") $ withCM $ \(lhs :==: rhs) -> do - guard (rhs == 0) - (a, b) <- matchM divView lhs - conditionNotZero b - return (a :==: 0) - --- a/b = 1 iff a=b (and b/=0) -divisionIsOne :: Rule (Context (Equation Expr)) -divisionIsOne = makeSimpleRule (ratId, "division-one") $ withCM $ \(lhs :==: rhs) -> do - guard (rhs == 1) - (a, b) <- matchM divView lhs - conditionNotZero b - return (a :==: b) - --- a/c = b/c iff a=b (and c/=0) -sameDivisor :: Rule (Context (Equation Expr)) -sameDivisor = makeSimpleRule (ratId, "same-divisor") $ withCM $ \(lhs :==: rhs) -> do - (a, c1) <- matchM divView lhs - (b, c2) <- matchM divView rhs - guard (c1==c2) - conditionNotZero c1 - return (a :==: b) - --- a/b = a/c iff a=0 or b=c (and b/=0 and c/=0) -sameDividend :: Rule (Context (OrList (Equation Expr))) -sameDividend = makeSimpleRule (ratId, "same-dividend") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do - (a1, b) <- matchM divView lhs - (a2, c) <- matchM divView rhs - guard (a1==a2) - conditionNotZero b - conditionNotZero c - return $ orList [a1 :==: 0, b :==: c] - --- a/b = c/d iff a*d = b*c (and b/=0 and d/=0) -crossMultiply :: Rule (Context (Equation Expr)) -crossMultiply = makeSimpleRule (ratId, "cross-multiply") $ withCM $ \(lhs :==: rhs) -> do - (a, b) <- matchM divView lhs - (c, d) <- matchM divView rhs - conditionNotZero b - conditionNotZero d - return (a*d :==: b*c) - --- a/b = c iff a = b*c (and b/=0) -multiplyOneDiv :: Rule (Context (Equation Expr)) -multiplyOneDiv = makeSimpleRule (ratId, "multiply-one-div") $ withCM $ \(lhs :==: rhs) -> - f (:==:) lhs rhs `mplus` f (flip (:==:)) rhs lhs - where - f eq ab c = do - guard (not (c `belongsTo` divView)) - (a, b) <- matchM divView ab - conditionNotZero b - return (a `eq` (b*c)) - --- a/c + b/c = a+b/c (also see Numeric.Rules) -fractionPlus :: Rule Expr -- also minus -fractionPlus = makeSimpleRule (ratId, "rational-plus") $ \expr -> do - ((a, b), (c, d)) <- match myView expr - guard (b == d) - return (build divView (a+c, b)) - where - myView = plusView >>> (divView *** divView) - --- ab/ac => b/c (if a/=0) --- Note that the common term can be squared (in one of the parts) -cancelTermsDiv :: Rule (Context Expr) -cancelTermsDiv = makeSimpleRule (ratId, "cancel-div") $ withCM $ \expr -> do - ((b, xs), (c, ys)) <- matchM myView expr - let (ps, qs, rs) = rec (map f xs) (map f ys) - guard (not (null rs)) - conditionNotZero (build productView (False, map g rs)) - return $ build myView ((b, map g ps), (c, map g qs)) - where - myView = divView >>> (productView *** productView) - powInt = powerView >>> second integerView - f a = fromMaybe (a, 1) (match powInt a) - g = build powInt - rec ((_, 0):xs) ys = rec xs ys - rec (pair@(a, n):xs) ys = - case break ((==a) . fst) ys of - (ys1, (b, m):ys2) - | m == 0 -> - rec (pair:xs) (ys1++ys2) - | otherwise -> - let i = n `min` m - (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2) - in (ps, qs, (a,i):rs) - _ -> - let (ps,qs,rs) = rec xs ys - in (pair:ps, qs,rs) - rec xs ys = (xs, ys, []) - -fractionScale :: Rule Expr -fractionScale = liftRule myView $ - makeSimpleRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do - guard (e1 /= e2) - let e3 = lcmExpr e1 e2 - ma <- divisionExpr e3 e1 - mb <- divisionExpr e3 e2 - guard (ma /= 1 || mb /= 1) - return ((ma*a, e3), (mb*b, e3)) - where - myView = plusView >>> (divView *** divView) - -turnIntoFraction :: Rule Expr -turnIntoFraction = liftRule plusView $ - makeSimpleRule (ratId, "to-rational") $ \(a, b) -> - liftM (\c -> (c, b)) (f a b) `mplus` - liftM (\c -> (a, c)) (f b a) - where - f a b = do - guard (not (a `belongsTo` divView)) - (_, e) <- match divView b - return $ build divView (a*e, e) - --- A simple implementation that considers the condition stored in the context -checkSolution :: Rule (Context (OrList (Equation Expr))) -checkSolution = makeSimpleRule (ratId, "check-solution") $ - withCM $ oneDisjunct $ \(x :==: a) -> do - c <- lookupClipboardG "condition" - xs <- matchM andView c - guard ((x ./=. a) `elem` xs) - return false - ---------------------------------------------------------------- --- Helper-code - -condition :: Logic (Relation Expr) -> ContextMonad () -condition c = do - mp <- maybeOnClipboardG "condition" - let a = maybe id (.&&.) mp c - unless (a==T) (addToClipboardG "condition" a) - -conditionNotZero :: Expr -> ContextMonad () -conditionNotZero expr = condition (f xs) - where - f = pushNotWith (Logic.Var . notRelation) . nott - eq = expr :==: 0 - xs = fmap (build equationView . fmap cleanUpExpr) $ - case match higherDegreeEquationsView (return eq) of - Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys)) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.RationalRules + ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend + , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv + , fractionScale, turnIntoFraction, checkSolution + ) where + +import Common.Library +import Control.Monad +import Data.Maybe +import Domain.Logic.Formula hiding (Var) +import Domain.Logic.Views +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.LeastCommonMultiple +import Domain.Math.Polynomial.Views +import Domain.Math.Power.Views +import qualified Domain.Logic.Formula as Logic + +ratId :: Id +ratId = newId "algebra.equations.rational" + +--------------------------------------------------------------- +-- Rules for rational expressions and rational equations + +-- a/b = 0 iff a=0 (and b/=0) +divisionIsZero :: Rule (Context (Equation Expr)) +divisionIsZero = makeSimpleRule (ratId, "division-zero") $ withCM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (a, b) <- matchM divView lhs + conditionNotZero b + return (a :==: 0) + +-- a/b = 1 iff a=b (and b/=0) +divisionIsOne :: Rule (Context (Equation Expr)) +divisionIsOne = makeSimpleRule (ratId, "division-one") $ withCM $ \(lhs :==: rhs) -> do + guard (rhs == 1) + (a, b) <- matchM divView lhs + conditionNotZero b + return (a :==: b) + +-- a/c = b/c iff a=b (and c/=0) +sameDivisor :: Rule (Context (Equation Expr)) +sameDivisor = makeSimpleRule (ratId, "same-divisor") $ withCM $ \(lhs :==: rhs) -> do + (a, c1) <- matchM divView lhs + (b, c2) <- matchM divView rhs + guard (c1==c2) + conditionNotZero c1 + return (a :==: b) + +-- a/b = a/c iff a=0 or b=c (and b/=0 and c/=0) +sameDividend :: Rule (Context (OrList (Equation Expr))) +sameDividend = makeSimpleRule (ratId, "same-dividend") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do + (a1, b) <- matchM divView lhs + (a2, c) <- matchM divView rhs + guard (a1==a2) + conditionNotZero b + conditionNotZero c + return $ singleton (a1 :==: 0) <> singleton (b :==: c) + +-- a/b = c/d iff a*d = b*c (and b/=0 and d/=0) +crossMultiply :: Rule (Context (Equation Expr)) +crossMultiply = makeSimpleRule (ratId, "cross-multiply") $ withCM $ \(lhs :==: rhs) -> do + (a, b) <- matchM divView lhs + (c, d) <- matchM divView rhs + conditionNotZero b + conditionNotZero d + return (a*d :==: b*c) + +-- a/b = c iff a = b*c (and b/=0) +multiplyOneDiv :: Rule (Context (Equation Expr)) +multiplyOneDiv = makeSimpleRule (ratId, "multiply-one-div") $ withCM $ \(lhs :==: rhs) -> + f (:==:) lhs rhs `mplus` f (flip (:==:)) rhs lhs + where + f eq ab c = do + guard (not (c `belongsTo` divView)) + (a, b) <- matchM divView ab + conditionNotZero b + return (a `eq` (b*c)) + +-- a/c + b/c = a+b/c (also see Numeric.Rules) +fractionPlus :: Rule Expr -- also minus +fractionPlus = makeSimpleRule (ratId, "rational-plus") $ \expr -> do + ((a, b), (c, d)) <- match myView expr + guard (b == d) + return (build divView (a+c, b)) + where + myView = plusView >>> (divView *** divView) + +-- ab/ac => b/c (if a/=0) +-- Note that the common term can be squared (in one of the parts) +cancelTermsDiv :: Rule (Context Expr) +cancelTermsDiv = makeSimpleRule (ratId, "cancel-div") $ withCM $ \expr -> do + ((b, xs), (c, ys)) <- matchM myView expr + let (ps, qs, rs) = rec (map f xs) (map f ys) + guard (not (null rs)) + conditionNotZero (build productView (False, map g rs)) + return $ build myView ((b, map g ps), (c, map g qs)) + where + myView = divView >>> toView (productView *** productView) + powInt = powerView >>> second integerView + f a = fromMaybe (a, 1) (match powInt a) + g = build powInt + rec ((_, 0):xs) ys = rec xs ys + rec (pair@(a, n):xs) ys = + case break ((==a) . fst) ys of + (ys1, (b, m):ys2) + | m == 0 -> + rec (pair:xs) (ys1++ys2) + | otherwise -> + let i = n `min` m + (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2) + in (ps, qs, (a,i):rs) + _ -> + let (ps,qs,rs) = rec xs ys + in (pair:ps, qs,rs) + rec xs ys = (xs, ys, []) + +fractionScale :: Rule Expr +fractionScale = liftRule myView $ + makeSimpleRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do + guard (e1 /= e2) + let e3 = lcmExpr e1 e2 + ma <- divisionExpr e3 e1 + mb <- divisionExpr e3 e2 + guard (ma /= 1 || mb /= 1) + return ((ma*a, e3), (mb*b, e3)) + where + myView = plusView >>> (divView *** divView) + +turnIntoFraction :: Rule Expr +turnIntoFraction = liftRule plusView $ + makeSimpleRule (ratId, "to-rational") $ \(a, b) -> + liftM (\c -> (c, b)) (f a b) `mplus` + liftM (\c -> (a, c)) (f b a) + where + f a b = do + guard (not (a `belongsTo` divView)) + (_, e) <- match divView b + return $ build divView (a*e, e) + +-- A simple implementation that considers the condition stored in the context +checkSolution :: Rule (Context (OrList (Equation Expr))) +checkSolution = makeSimpleRule (ratId, "check-solution") $ + withCM $ oneDisjunct $ \(x :==: a) -> do + c <- lookupClipboardG "condition" + xs <- matchM andView c + guard ((x ./=. a) `elem` xs) + return false + +--------------------------------------------------------------- +-- Helper-code + +condition :: Logic (Relation Expr) -> ContextMonad () +condition c = do + mp <- maybeOnClipboardG "condition" + let a = maybe id (.&&.) mp c + unless (a==T) (addToClipboardG "condition" a) + +conditionNotZero :: Expr -> ContextMonad () +conditionNotZero expr = condition (f xs) + where + f = pushNotWith (Logic.Var . notRelation) . Not + eq = expr :==: 0 + xs = fmap (build equationView . fmap cleanUpExpr) $ + case match higherDegreeEquationsView (singleton eq) of + Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys)) Nothing -> Logic.Var (coverUp eq) diff --git a/src/Domain/Math/Polynomial/Rules.hs b/src/Domain/Math/Polynomial/Rules.hs --- a/src/Domain/Math/Polynomial/Rules.hs +++ b/src/Domain/Math/Polynomial/Rules.hs @@ -1,592 +1,610 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.Rules - ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms - , commonFactorVar, commonFactorVarNew, defPowerNat, distributeDivision - , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare - , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero - , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar - , parentNotNegCheck, prepareSplitSquare, quadraticRuleOrder, removeDivision - , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational - , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRoot - , squareBothSides, substBackVar, varToLeft - ) where - -import Common.Library hiding (terms, simplify) -import Common.Uniplate (universe, descend) -import Common.Utils -import Control.Monad -import Data.List -import Data.Maybe -import Data.Ord -import Data.Ratio -import Domain.Math.Approximation (precision) -import Domain.Math.Clipboard -import Domain.Math.Data.OrList -import Domain.Math.Data.Polynomial -import Domain.Math.Data.Relation -import Domain.Math.Equation.BalanceRules -import Domain.Math.Equation.CoverUpRules -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Views -import Domain.Math.Power.OldViews -import Domain.Math.Simplification hiding (simplifyWith) -import Domain.Math.SquareRoot.Views -import Prelude hiding ( (^) ) - -quadraticRuleOrder :: [Id] -quadraticRuleOrder = - [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar) - , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar) - , getId coverUpPower - , getId commonFactorVar, getId simplerPolynomial - , getId niceFactors, getId noLinFormula - , getId cancelTerms, getId sameConFactor, getId distributionSquare - , getId allPowerFactors - ] - -lineq, quadreq, polyeq :: String -lineq = "algebra.equations.linear" -quadreq = "algebra.equations.quadratic" -polyeq = "algebra.equations.polynomial" - - ------------------------------------------------------------- --- General form rules: ax^2 + bx + c = 0 - -quadraticNF :: View Expr (String, (Rational, Rational, Rational)) -quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView - --- ax^2 + bx = 0 -commonFactorVar :: Rule (Equation Expr) -commonFactorVar = rhsIsZero commonFactorVarNew - --- Maybe to be replaced by more general factorVariablePower?? -commonFactorVarNew :: Rule Expr -commonFactorVarNew = describe "Common factor variable" $ - makeSimpleRule (quadreq, "common-factor") $ \expr -> do - (x, (a, b, c)) <- match quadraticNF expr - guard (b /= 0 && c == 0) - -- also search for constant factor - let d | a<0 && b<0 = -gcdFrac a b - | otherwise = gcdFrac a b - return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) - -gcdFrac :: Rational -> Rational -> Rational -gcdFrac r1 r2 = - if denominator r1 == 1 && denominator r2 == 1 - then fromInteger (numerator r1 `gcd` numerator r2) - else 1 - --- ax^2 + c = 0 -noLinFormula :: Rule (Equation Expr) -noLinFormula = describe "No linear term ('b=0')" $ liftRule myView $ - makeSimpleRule (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do - guard (rhs == 0 && b == 0 && c /= 0) - return $ if a>0 then ((x, (a, 0, 0)), -c) - else ((x, (-a, 0, 0)), c) - where - myView = constantRight quadraticNF - --- search for (X+A)*(X+B) decomposition -niceFactors :: Rule (Equation Expr) -niceFactors = rhsIsZero niceFactorsNew - --- search for (X+A)*(X+B) decomposition -niceFactorsNew :: Rule Expr -niceFactorsNew = describe "Find a nice decomposition" $ - makeSimpleRuleList (quadreq, "nice-factors") $ \expr -> do - let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t - (x, (a, b, c)) <- liftM sign (matchM (polyNormalForm integerView >>> second quadraticPolyView) expr) - guard (a==1) - let ok (i, j) = i+j == b - f (i, j) - | i == j = -- special case - (Var x + fromInteger i) ^ 2 - | otherwise = - (Var x + fromInteger i) * (Var x + fromInteger j) - map f (filter ok (factors c)) - where - factors :: Integer -> [(Integer, Integer)] - factors n = [ pair - | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n))) - , a <- [1..h], let b = n `div` a, a*b == n - , pair <- [(a, b), (negate a, negate b)] - ] - --- Simplify polynomial by multiplying (or dividing) the terms: --- 1) If a,b,c are ints, then find gcd --- 2) If any of a,b,c is a fraction, find lcm of denominators --- 3) If a<0, then also suggest to change sign (return two solutions) -simplerPolynomial :: Rule (Equation Expr) -simplerPolynomial = describe "simpler polynomial" $ - rhsIsZero $ liftRuleIn thisView $ - makeSimpleRuleList (quadreq, "simpler-poly") $ \(a, b, c) -> do - r <- findFactor (filter (/=0) [a, b, c]) - d <- if a >= 0 then [r] else [-r, r] - guard (d `notElem` [0, 1]) - return (a*d, b*d, c*d) - where - thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView - --- Simplified variant of simplerPoly: just bring a to 1. --- Needed for quadratic strategy without square formula -bringAToOne :: Rule (Equation Expr) -bringAToOne = rhsIsZero $ liftRuleIn thisView $ - describe "Bring 'a' to one" $ - makeSimpleRule (quadreq, "scale") $ \(a, b, c) -> do - guard (a `notElem` [0, 1]) - return (1, b/a, c/a) - where - thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView - ------------------------------------------------------------- --- General form rules: expr = 0 - --- Rule must be symmetric in side of equation -mulZero :: Rule (OrList (Equation Expr)) -mulZero = describe "multiplication is zero" $ - makeSimpleRuleList (quadreq, "product-zero") $ oneDisjunct bothSides - where - bothSides eq = oneSide eq `mplus` oneSide (flipSides eq) - oneSide (lhs :==: rhs) = do - guard (rhs == 0) - (_, xs) <- matchM productView lhs - guard (length xs > 1) - return $ orList $ flip map xs $ \e -> - case match (polyNormalForm rationalView >>> second linearPolyView) e of - -- special cases (simplify immediately, as in G&R) - Just (x, (a, b)) - | a == 1 -> - Var x :==: fromRational (-b) - | a == -1 -> - Var x :==: fromRational b - _ -> e :==: 0 - ------------------------------------------------------------- --- Constant form rules: expr = constant - --- Use this configuration for covering-up plus and minus symbols! --- Prevent (x^2+3x)+5 = 0 to be covered up -oneVar :: ConfigCoverUp -oneVar = configCoverUp - { configName = "onevar" - , predicateCovered = \a -> p1 a || p2 a - , predicateCombined = hasNoVar - , coverLHS = True - , coverRHS = True - } - where - p1 = (==1) . length . vars - -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56 - p2 a = fromMaybe False $ do - (x, y) <- match timesView a - return (hasSomeVar x /= hasSomeVar y) - ------------------------------------------------------------- --- Top form rules: expr1 = expr2 - --- Do not simplify (5+sqrt 53)/2 -simplerSquareRoot :: Rule Expr -simplerSquareRoot = describe "simpler square root" $ - makeSimpleRule (quadreq, "simpler-sqrt") $ \e -> do - xs <- f e - guard (not (null xs)) - new <- canonical (squareRootViewWith rationalView) e - ys <- f new - guard (xs /= ys) - return new - where - -- return numbers under sqrt symbol - f :: Expr -> Maybe [Rational] - f e = liftM sort $ sequence [ match rationalView a | Sqrt a <- universe e ] - -cancelTerms :: Rule (Equation Expr) -cancelTerms = describe "Cancel terms" $ - makeSimpleRule (quadreq, "cancel") $ \(lhs :==: rhs) -> do - xs <- match sumView lhs - ys <- match sumView rhs - let zs = filter (`elem` ys) (nub xs) - guard (not (null zs)) - let without as = build sumView (as \\ zs) - return (without xs :==: without ys) - --- Two out of three "merkwaardige producten" -distributionSquare :: Rule Expr -distributionSquare = describe "distribution square" $ - ruleList (quadreq, "distr-square") - [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2 - , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2 - ] - --- a^2 == b^2 -squareBothSides :: Rule (OrList (Equation Expr)) -squareBothSides = describe "square both sides" $ - rule (quadreq, "square-both") $ \a b -> - orList [a^2 :==: b^2] :~> orList [a :==: b, a :==: -b] - --- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c -prepareSplitSquare :: Rule (Equation Expr) -prepareSplitSquare = describe "prepare split square" $ - liftRule myView $ - makeSimpleRule (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do - let newC = (b/2)*(b/2) - newRHS = r + newC - c - guard (a==1 && b/=0 && c /= newC) - return ((x, (a, b, newC)), newRHS) - where - myView = constantRight quadraticNF - --- factor left-hand side into (ax + c)^2 -factorLeftAsSquare :: Rule (Equation Expr) -factorLeftAsSquare = describe "factor left as square" $ - makeSimpleRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do - guard (hasNoVar rhs) - (x, (a, b, c)) <- match quadraticNF lhs - let h = b/2 - guard (a==1 && b/=0 && h*h == c) - return ((Var x + build rationalView h)^2 :==: rhs) - --- flip the two sides of an equation -flipEquation :: Rule (Equation Expr) -flipEquation = doBeforeTrans condition $ - describe "flip equation" $ - rule (lineq, "flip") $ \a b -> - (a :==: b) :~> (b :==: a) - where - condition = makeTrans $ \eq@(lhs :==: rhs) -> do - guard (hasSomeVar rhs && hasNoVar lhs) - return eq - --- Afterwards, merge and sort -moveToLeft :: Rule (Equation Expr) -moveToLeft = describe "Move to left" $ - makeSimpleRule (quadreq, "move-left") $ \(lhs :==: rhs) -> do - guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs)) - return (collectLikeTerms (sorted (lhs - rhs)) :==: 0) - where - isComplex = maybe False ((>= 2) . length . filter hasSomeVar) - . match sumView . applyD merge - - -- high exponents first, non power-factor terms at the end - sorted = simplifyWith (sortBy (comparing toPF)) sumView - toPF = fmap (negate . thd3) . match powerFactorView - -ruleApproximate :: Rule (Relation Expr) -ruleApproximate = describe "Approximate irrational number" $ - makeSimpleRule (quadreq, "approx") $ \relation -> do - lhs :==: rhs <- match equationView relation - guard (not (simplify rhs `belongsTo` rationalView)) - x <- getVariable lhs - d <- match doubleView rhs - let new = fromDouble (precision 4 d) - return (Var x .~=. new) - -ruleNormalizeRational :: Rule Expr -ruleNormalizeRational = - describe "normalize rational number" $ - ruleFromView (lineq, "norm-rational") rationalView - -ruleNormalizeMixedFraction :: Rule Expr -ruleNormalizeMixedFraction = - describe "normalize mixed fraction" $ - ruleFromView (lineq, "norm-mixed") mixedFractionView - ------------------------------------------------------------ --------- Rules From HDE - --- X*A + X*B = X*C + X*D --- New implementation, but slightly different than original --- This one does not factor constants - -allPowerFactors :: Rule (OrList (Equation Expr)) -allPowerFactors = describe "all power factors" $ - makeSimpleRule (polyeq, "power-factors") $ oneDisjunct $ - \(lhs :==: rhs) -> do - let myView = polyNormalForm rationalView - (s1, p1) <- match myView lhs - (s2, p2) <- match myView rhs - let n | p1 == 0 = lowestDegree p2 - | p2 == 0 = lowestDegree p1 - | otherwise = lowestDegree p1 `min` lowestDegree p2 - ts = terms p1 ++ terms p2 - f p = build myView (s1, raise (-n) p) - guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1) - return $ orList [Var s1 :==: 0, f p1 :==: f p2] - -factorVariablePower :: Rule Expr -factorVariablePower = describe "factor variable power" $ - makeSimpleRule (polyeq, "factor-varpower") $ \expr -> do - let myView = polyNormalForm rationalView - (s, p) <- match (polyNormalForm rationalView) expr - let n = lowestDegree p - guard (n > 0 && length (terms p) > 1) - return $ Var s .^. fromIntegral n * build myView (s, raise (-n) p) - --- A*B = A*C implies A=0 or B=C -sameFactor :: Rule (OrList (Equation Expr)) -sameFactor = describe "same factor" $ - makeSimpleRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do - (b1, xs) <- match productView lhs - (b2, ys) <- match productView rhs - (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong? - return $ orList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ] - --- N*(A+B) = N*C + N*D recognize a constant factor on both sides --- Example: 3(x^2+1/2) = 6+6x -sameConFactor :: Rule (Equation Expr) -sameConFactor = - describe "same constant factor" $ - liftRule myView $ - makeSimpleRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do - let (bs, zs) = unzip (ps1 ++ ps2) - (rs, es) = unzip (map (f 1 []) zs) - f r acc [] = (r, reverse acc) - f r acc (x:xs) = case match rationalView x of - Just r2 -> f (r*r2) acc xs - Nothing -> f r (x:acc) xs - c <- whichCon rs - guard (c /= 1) - let make b r e = (b, fromRational (r/c):e) - (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es) - return (newLeft :==: newRight) - where - myView = bothSidesView (sumView >>> listView productView) - - whichCon :: [Rational] -> Maybe Rational - whichCon xs - | all (\x -> denominator x == 1 && x /= 0) xs = - Just (fromInteger (foldr1 gcd (map numerator xs))) - | otherwise = Nothing - -abcFormula :: Rule (Context (OrList (Equation Expr))) -abcFormula = describe "quadratic formula (abc formule)" $ - makeSimpleRule (quadreq, "abc") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do - guard (rhs == 0) - (x, (a, b, c)) <- matchM quadraticNF lhs - addListToClipboard ["a", "b", "c"] (map fromRational [a, b, c]) - let discr = b*b - 4 * a * c - sqD = sqrt (fromRational discr) - addToClipboard "D" (fromRational discr) - case compare discr 0 of - LT -> return false - EQ -> return $ return $ - Var x :==: (-fromRational b) / (2 * fromRational a) - GT -> return $ orList - [ Var x :==: (-fromRational b + sqD) / (2 * fromRational a) - , Var x :==: (-fromRational b - sqD) / (2 * fromRational a) - ] - -higherSubst :: Rule (Context (Equation Expr)) -higherSubst = describe "Substitute variable" $ - makeSimpleRule (polyeq, "subst") $ withCM $ \(lhs :==: rhs) -> do - guard (rhs == 0) - let myView = polyView >>> second trinomialPolyView - (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs - guard (n1 == 0 && n2 > 1 && n3 `mod` n2 == 0 && x /= "p") - let new = build myView ("p", ((a, 0), (b, 1), (c, n3 `div` n2))) - addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2)) - return (new :==: 0) - -substBackVar :: Rule (Context Expr) -substBackVar = describe "Substitute back a variable" $ - makeSimpleRule (polyeq, "back-subst") $ withCM $ \a -> do - expr <- lookupClipboard "subst" - case fromExpr expr of - Just (Var p :==: rhs) -> do - guard (hasVar p a) - return (subst p rhs a) - _ -> fail "no subst in clipboard" - where - subst a b (Var c) | a==c = b - subst a b expr = descend (subst a b) expr - -exposeSameFactor :: Rule (Equation Expr) -exposeSameFactor = describe "expose same factor" $ - liftRule (bothSidesView productView) $ - makeSimpleRuleList (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do - (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] ++ - [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ] - return ((bx, nx) :==: (by, ny)) - where - suitable p = fromMaybe False $ do - (_, _, b) <- match (linearViewWith rationalView) p - guard (b /= 0) - return True - - exposeList _ [] = [] - exposeList a (b:bs) = map (++bs) (expose a b) ++ map (b:) (exposeList a bs) - - expose a b = do - (s1, p1) <- matchM (polyViewWith rationalView) a - (s2, p2) <- matchM (polyViewWith rationalView) b - guard (s1==s2 && p1/=p2) - case division p2 p1 of - Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3] - Nothing -> [] - ---------------------------------------------------------- --- From LinearEquations - --- Only used for cleaning up -distributeAll :: Expr -> Expr -distributeAll expr = - case expr of - e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1) - bs = fromMaybe [e2] (match sumView e2) - in build sumView [ a .*. b | a <- as, b <- bs ] - _ -> expr - --- This rule should consider the associativity of multiplication --- Combine bottom-up, for example: 5*(x-5)*(x+5) --- However, in -2x(2x+10) (-2x) should be seen as "one term" -distributionT :: Transformation Expr -distributionT = makeTransList f - where - f expr = do - (b, xs) <- matchM simpleProductView expr - ys <- rec (combine xs) - return $ build simpleProductView (b, ys) - - combine :: [Expr] -> [Expr] - combine (x:y:rest) | p x && p y = combine ((x*y):rest) - where p = maybe False ((==1) . length) . match sumView - combine [] = [] - combine (x:xs) = x : combine xs - - rec :: [Expr] -> [[Expr]] - rec (a:b:xs) = map (:xs) (g a b) ++ map (a:) (rec (b:xs)) - rec _ = [] - - g :: Expr -> Expr -> [Expr] - g e1 e2 = do - as <- matchM sumView e1 - bs <- matchM sumView e2 - guard (length as > 1 || length bs > 1) - return $ build sumView [ a .*. b | a <- as, b <- bs ] - -------------------------------------------------------- --- Rewrite Rules - -varToLeft :: Rule (Relation Expr) -varToLeft = doAfter (fmap collectLikeTerms) $ - describe "variable to left" $ - makeRule (lineq, "var-left") $ flip supply1 minusT $ \eq -> do - (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq) - guard (a/=0) - return (fromRational a * Var x) - --- factor is always positive due to lcm function -removeDivision :: Rule (Relation Expr) -removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $ - describe "remove division" $ - makeRule (lineq, "remove-div") $ flip supply1 timesT $ \eq -> do - xs <- match sumView (leftHandSide eq) - ys <- match sumView (rightHandSide eq) - -- also consider parts without variables - -- (but at least one participant should have a variable) - zs <- forM (xs ++ ys) $ \a -> do - (_, list) <- match productView a - return [ (hasSomeVar a, e) | e <- list ] - let f (b, e) = do - (_, this) <- match (divView >>> second integerView) e - return (b, this) - case mapMaybe f (concat zs) of - [] -> Nothing - ps -> let (bs, ns) = unzip ps - in if or bs then return (fromInteger (foldr1 lcm ns)) - else Nothing - -distributeTimes :: Rule Expr -distributeTimes = describe "distribution multiplication" $ - makeSimpleRuleList (lineq, "distr-times") $ - liftM collectLikeTerms . applyAll distributionT - -distributeDivision :: Rule Expr -distributeDivision = describe "distribution division" $ - makeSimpleRule (quadreq, "distr-div") $ \expr -> do - (xs, r) <- match (divView >>> (sumView *** rationalView)) expr - guard (length xs > 1) - let ys = map (/fromRational r) xs - return $ build sumView ys - -merge :: Rule Expr -merge = describe "merge similar terms" $ - makeSimpleRule (lineq, "merge") $ \old -> do - let new = collectLikeTerms old - f = maybe 0 length . match sumView - guard (f old > f new) - return new - -simplerLinearFactor :: Rule Expr -simplerLinearFactor = describe "simpler linear factor" $ - makeSimpleRule (polyeq, "simpler-linfactor") $ \expr -> do - let myView = polyNormalForm rationalView >>> second linearPolyView - (x, (a, b)) <- match myView expr - let d = (if a<0 then negate else id) (gcdFrac a b) - guard (a /= 0 && b /= 0 && d /= 1 && d /= -1) - return $ fromRational d * build myView (x, (a/d, b/d)) - -ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a -ruleFromView s v = makeSimpleRuleList s $ \a -> do - b <- canonicalM v a - guard (a /= b) - return b - -rhsIsZero :: Rule Expr -> Rule (Equation Expr) -rhsIsZero r = makeSimpleRuleList (showId r) $ \(lhs :==: rhs) -> do - guard (rhs == 0) - a <- applyAll r lhs - return (a :==: rhs) - -constantRight :: View Expr a -> View (Equation Expr) (a, Rational) -constantRight v = makeView f g - where - f (lhs :==: rhs) = liftM2 (,) (match v lhs) (match rationalView rhs) - g (a, r) = build v a :==: build rationalView r - -bothSidesView :: View a b -> View (Equation a) (Equation b) -bothSidesView v = makeView f (fmap (build v)) - where - f (lhs :==: rhs) = liftM2 (:==:) (match v lhs) (match v rhs) - -findFactor :: Monad m => [Rational] -> m Rational -findFactor rs - | null rs = - fail "no factor" - | all ((==1) . denominator) rs = - return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs - | otherwise = - return $ fromIntegral $ foldr1 lcm $ map denominator rs - -parentNotNegCheck :: Rule (Context Expr) -parentNotNegCheck = minorRule $ makeSimpleRule "parent not negate check" $ \c -> - case up c >>= current of - Just (Negate _) -> Nothing - _ -> Just c - -noDivisionConstant :: Rule Expr -noDivisionConstant = makeSimpleRule (lineq, "no-div-con") f - where - f (a :/: b) | hasNoVar b && hasSomeVar a = - return ((1/b) * a) - f _ = Nothing - -defPowerNat :: Rule Expr -defPowerNat = makeSimpleRule (polyeq, "def-power-nat") f - where - f (Sym _ [Var _, _]) = Nothing -- should not work on x^5 - f (Sym s [a, Nat n]) | isPowerSymbol s = - return (build productView (False, replicate (fromInteger n) a)) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Rules + ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms + , commonFactorVar, commonFactorVarNew, defPowerNat + , distributeDivisionT, distributeDivisionMulti + , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare + , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero + , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar + , parentNotNegCheck, prepareSplitSquare, quadraticRuleOrder, removeDivision + , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational + , ruleNormalizePolynomial + , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRootMulti + , squareBothSides, substBackVar, varToLeft, conditionVarsRHS, fractionProduct + ) where + +import Common.Library hiding (terms, simplify) +import Common.Utils +import Common.Utils.Uniplate (universe, descend) +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ord +import Data.Ratio +import Domain.Math.Approximation (precision) +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Polynomial +import Domain.Math.Data.Relation +import Domain.Math.Equation.BalanceRules +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Views +import Domain.Math.Power.OldViews (powerFactorView) +import Domain.Math.Safe +import Domain.Math.Simplification hiding (simplifyWith) +import Domain.Math.SquareRoot.Views +import Prelude hiding ( (^) ) +import qualified Prelude + +quadraticRuleOrder :: [Id] +quadraticRuleOrder = + [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar) + , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar) + , getId coverUpPower + , getId commonFactorVar, getId simplerPolynomial + , getId niceFactors, getId noLinFormula + , getId cancelTerms, getId sameConFactor, getId distributionSquare + , getId allPowerFactors + ] + +lineq, quadreq, polyeq :: String +lineq = "algebra.equations.linear" +quadreq = "algebra.equations.quadratic" +polyeq = "algebra.equations.polynomial" + +------------------------------------------------------------ +-- General form rules: ax^2 + bx + c = 0 + +quadraticNF :: View Expr (String, (Rational, Rational, Rational)) +quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView + +-- ax^2 + bx = 0 +commonFactorVar :: Rule (Equation Expr) +commonFactorVar = rhsIsZero commonFactorVarNew + +-- Maybe to be replaced by more general factorVariablePower?? +commonFactorVarNew :: Rule Expr +commonFactorVarNew = describe "Common factor variable" $ + makeSimpleRule (quadreq, "common-factor") $ \expr -> do + (x, (a, b, c)) <- match quadraticNF expr + guard (a /= 0 && b /= 0 && c == 0) + -- also search for constant factor + let d = signum a * gcdFrac a b + return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) + +gcdFrac :: Rational -> Rational -> Rational +gcdFrac r1 r2 = + if denominator r1 == 1 && denominator r2 == 1 + then fromInteger (numerator r1 `gcd` numerator r2) + else 1 + +-- ax^2 + c = 0 +noLinFormula :: Rule (Equation Expr) +noLinFormula = describe "No linear term ('b=0')" $ liftRule myView $ + makeSimpleRule (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do + guard (rhs == 0 && b == 0 && c /= 0) + return $ if a>0 then ((x, (a, 0, 0)), -c) + else ((x, (-a, 0, 0)), c) + where + myView = constantRight quadraticNF + +-- search for (X+A)*(X+B) decomposition +niceFactors :: Rule (Equation Expr) +niceFactors = rhsIsZero niceFactorsNew + +-- search for (X+A)*(X+B) decomposition +niceFactorsNew :: Rule Expr +niceFactorsNew = describe "Find a nice decomposition" $ + makeSimpleRuleList (quadreq, "nice-factors") $ \expr -> do + let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t + (x, (a, b, c)) <- liftM sign (matchM (polyNormalForm integerView >>> second quadraticPolyView) expr) + guard (a==1) + let ok (i, j) = i+j == b + f (i, j) + | i == j = -- special case + (Var x + fromInteger i) ^ 2 + | otherwise = + (Var x + fromInteger i) * (Var x + fromInteger j) + map f (filter ok (factors c)) + where + factors :: Integer -> [(Integer, Integer)] + factors n = [ pair + | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n))) + , a <- [1..h], let b = n `div` a, a*b == n + , pair <- [(a, b), (negate a, negate b)] + ] + +-- Simplify polynomial by multiplying (or dividing) the terms: +-- 1) If a,b,c are ints, then find gcd +-- 2) If any of a,b,c is a fraction, find lcm of denominators +-- 3) If a<0, then also suggest to change sign (return two solutions) +simplerPolynomial :: Rule (Equation Expr) +simplerPolynomial = describe "simpler polynomial" $ + rhsIsZero $ liftRuleIn (quadraticNF >>> toView swapView) $ + makeSimpleRuleList (quadreq, "simpler-poly") $ \(a, b, c) -> do + r <- findFactor (filter (/=0) [a, b, c]) + d <- if a >= 0 then [r] else [-r, r] + guard (d `notElem` [0, 1]) + return (a*d, b*d, c*d) + +-- Simplified variant of simplerPoly: just bring a to 1. +-- Needed for quadratic strategy without square formula +bringAToOne :: Rule (Equation Expr) +bringAToOne = rhsIsZero $ liftRuleIn (quadraticNF >>> toView swapView) $ + describe "Bring 'a' to one" $ + makeSimpleRule (quadreq, "scale") $ \(a, b, c) -> do + guard (a `notElem` [0, 1]) + return (1, b/a, c/a) + +------------------------------------------------------------ +-- General form rules: expr = 0 + +-- Rule must be symmetric in side of equation +mulZero :: Rule (OrList (Equation Expr)) +mulZero = describe "multiplication is zero" $ + makeSimpleRuleList (quadreq, "product-zero") $ oneDisjunct bothSides + where + bothSides eq = oneSide eq `mplus` oneSide (flipSides eq) + oneSide (lhs :==: rhs) = do + guard (rhs == 0) + (_, xs) <- matchM productView lhs + guard (length xs > 1) + return $ toOrList $ flip map xs $ \e -> + case match (polyNormalForm rationalView >>> second linearPolyView) e of + -- special cases (simplify immediately, as in G&R) + Just (x, (a, b)) + | a == 1 -> + Var x :==: fromRational (-b) + | a == -1 -> + Var x :==: fromRational b + _ -> e :==: 0 + +------------------------------------------------------------ +-- Constant form rules: expr = constant + +-- Use this configuration for covering-up plus and minus symbols! +-- Prevent (x^2+3x)+5 = 0 to be covered up +oneVar :: ConfigCoverUp +oneVar = configCoverUp + { configName = "onevar" + , predicateCovered = \a -> p1 a || p2 a + , predicateCombined = hasNoVar + , coverLHS = True + , coverRHS = True + } + where + p1 = (==1) . length . vars + -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56 + p2 a = fromMaybe False $ do + (x, y) <- match timesView a + return (hasSomeVar x /= hasSomeVar y) + +------------------------------------------------------------ +-- Top form rules: expr1 = expr2 + +simplerSquareRootMulti :: IsTerm a => Rule (Context a) +simplerSquareRootMulti = describe "simpler square root" $ + finalRule $ makeSimpleRuleList (quadreq, "simpler-sqrt") $ applyAll $ + repeat1 (somewhere (use (makeSimpleRule () simplerSqrt))) + where + -- Do not simplify (5+sqrt 53)/2 + simplerSqrt :: Expr -> Maybe Expr + simplerSqrt e = do + xs <- f e + guard (not (null xs)) + new <- canonical (squareRootViewWith rationalView) e + ys <- f new + guard (xs /= ys) + return new + + -- return numbers under sqrt symbol + f :: Expr -> Maybe [Rational] + f e = liftM sort $ sequence [ match rationalView a | Sqrt a <- universe e ] + +cancelTerms :: Rule (Equation Expr) +cancelTerms = describe "Cancel terms" $ + makeSimpleRule (quadreq, "cancel") $ \(lhs :==: rhs) -> do + xs <- match sumView lhs + ys <- match sumView rhs + let zs = filter (`elem` ys) (nub xs) + guard (not (null zs)) + let without as = build sumView (as \\ zs) + return (without xs :==: without ys) + +-- "merkwaardige producten" +distributionSquare :: Rule Expr +distributionSquare = describe "distribution for special products" $ + ruleList (quadreq, "distr-square") + [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2 + , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2 + , \a b -> (a+b)*(a-b) :~> a^2 - b^2 + , \a b -> (a-b)*(a+b) :~> a^2 - b^2 + ] + +-- a^2 == b^2 +squareBothSides :: Rule (OrList (Equation Expr)) +squareBothSides = describe "square both sides" $ + rule (quadreq, "square-both") $ \a b -> + singleton (a^2 :==: b^2) :~> toOrList [a :==: b, a :==: -b] + +-- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c +prepareSplitSquare :: Rule (Equation Expr) +prepareSplitSquare = describe "prepare split square" $ + liftRule myView $ + makeSimpleRule (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do + let newC = (b/2)*(b/2) + newRHS = r + newC - c + guard (a==1 && b/=0 && c /= newC) + return ((x, (a, b, newC)), newRHS) + where + myView = constantRight quadraticNF + +-- factor left-hand side into (ax + c)^2 +factorLeftAsSquare :: Rule (Equation Expr) +factorLeftAsSquare = describe "factor left as square" $ + makeSimpleRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do + guard (hasNoVar rhs) + (x, (a, b, c)) <- match quadraticNF lhs + let h = b/2 + guard (a==1 && b/=0 && h*h == c) + return ((Var x + build rationalView h)^2 :==: rhs) + +-- flip the two sides of an equation +flipEquation :: Rule (Equation Expr) +flipEquation = describe "flip equation" $ + rule (lineq, "flip") $ \a b -> + (a :==: b) :~> (b :==: a) + +conditionVarsRHS :: Rule (Equation Expr) +conditionVarsRHS = describe "All variables are in the right-hand side" $ + checkRule $ \(lhs :==: rhs) -> + hasSomeVar rhs && hasNoVar lhs + +-- Afterwards, merge and sort +moveToLeft :: Rule (Equation Expr) +moveToLeft = describe "Move to left" $ + makeSimpleRule (quadreq, "move-left") $ \(lhs :==: rhs) -> do + guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs)) + return (collectLikeTerms (sorted (lhs - rhs)) :==: 0) + where + isComplex = maybe False ((>= 2) . length . filter hasSomeVar) + . match sumView . applyD merge + + -- high exponents first, non power-factor terms at the end + sorted = simplifyWith (sortBy (comparing toPF)) sumView + toPF = fmap (negate . thd3) . match powerFactorView + +ruleApproximate :: Rule (Relation Expr) +ruleApproximate = describe "Approximate irrational number" $ + makeSimpleRule (quadreq, "approx") $ \relation -> do + lhs :==: rhs <- match equationView relation + guard (not (simplify rhs `belongsTo` rationalView)) + x <- getVariable lhs + d <- match doubleView rhs + let new = fromDouble (precision 4 d) + return (Var x .~=. new) + +ruleNormalizeRational :: Rule Expr +ruleNormalizeRational = + describe "normalize rational number" $ + ruleFromView (lineq, "norm-rational") rationalView + +ruleNormalizeMixedFraction :: Rule Expr +ruleNormalizeMixedFraction = + describe "normalize mixed fraction" $ + ruleFromView (lineq, "norm-mixed") mixedFractionView + +ruleNormalizePolynomial :: Rule Expr +ruleNormalizePolynomial = + describe "normalize polynomial" $ + ruleFromView (polyeq, "norm-poly") (polyNormalForm rationalView) + +----------------------------------------------------------- +-------- Rules From HDE + +-- X*A + X*B = X*C + X*D +-- New implementation, but slightly different than original +-- This one does not factor constants + +allPowerFactors :: Rule (OrList (Equation Expr)) +allPowerFactors = describe "all power factors" $ + makeSimpleRule (polyeq, "power-factors") $ oneDisjunct $ + \(lhs :==: rhs) -> do + let myView = polyNormalForm rationalView + (s1, p1) <- match myView lhs + (s2, p2) <- match myView rhs + let n | p1 == 0 = lowestDegree p2 + | p2 == 0 = lowestDegree p1 + | otherwise = lowestDegree p1 `min` lowestDegree p2 + ts = terms p1 ++ terms p2 + f p = build myView (s1, raise (-n) p) + guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1) + return $ toOrList [Var s1 :==: 0, f p1 :==: f p2] + +factorVariablePower :: Rule Expr +factorVariablePower = describe "factor variable power" $ + makeSimpleRule (polyeq, "factor-varpower") $ \expr -> do + let myView = polyNormalForm rationalView + (s, p) <- match (polyNormalForm rationalView) expr + let n = lowestDegree p + guard (n > 0 && length (terms p) > 1) + new <- p `safeDiv` (var Prelude.^ n) + return $ Var s .^. fromIntegral n * build myView (s, new) + +-- A*B = A*C implies A=0 or B=C +sameFactor :: Rule (OrList (Equation Expr)) +sameFactor = describe "same factor" $ + makeSimpleRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do + (b1, xs) <- match productView lhs + (b2, ys) <- match productView rhs + (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong? + return $ toOrList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ] + +-- N*(A+B) = N*C + N*D recognize a constant factor on both sides +-- Example: 3(x^2+1/2) = 6+6x +sameConFactor :: Rule (Equation Expr) +sameConFactor = + describe "same constant factor" $ + liftRule myView $ + makeSimpleRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do + let (bs, zs) = unzip (ps1 ++ ps2) + (rs, es) = unzip (map (f 1 []) zs) + f r acc [] = (r, reverse acc) + f r acc (x:xs) = case match rationalView x of + Just r2 -> f (r*r2) acc xs + Nothing -> f r (x:acc) xs + c <- whichCon rs + guard (c /= 1) + let make b r e = (b, fromRational (r/c):e) + (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es) + return (newLeft :==: newRight) + where + myView = bothSidesView (toView sumView >>> listView (toView productView)) + + whichCon :: [Rational] -> Maybe Rational + whichCon xs + | all (\x -> denominator x == 1 && x /= 0) xs = + Just (fromInteger (foldr1 gcd (map numerator xs))) + | otherwise = Nothing + +abcFormula :: Rule (Context (OrList (Equation Expr))) +abcFormula = describe "quadratic formula (abc formule)" $ + makeSimpleRule (quadreq, "abc") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- matchM quadraticNF lhs + addListToClipboard ["a", "b", "c"] (map fromRational [a, b, c]) + let discr = b*b - 4 * a * c + sqD = sqrt (fromRational discr) + addToClipboard "D" (fromRational discr) + case compare discr 0 of + LT -> return false + EQ -> return $ singleton $ + Var x :==: (-fromRational b) / (2 * fromRational a) + GT -> return $ toOrList + [ Var x :==: (-fromRational b + sqD) / (2 * fromRational a) + , Var x :==: (-fromRational b - sqD) / (2 * fromRational a) + ] + +higherSubst :: Rule (Context (Equation Expr)) +higherSubst = describe "Substitute variable" $ + makeSimpleRule (polyeq, "subst") $ withCM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + let myView = polyView >>> second trinomialPolyView + (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs + guard (n1 == 0 && n2 > 1 && n3 `mod` n2 == 0 && x /= "p") + let new = build myView ("p", ((a, 0), (b, 1), (c, n3 `div` n2))) + addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2)) + return (new :==: 0) + +substBackVar :: Rule (Context Expr) +substBackVar = describe "Substitute back a variable" $ + makeSimpleRule (polyeq, "back-subst") $ withCM $ \a -> do + expr <- lookupClipboard "subst" + case fromExpr expr of + Just (Var p :==: rhs) -> do + guard (hasVar p a) + return (subst p rhs a) + _ -> fail "no subst in clipboard" + where + subst a b (Var c) | a==c = b + subst a b expr = descend (subst a b) expr + +exposeSameFactor :: Rule (Equation Expr) +exposeSameFactor = describe "expose same factor" $ + liftRule (bothSidesView (toView productView)) $ + makeSimpleRuleList (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do + (nx, ny) <- [ (xs, new) | x <- xs, isOk x, new <- exposeList x ys ] ++ + [ (new, ys) | y <- ys, isOk y, new <- exposeList y xs ] + return ((bx, nx) :==: (by, ny)) + where + isOk p = fromMaybe False $ do + (_, _, b) <- match (linearViewWith rationalView) p + guard (b /= 0) + return True + + exposeList _ [] = [] + exposeList a (b:bs) = map (++bs) (expose a b) ++ map (b:) (exposeList a bs) + + expose a b = do + (s1, p1) <- matchM (polyViewWith rationalView) a + (s2, p2) <- matchM (polyViewWith rationalView) b + guard (s1==s2 && p1/=p2) + case safeDiv p2 p1 of + Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3] + Nothing -> [] + +--------------------------------------------------------- +-- From LinearEquations + +-- Only used for cleaning up +distributeAll :: Expr -> Expr +distributeAll expr = + case expr of + e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1) + bs = fromMaybe [e2] (match sumView e2) + in build sumView [ a .*. b | a <- as, b <- bs ] + _ -> expr + +-- This rule should consider the associativity of multiplication +-- Combine bottom-up, for example: 5*(x-5)*(x+5) +-- However, in -2x(2x+10) (-2x) should be seen as "one term" +distributionT :: Transformation Expr +distributionT = makeTransList f + where + f expr = do + (b, xs) <- matchM simpleProductView expr + ys <- rec (combine xs) + return $ build simpleProductView (b, ys) + + combine :: [Expr] -> [Expr] + combine (x:y:rest) | p x && p y = combine ((x*y):rest) + where p = maybe False ((==1) . length) . match sumView + combine [] = [] + combine (x:xs) = x : combine xs + + rec :: [Expr] -> [[Expr]] + rec (a:b:xs) = map (:xs) (g a b) ++ map (a:) (rec (b:xs)) + rec _ = [] + + g :: Expr -> Expr -> [Expr] + g e1 e2 = do + as <- matchM sumView e1 + bs <- matchM sumView e2 + guard (length as > 1 || length bs > 1) + return $ build sumView [ a .*. b | a <- as, b <- bs ] + +------------------------------------------------------- +-- Rewrite Rules + +varToLeft :: Rule (Relation Expr) +varToLeft = doAfter (fmap collectLikeTerms) $ + describe "variable to left" $ + makeRule (lineq, "var-left") $ flip (supply1 "term") minusT $ \eq -> do + (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq) + guard (a/=0) + return (fromRational a * Var x) + +-- factor is always positive due to lcm function +removeDivision :: Rule (Relation Expr) +removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $ + describe "remove division" $ + makeRule (lineq, "remove-div") $ flip (supply1 "factor") timesT $ \eq -> do + xs <- match sumView (leftHandSide eq) + ys <- match sumView (rightHandSide eq) + -- also consider parts without variables + -- (but at least one participant should have a variable) + zs <- forM (xs ++ ys) $ \a -> do + (_, list) <- match productView a + return [ (hasSomeVar a, e) | e <- list ] + let f (b, e) = do + (_, this) <- match (divView >>> second integerView) e + return (b, this) + (bs, ns) = unzip (mapMaybe f (concat zs)) + guard (or bs) + return (fromInteger (foldr1 lcm ns)) + +distributeTimes :: Rule Expr +distributeTimes = describe "distribution multiplication" $ + makeSimpleRuleList (lineq, "distr-times") $ + liftM collectLikeTerms . applyAll distributionT + +distributeDivisionMulti :: IsTerm a => Rule (Context a) +distributeDivisionMulti = describe "distribution division" $ + makeSimpleRule (quadreq, "distr-div") $ apply $ repeat1 $ + somewhere (use (makeRule () distributeDivisionT)) + +distributeDivisionT :: Transformation Expr +distributeDivisionT = makeTrans $ \expr -> do + (xs, r) <- match (divView >>> (toView sumView *** rationalView)) expr + guard (length xs > 1) + let ys = map (/fromRational r) xs + return $ build sumView ys + +merge :: Rule Expr +merge = describe "merge similar terms" $ + makeSimpleRule (lineq, "merge") $ \old -> do + let norm = cleanUpSimple old -- don't use rule just for cleaning up + new = collectLikeTerms norm + f = maybe 0 length . match sumView + guard (f norm > f new) + return new + +simplerLinearFactor :: Rule Expr +simplerLinearFactor = describe "simpler linear factor" $ + makeSimpleRule (polyeq, "simpler-linfactor") $ \expr -> do + let myView = polyNormalForm rationalView >>> second linearPolyView + (x, (a, b)) <- match myView expr + let d = (if a<0 then negate else id) (gcdFrac a b) + guard (a /= 0 && b /= 0 && d `notElem` [1, -1]) + return $ fromRational d * build myView (x, (a/d, b/d)) + +ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a +ruleFromView s v = makeSimpleRule s $ \a -> do + b <- canonical v a + guard (a /= b) + return b + +rhsIsZero :: Rule Expr -> Rule (Equation Expr) +rhsIsZero r = makeSimpleRuleList (showId r) $ \(lhs :==: rhs) -> do + guard (rhs == 0) + a <- applyAll r lhs + return (a :==: rhs) + +constantRight :: View Expr a -> View (Equation Expr) (a, Rational) +constantRight v = makeView f g + where + f (lhs :==: rhs) = liftM2 (,) (match v lhs) (match rationalView rhs) + g (a, r) = build v a :==: build rationalView r + +bothSidesView :: View a b -> View (Equation a) (Equation b) +bothSidesView v = makeView f (fmap (build v)) + where + f (lhs :==: rhs) = liftM2 (:==:) (match v lhs) (match v rhs) + +findFactor :: Monad m => [Rational] -> m Rational +findFactor rs + | null rs = + fail "no factor" + | all ((==1) . denominator) rs = + return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs + | otherwise = + return $ fromIntegral $ foldr1 lcm $ map denominator rs + +parentNotNegCheck :: Rule (Context Expr) +parentNotNegCheck = minorRule $ makeSimpleRule "parent not negate check" $ \c -> + case up c >>= current of + Just (Negate _) -> Nothing + _ -> Just c + +noDivisionConstant :: Rule Expr +noDivisionConstant = makeSimpleRule (lineq, "no-div-con") f + where + f (a :/: b) | hasNoVar b && hasSomeVar a = + return ((1/b) * a) + f _ = Nothing + +-- (a/b) * (c/d) = (a*c)/(b*d) +fractionProduct :: Rule Expr +fractionProduct = makeSimpleRule (polyeq, "fraction-product") $ \expr -> do + ((a, b), (c, d)) <- match (timesView >>> divView *** divView) expr + return ((a .*. c) ./. (b .*. d)) + +defPowerNat :: Rule Expr +defPowerNat = makeSimpleRule (polyeq, "def-power-nat") f + where + f (Sym _ [Var _, _]) = Nothing -- should not work on x^5 + f (Sym s [a, Nat n]) | isPowerSymbol s = + return (build productView (False, replicate (fromInteger n) a)) f _ = Nothing diff --git a/src/Domain/Math/Polynomial/Strategies.hs b/src/Domain/Math/Polynomial/Strategies.hs --- a/src/Domain/Math/Polynomial/Strategies.hs +++ b/src/Domain/Math/Polynomial/Strategies.hs @@ -1,183 +1,194 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.Strategies - ( linearStrategy, linearMixedStrategy, linearStrategyG - , quadraticStrategy, quadraticStrategyG - , higherDegreeStrategy, higherDegreeStrategyG - , findFactorsStrategy, findFactorsStrategyG - ) where - -import Prelude hiding (repeat, replicate, fail) -import Common.Strategy -import Common.Navigator -import Common.Id -import Common.Uniplate (transform) -import Common.View -import Common.Context -import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) -import Domain.Math.Polynomial.Rules -import Domain.Math.Numeric.Views -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Expr -import Domain.Math.Polynomial.CleanUp -import Data.Maybe -import Common.Rewriting - ------------------------------------------------------------- --- Linear equations - -linearStrategy :: LabeledStrategy (Context (Equation Expr)) -linearStrategy = cleanUpStrategy (applyTop (fmap cleanUpSimple)) linearStrategyG - -linearMixedStrategy :: LabeledStrategy (Context (Equation Expr)) -linearMixedStrategy = - let f = applyTop (fmap (transform (simplify mixedFractionView) . cleanUpSimple)) - cfg = [ (byName ruleNormalizeMixedFraction, Reinsert) - , (byName ruleNormalizeRational, Remove) - ] - in cleanUpStrategy f (configureNow (configure cfg linearStrategyG)) - -linearStrategyG :: IsTerm a => LabeledStrategy (Context a) -linearStrategyG = - label "Linear Equation" $ - label "Phase 1" (repeat ( - use removeDivision - <|> multi (showId distributeTimes) (somewhere (useC parentNotNegCheck <*> use distributeTimes)) - <|> multi (showId merge) (once (use merge)))) - <*> label "Phase 2" (repeat ( - (use flipEquation |> use varToLeft) - <|> use (coverUpPlusWith oneVar) - <|> use (coverUpMinusLeftWith oneVar) - <|> use (coverUpMinusRightWith oneVar) - <|> use coverUpTimes - <|> use coverUpNegate - )) - <*> repeat (once - ( use ruleNormalizeRational - <|> remove (use ruleNormalizeMixedFraction) - )) - ------------------------------------------------------------- --- Quadratic equations - -quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) -quadraticStrategy = - cleanUpStrategy (applyTop cleanUpRelations) quadraticStrategyG - -quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a) -quadraticStrategyG = - label "Quadratic Equation Strategy" $ repeat $ - -- Relaxed strategy: even if there are "nice" factors, allow use of quadratic formula - somewhere (generalForm <|> generalABCForm) - |> somewhere zeroForm - |> somewhere constantForm - |> simplifyForm - |> topForm - where - -- ax^2 + bx + c == 0, without quadratic formula - generalForm = label "general form" $ - use commonFactorVar - <|> use noLinFormula - <|> use simplerPolynomial - <|> remove (use bringAToOne) - <|> use niceFactors - <|> use coverUpPower -- to deal with special case x^2=0 - - generalABCForm = label "abc form" $ - useC abcFormula - - zeroForm = label "zero form" $ - use mulZero - - -- expr == c - constantForm = label "constant form" $ - use (coverUpPlusWith oneVar) - <|> use (coverUpMinusLeftWith oneVar) - <|> use (coverUpMinusRightWith oneVar) - <|> use coverUpTimes - <|> use coverUpNegate - <|> use coverUpNumerator - <|> use squareBothSides - <|> use factorLeftAsSquare - - -- simplifies square roots, or do an approximation - simplifyForm = - label "square root simplification" ( - multi (showId simplerSquareRoot) (somewhere (use simplerSquareRoot))) - <|> - remove (label "approximate result" ( - multi (showId ruleApproximate) (somewhere (use ruleApproximate)))) - - topForm = label "top form" $ - somewhere (use cancelTerms <|> use sameFactor) - |> ( somewhere (use sameConFactor) - <|> multi (showId merge) (somewhere (use merge)) - <|> somewhere (use distributionSquare) - <|> multi (showId distributeTimes) (somewhere - (useC parentNotNegCheck <*> use distributeTimes)) - <|> multi (showId distributeDivision) (somewhere - (once (use distributeDivision))) - <|> somewhere (use flipEquation) - ) - |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare)) - ------------------------------------------------------------ --- Higher degree equations - -higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) -higherDegreeStrategy = - cleanUpStrategy (applyTop cleanUpRelations) higherDegreeStrategyG - -higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a) -higherDegreeStrategyG = label "higher degree" $ - higherForm - <*> label "quadratic" quadraticStrategyG - <*> afterSubst - where - higherForm = label "higher degree form" $ repeat $ - somewhere (use allPowerFactors) - |> somewhere ( - use coverUpPower - <|> use mulZero - <|> use sameFactor - <|> use coverUpTimes - <|> use exposeSameFactor - <|> use (coverUpPlusWith oneVar) - <|> use (coverUpMinusLeftWith oneVar) - <|> use (coverUpMinusRightWith oneVar) - <|> use sameConFactor - <|> useC higherSubst) - |> somewhere (use moveToLeft) - - afterSubst = label "afterwards" $ try $ - useC substBackVar <*> repeat (somewhere (use coverUpPower)) - ------------------------------------------------------------ --- Finding factors in an expression - -findFactorsStrategy :: LabeledStrategy (Context Expr) -findFactorsStrategy = cleanUpStrategy (applyTop cleanUpSimple) $ - label "find factors" $ replicate 10 $ try findFactorsStrategyG - -findFactorsStrategyG :: IsTerm a => LabeledStrategy (Context a) -findFactorsStrategyG = label "find factor step" $ - somewhereTimes $ - use niceFactorsNew <|> use commonFactorVarNew - <|> use factorVariablePower <|> use simplerLinearFactor - -somewhereTimes :: IsStrategy f => f (Context a) -> Strategy (Context a) -somewhereTimes = somewhereWith "SomewhereTimes" $ \c -> - if isTimesC c then [0 .. arity c-1] else [] - -isTimesC :: Context a -> Bool -isTimesC = maybe False (isJust . isTimes :: Term -> Bool) . currentT +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Strategies + ( linearStrategy, linearMixedStrategy, linearStrategyG + , quadraticStrategy, quadraticStrategyG + , higherDegreeStrategy, higherDegreeStrategyG + , findFactorsStrategy, findFactorsStrategyG, expandStrategy + ) where + +import Common.Library +import Common.Utils.Uniplate (transform) +import Data.Maybe +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Views + +------------------------------------------------------------ +-- Linear equations + +linearStrategy :: LabeledStrategy (Context (Equation Expr)) +linearStrategy = cleanUpStrategyAfter (applyTop (fmap cleanUpSimple)) linearStrategyG + +linearMixedStrategy :: LabeledStrategy (Context (Equation Expr)) +linearMixedStrategy = + let f = applyTop (fmap (transform (simplify mixedFractionView) . cleanUpSimple)) + cfg = [ (byName ruleNormalizeMixedFraction, Reinsert) + , (byName ruleNormalizeRational, Remove) + ] + in cleanUpStrategyAfter f (configureNow (configure cfg linearStrategyG)) + +linearStrategyG :: IsTerm a => LabeledStrategy (Context a) +linearStrategyG = + label "Linear Equation" $ + label "Phase 1" (repeatS ( + use removeDivision + <|> multi (showId distributeTimes) (somewhere (useC parentNotNegCheck <*> use distributeTimes)) + <|> multi (showId merge) (once (use merge)))) + <*> label "Phase 2" (repeatS ( + (flipEquationS |> use varToLeft) + <|> use (coverUpPlusWith oneVar) + <|> use (coverUpMinusLeftWith oneVar) + <|> use (coverUpMinusRightWith oneVar) + <|> use coverUpTimes + <|> use coverUpNegate + )) + <*> repeatS (once + ( use ruleNormalizeRational + <|> remove (use ruleNormalizeMixedFraction) + )) + +------------------------------------------------------------ +-- Quadratic equations + +quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) +quadraticStrategy = + cleanUpStrategyAfter (applyTop cleanUpRelations) quadraticStrategyG + +quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a) +quadraticStrategyG = + label "Quadratic Equation Strategy" $ repeatS $ + -- Relaxed strategy: even if there are "nice" factors, allow use of quadratic formula + somewhere (generalForm <|> generalABCForm) + |> somewhere zeroForm + |> somewhere constantForm + |> simplifyForm + |> topForm + where + -- ax^2 + bx + c == 0, without quadratic formula + generalForm = label "general form" $ + use commonFactorVar + <|> use noLinFormula + <|> use simplerPolynomial + <|> remove (use bringAToOne) + <|> use niceFactors + <|> use coverUpPower -- to deal with special case x^2=0 + + generalABCForm = label "abc form" $ + useC abcFormula + + zeroForm = label "zero form" $ + use mulZero + + -- expr == c + constantForm = label "constant form" $ + use (coverUpPlusWith oneVar) + <|> use (coverUpMinusLeftWith oneVar) + <|> use (coverUpMinusRightWith oneVar) + <|> use coverUpTimes + <|> use coverUpNegate + <|> use coverUpNumerator + <|> use squareBothSides + <|> use factorLeftAsSquare + + -- simplifies square roots, or do an approximation + simplifyForm = + label "square root simplification" simplerSquareRootMulti + <|> + remove (label "approximate result" ( + multi (showId ruleApproximate) (somewhere (use ruleApproximate)))) + + topForm = label "top form" $ + somewhere (use cancelTerms <|> use sameFactor) + |> ( somewhere (use sameConFactor) + <|> multi (showId merge) (somewhere (use merge)) + <|> somewhere (use distributionSquare) + <|> multi (showId distributeTimes) (somewhere + (useC parentNotNegCheck <*> use distributeTimes)) + <|> finalRule distributeDivisionMulti + <|> somewhere flipEquationS + ) + |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare)) + +----------------------------------------------------------- +-- Higher degree equations + +higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) +higherDegreeStrategy = + cleanUpStrategyAfter (applyTop cleanUpRelations) higherDegreeStrategyG + +higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a) +higherDegreeStrategyG = label "higher degree" $ + higherForm + <*> label "quadratic" quadraticStrategyG + <*> afterSubst + where + higherForm = label "higher degree form" $ repeatS $ + somewhere (use allPowerFactors) + |> somewhere ( + use coverUpPower + <|> use mulZero + <|> use sameFactor + <|> use coverUpTimes + <|> use exposeSameFactor + <|> use (coverUpPlusWith oneVar) + <|> use (coverUpMinusLeftWith oneVar) + <|> use (coverUpMinusRightWith oneVar) + <|> use sameConFactor + <|> useC higherSubst) + |> somewhere (use moveToLeft) + + afterSubst = label "afterwards" $ try $ + useC substBackVar <*> repeatS (somewhere (use coverUpPower)) + +----------------------------------------------------------- +-- Finding factors in an expression + +findFactorsStrategy :: LabeledStrategy (Context Expr) +findFactorsStrategy = cleanUpStrategyAfter (applyTop cleanUpSimple) $ + label "find factors" $ repeatS findFactorsStrategyG + +findFactorsStrategyG :: IsTerm a => LabeledStrategy (Context a) +findFactorsStrategyG = label "find factor step" $ + somewhereTimes $ + use niceFactorsNew <|> use commonFactorVarNew + <|> use factorVariablePower <|> use simplerLinearFactor + +somewhereTimes :: IsStrategy f => f (Context a) -> Strategy (Context a) +somewhereTimes = somewhereWith "SomewhereTimes" $ \c -> + if isTimesC c then [0 .. arity c-1] else [] + +isTimesC :: Context a -> Bool +isTimesC = maybe False (isJust . isTimes :: Term -> Bool) . currentT + +flipEquationS :: IsTerm a => Strategy (Context a) +flipEquationS = use conditionVarsRHS <*> use flipEquation + +----------------------------------------------------------- +-- Expanding factors of an expression + +expandStrategy :: LabeledStrategy (Context Expr) +expandStrategy = cleanUpStrategyAfter (applyTop f . change g) $ + label "expand factors" $ repeatS (somewhere $ + use distributionSquare <|> use merge <|> use distributeTimes <|> + use defPowerNat <|> use noDivisionConstant <|> use fractionProduct) + <*> + try (use ruleNormalizePolynomial) + where -- mergeAlike + f = transform (simplify (listOfPowerFactors "x" rationalView)) + -- . cleanUpSimple + g = simplify (polyRelaxedForm rationalView) 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 @@ -1,104 +1,23 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.Tests (tests) where - -import Common.TestSuite -import Common.View -import Domain.Math.Polynomial.Generators -import Domain.Math.Polynomial.Views -import Domain.Math.Numeric.Views -import Domain.Math.Numeric.Laws -import Test.QuickCheck - ------------------------------------------------------------- --- Testing instances - -tests :: TestSuite -tests = do - let v = viewEquivalent (polyViewWith rationalView) - testNumLawsWith v "polynomial" (sized polynomialGen) - --- see the derivations for the DWO exercise set -{- -seeLE n = printDerivation linearExercise $ concat linearEquations !! (n-1) -seeQE n = printDerivation quadraticExercise $ orList $ return $ build equationView $ concat quadraticEquations !! (n-1) -seeHDE n = printDerivation higherDegreeExercise $ orList $ return $ build equationView $ higherDegreeEquations !! (n-1) - --- test strategies with DWO exercise set -{- -testLE = concat $ zipWith (f linearExercise) [1..] $ concat linearEquations -testQE = concat $ zipWith (f quadraticExercise) [1..] $ map (orList . return . build equationView) $ concat quadraticEquations -testHDE = concat $ zipWith (f higherDegreeExercise) [1..] $ map (orList . return . build equationView) higherDegreeEquations --} -f :: (Show b, Show a) => Exercise a -> b -> a -> [b] -f s n e = map p (g (applyAll (strategy s) (inContext s e))) where - g xs | null xs = error $ show n ++ ": " ++ show e - | otherwise = xs - p a | maybe False (isReady s) (fromContext a) = n - | otherwise = error $ show n ++ ": " ++ show e ++ " => " ++ maybe "??" show (fromContext a) - -randomLE = quickCheck $ forAll (liftM2 (:==:) (sized linearGen) (sized linearGen)) $ \eq -> - (>0) (sum (take 10 $ f linearExercise 1 eq)) -randomQE = quickCheck $ forAll (liftM2 (:==:) (sized quadraticGen) (sized quadraticGen)) $ \eq -> - (>0) (sum (take 10 $ f quadraticExercise 1 (orList [build equationView eq]))) - -{- -eqLE = concat $ zipWith (g linearExercise) [1..] $ concat linearEquations -eqQE = concat $ zipWith (g quadraticExercise) [1..] $ map (orList . return) $ concat quadraticEquations -eqHDE = concat $ zipWith (g higherDegreeExercise) [1..] $ map (orList . return) higherDegreeEquations - -g s n e = map p (h (derivations (derivationTree (strategy s) (inContext e)))) where - h xs | null xs = error $ show n ++ ": " ++ show e - | otherwise = xs - p (a, xs) = case [ (x, y) | x <- ys, y <- ys, Prelude.not (equivalence s x y) ] of - [] -> let l = length xs in l*l - (x, y):_ -> error $ show n ++ ": " ++ show x ++ " is not " ++ show y - where ys = map fromContext (a : map snd xs) --} - --- e1 = match higherDegreeEquationsView $ OrList [(x :==: 2)] where x = Var "x" --- e2 = simplify rationalView (Sqrt ()) - --- goLE = eqTest ineqLinearExercise -goQE = eqTest ineqQuadraticExercise - ---eqTest :: Exercise a -> IO () -eqTest ex = - forM_ (examples ex) $ \eq -> do - let tree = derivationTree (strategy ex) (inContext ex eq) - forM_ (derivations tree) $ \d -> do - let xs = terms d - pp = maybe "??" (prettyPrinter ex) . fromContext - forM [ (a, b) | a <- xs, b <- xs ] $ \(a, b) -> - if equalityIneq a b -- equivalence ex (fromContext a) (fromContext b) - then putChar '.' - else error $ unlines ["", pp a, pp b] - -equalityIneq :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool -equalityIneq ca cb = fromMaybe False $ - liftM2 (equivalence ineqQuadraticExercise) (f ca) (f cb) - where - f = fmap g . fromContext - g | any clipboardHasIneq [ca,cb] = turnIntoEqualTo - | otherwise = id - -clipboardHasIneq :: Context a -> Bool -clipboardHasIneq = isJust . evalCM (\_ -> lookupClipboard "ineq") - -turnIntoEqualTo :: Logic (Relation a) -> Logic (Relation a) -turnIntoEqualTo = g . fmap (\rel -> - leftHandSide rel .==. rightHandSide rel) - where - -- temporary fix - g (p :&&: q) = g p :&&: g q - g (p :||: q) = g p :||: g q - g p = p -} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Tests (tests) where + +import Common.Algebra.Field +import Common.Algebra.Law +import Common.Utils.TestSuite +import Control.Monad +import Domain.Math.Data.Polynomial + +tests :: TestSuite +tests = suite "Polynomial is a commutative ring" $ + forM_ (commutativeRingLaws :: [Law (SafeNum (Polynomial Int))]) $ \p -> + addProperty (show p) p diff --git a/src/Domain/Math/Polynomial/Views.hs b/src/Domain/Math/Polynomial/Views.hs --- a/src/Domain/Math/Polynomial/Views.hs +++ b/src/Domain/Math/Polynomial/Views.hs @@ -1,323 +1,334 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Polynomial.Views - ( polyView, polyViewWith -- polyViewFor, polyViewForWith - , quadraticView, quadraticViewWith --, quadraticViewFor quadraticViewForWith - , linearView, linearViewWith -- linearViewFor linearViewForWith - , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView - , monomialPolyView, binomialPolyView, trinomialPolyView - , polyNormalForm - , linearEquationView, quadraticEquationView, quadraticEquationsView - , higherDegreeEquationsView - ) where - -import Prelude hiding ((^)) -import Control.Monad -import Common.View -import Common.Classes -import Common.Rewriting -import Common.Uniplate (transform, descend, children) -import Common.Utils (distinct) -import Domain.Math.Data.Polynomial -import Domain.Math.Data.Relation -import Domain.Math.Data.OrList -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Equation.CoverUpRules -import Data.Maybe -import qualified Domain.Math.Data.SquareRoot as SQ -import Domain.Math.SquareRoot.Views -import Domain.Math.Power.OldViews (powerFactorViewForWith) - -------------------------------------------------------------------- --- Polynomial view - -polyView :: View Expr (String, Polynomial Expr) -polyView = polyViewWith identity - -polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a) -polyViewWith v = makeView matchPoly (uncurry buildPoly) - where - matchPoly expr = do - pv <- selectVar expr - p <- matchPolyFor pv expr - return (pv, p) - - matchPolyFor pv expr = - case expr of - Var s | pv == s -> Just var - Nat n -> Just (fromIntegral n) - Negate a -> liftM negate (f a) - a :+: b -> liftM2 (+) (f a) (f b) - a :-: b -> liftM2 (-) (f a) (f b) - a :*: b -> liftM2 (*) (f a) (f b) - a :/: b -> do - c <- match v b - guard (c /= 0) - guard (withoutVar pv b) - p <- f a - return (fmap (/c) p) - Sym s [a, n] | isPowerSymbol s -> - liftM2 power (f a) (matchNat n) - _ -> do - guard (withoutVar pv expr) - liftM con (match v expr) - where - f = matchPolyFor pv - - buildPoly pv = - let f (a, n) = build v a .*. (Var pv .^. fromIntegral n) - in build sumView . map f . reverse . terms - - - matchNat expr = do - n <- match integralView expr - guard (n >= 0) - return n - -------------------------------------------------------------------- --- Quadratic view - -quadraticView :: View Expr (String, Expr, Expr, Expr) -quadraticView = quadraticViewWith identity - -quadraticViewWith :: Fractional a => View Expr a -> View Expr (String, a, a, a) -quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> makeView f g - where - f (s, (a, b, c)) = return (s, a, b, c) - g (s, a, b, c) = (s, (a, b, c)) - -------------------------------------------------------------------- --- Linear view - -linearView :: View Expr (String, Expr, Expr) -linearView = linearViewWith identity - -linearViewWith :: Fractional a => View Expr a -> View Expr (String, a, a) -linearViewWith v = polyViewWith v >>> second linearPolyView >>> makeView f g - where - f (s, (a, b)) = return (s, a, b) - g (s, a, b) = (s, (a, b)) - -------------------------------------------------------------------- --- Views on polynomials (degree) - -constantPolyView :: Num a => View (Polynomial a) a -constantPolyView = makeView (isList1 . polynomialList) (buildList . list1) - -linearPolyView :: Num a => View (Polynomial a) (a, a) -linearPolyView = makeView (isList2 . polynomialList) (buildList . list2) - -quadraticPolyView :: Num a => View (Polynomial a) (a, a, a) -quadraticPolyView = makeView (isList3 . polynomialList) (buildList . list3) - -cubicPolyView :: Num a => View (Polynomial a) (a, a, a, a) -cubicPolyView = makeView (isList4 . polynomialList) (buildList . list4) - -------------------------------------------------------------------- --- Views on polynomials (number of terms) - -monomialPolyView :: Num a => View (Polynomial a) (a, Int) -monomialPolyView = makeView (isList1. terms) (buildPairs . list1) - -binomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int)) -binomialPolyView = makeView (isList2 . terms) (buildPairs . list2) - -trinomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int), (a, Int)) -trinomialPolyView = makeView (isList3 . terms) (buildPairs . list3) - --- helpers -buildList :: Num a => [a] -> Polynomial a -buildList = buildPairs . flip zip [0..] . reverse - -buildPairs :: Num a => [(a, Int)] -> Polynomial a -buildPairs as - | null as = 0 - | otherwise = foldl1 (+) (map f as) - where - f (a, n) = con a * power var n - -polynomialList :: Num a => Polynomial a -> [a] -polynomialList p = map (`coefficient` p) [d, d-1 .. 0] - where d = degree p - -list1 :: a -> [a] -list1 a = [a] - -list2 :: (a, a) -> [a] -list2 (a, b) = [a, b] - -list3 :: (a, a, a) -> [a] -list3 (a, b, c) = [a, b, c] - -list4 :: (a, a, a, a) -> [a] -list4 (a, b, c, d) = [a, b, c, d] - -isList1 :: [a] -> Maybe a -isList1 [a] = Just a -isList1 _ = Nothing - -isList2 :: [a] -> Maybe (a, a) -isList2 [a, b] = Just (a, b) -isList2 _ = Nothing - -isList3 :: [a] -> Maybe (a, a, a) -isList3 [a, b, c] = Just (a, b, c) -isList3 _ = Nothing - -isList4 :: [a] -> Maybe (a, a, a, a) -isList4 [a, b, c, d] = Just (a, b, c, d) -isList4 _ = Nothing - -------------------------------------------------------------------- --- Normal form, and list of power factors - -listOfPowerFactors :: Num a => String -> View Expr a -> View Expr [(a, Int)] -listOfPowerFactors pv v = sumView >>> listView (powerFactorViewForWith pv v) - -polyNormalForm :: Num a => View Expr a -> View Expr (String, Polynomial a) -polyNormalForm v = makeView f (uncurry g) - where - f e = do - pv <- selectVar e - xs <- match (listOfPowerFactors pv v) e - guard (distinct (map snd xs)) - return (pv, buildPairs xs) - g pv = build (listOfPowerFactors pv v) . reverse . terms - -------------------------------------------------------------------- --- Normal forms for equations - --- Excludes equations such as 1==1 or 0==1 -linearEquationViewWith :: Fractional a => View Expr a -> View (Equation Expr) (String, a) -linearEquationViewWith v = makeView f g - where - f (lhs :==: rhs) = do - (x, a, b) <- match (linearViewWith v) (lhs - rhs) - return (x, -b/a) - g (x, r) = Var x :==: build v r - -linearEquationView :: View (Equation Expr) (String, Rational) -linearEquationView = linearEquationViewWith rationalView - -quadraticEquationsView:: View (OrList (Equation Expr)) (OrList (String, SQ.SquareRoot Rational)) -quadraticEquationsView = makeView f (fmap g) - where - f eq = do - ors <- switch (fmap (match quadraticEquationView) eq) - return (normalize (join ors)) - - g (x, a) = Var x :==: build (squareRootViewWith rationalView) a - -quadraticEquationView :: View (Equation Expr) (OrList (String, SQ.SquareRoot Rational)) -quadraticEquationView = makeView f g - where - f (lhs :==: rhs) = do - (s, p) <- match (polyViewWith (squareRootViewWith rationalView)) (lhs - rhs) - guard (degree p <= 2) - liftM (fmap ((,) s)) $ - case polynomialList p of - [a, b, c] -> do - discr <- SQ.fromSquareRoot (b*b - SQ.scale 4 (a*c)) - let sdiscr = SQ.sqrtRational discr - twoA = SQ.scale 2 a - case compare discr 0 of - LT -> return false - EQ -> return $ orList [-b/twoA] - GT -> return $ orList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA] - [a, b] -> return $ orList [-b/a] - [a] | a==0 -> return true - _ -> return false - - g ors = - case disjunctions ors of - Nothing -> 0 :==: 0 - Just xs -> - let make (x, a) = Var x .-. build (squareRootViewWith rationalView) a - in build productView (False, map make xs) :==: 0 - -higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr) -higherDegreeEquationsView = makeView f (fmap (:==: 0)) - where - f = Just . normalize . join . fmap make . coverUpOrs - make = orList . filter (not . hasNegSqrt) - . map (cleanUpExpr . distr) . normHDE . sub - sub (a :==: b) = a-b - - distr = transform g - where - g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c) - g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c) - g a = a - -hasNegSqrt :: Expr -> Bool -hasNegSqrt (Sqrt a) = - case match rationalView a of - Just r | r < 0 -> True - _ -> hasNegSqrt a -hasNegSqrt (Sym s [a, b]) | isRootSymbol s = - case (match rationalView a, match integerView b) of - (Just r, Just n) | r < 0 && even n -> True - _ -> hasNegSqrt a || hasNegSqrt b -hasNegSqrt a = - any hasNegSqrt (children a) - -normHDE :: Expr -> [Expr] -normHDE e = - case match (polyViewWith rationalView) e of - Just (x, p) -> normPolynomial x p - Nothing -> fromMaybe [e] $ do - (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0) - return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] - -normPolynomial :: String -> Polynomial Rational -> [Expr] -normPolynomial x p - | degree p == 0 = - [] - | length (terms p) <= 1 = - [Var x] - | degree p == 1 = - [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)] - | degree p == 2 = - let [a,b,c] = [ coefficient n p | n <- [2,1,0] ] - discr = b*b - 4*a*c - sdiscr = SQ.sqrtRational discr - in if discr < 0 then [] else - map ((Var x .+.) . build (squareRootViewWith rationalView)) - [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr) - , SQ.scale (1/(2*a)) (SQ.con b - sdiscr) - ] - | otherwise = - case terms p of - [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> - let list = [(c, 0), (b, 1), (a, e2 `div` e1)] - newp = sum (map (\(y, z) -> scale y (power var z)) list) - sub = map (substitute (x, Var x^fromIntegral e1)) - in concatMap normHDE (sub (normPolynomial x newp)) - [(c, 0), (a, n)] - | odd n -> if c/a >= 0 - then [Var x + root (fromRational (c/a)) (fromIntegral n)] - else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)] - | even n -> if c/a > 0 - then [] - else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n) - , Var x - root (fromRational (abs (c/a))) (fromIntegral n) - ] - _ -> - case factorize p of - ps | length ps > 1 -> concatMap (normPolynomial x) ps - _ -> [build (polyViewWith rationalView) (x, p)] - -substitute :: (String, Expr) -> Expr -> Expr -substitute (s, a) (Var b) | s==b = a +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Views + ( polyView, polyViewWith + , quadraticView, quadraticViewWith --, quadraticViewFor quadraticViewForWith + , linearView, linearViewWith -- linearViewFor linearViewForWith + , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView + , monomialPolyView, binomialPolyView, trinomialPolyView + , polyNormalForm, polyRelaxedForm + , linearEquationView, quadraticEquationView, quadraticEquationsView + , higherDegreeEquationsView, listOfPowerFactors + ) where + +import Common.Classes +import Common.Rewriting +import Common.Utils (distinct) +import Common.Utils.Uniplate (transform, descend, children) +import Common.View +import Control.Monad +import Data.Foldable (foldMap, toList) +import Data.Maybe +import Data.Traversable (mapM) +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Polynomial +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.OldViews (powerFactorViewForWith) +import Domain.Math.SquareRoot.Views +import Prelude hiding ((^)) +import qualified Domain.Math.Data.SquareRoot as SQ +import qualified Prelude + +polyViewWithNew :: View (String, Expr) (String, Polynomial Expr) +polyViewWithNew = makeView matchPoly buildPoly + where + matchPoly (s, expr) = liftM ((,) s) (matchPolyFor s expr) + buildPoly (s, p) = (s, buildPolyFor s p) + + matchPolyFor pv expr = + case expr of + Var s | pv == s -> Just var + Nat n -> Just (fromIntegral n) + Negate a -> liftM negate (f a) + a :+: b -> liftM2 (+) (f a) (f b) + a :-: b -> liftM2 (-) (f a) (f b) + a :*: b -> liftM2 (*) (f a) (f b) + a :/: b -> do + guard (withoutVar pv b) + p <- f a + d <- match rationalView b + guard (d /= 0) + return (fmap (/fromRational d) p) + Sym s [a, n] | isPowerSymbol s -> + liftM2 (Prelude.^) (f a) (matchNat n) + _ -> do + guard (withoutVar pv expr) + return (con expr) + where + f = matchPolyFor pv + + buildPolyFor pv = + let f (a, n) = a .*. (Var pv .^. fromIntegral n) + in build sumView . map f . reverse . terms + + matchNat expr = do + n <- match integerView expr + guard (n >= 0) + return n + +------------------------------------------------------------------- +-- Polynomial view + +polyView :: View Expr (String, Polynomial Expr) +polyView = (f <-> snd) >>> polyViewWithNew + where + f a = (fromMaybe "" (selectVar a), a) + +polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a) +polyViewWith v = polyView >>> second (traverseView v) + +------------------------------------------------------------------- +-- Quadratic view + +quadraticView :: View Expr (String, Expr, Expr, Expr) +quadraticView = quadraticViewWith identity + +quadraticViewWith :: Fractional a => View Expr a -> View Expr (String, a, a, a) +quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> (f <-> g) + where + f (s, (a, b, c)) = (s, a, b, c) + g (s, a, b, c) = (s, (a, b, c)) + +------------------------------------------------------------------- +-- Linear view + +linearView :: View Expr (String, Expr, Expr) +linearView = linearViewWith identity + +linearViewWith :: Fractional a => View Expr a -> View Expr (String, a, a) +linearViewWith v = polyViewWith v >>> second linearPolyView >>> (f <-> g) + where + f (s, (a, b)) = (s, a, b) + g (s, a, b) = (s, (a, b)) + +------------------------------------------------------------------- +-- Views on polynomials (degree) + +constantPolyView :: Num a => View (Polynomial a) a +constantPolyView = makeView (isList1 . polynomialList) (buildList . list1) + +linearPolyView :: Num a => View (Polynomial a) (a, a) +linearPolyView = makeView (isList2 . polynomialList) (buildList . list2) + +quadraticPolyView :: Num a => View (Polynomial a) (a, a, a) +quadraticPolyView = makeView (isList3 . polynomialList) (buildList . list3) + +cubicPolyView :: Num a => View (Polynomial a) (a, a, a, a) +cubicPolyView = makeView (isList4 . polynomialList) (buildList . list4) + +------------------------------------------------------------------- +-- Views on polynomials (number of terms) + +monomialPolyView :: Num a => View (Polynomial a) (a, Int) +monomialPolyView = makeView (isList1. terms) (buildPairs . list1) + +binomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int)) +binomialPolyView = makeView (isList2 . terms) (buildPairs . list2) + +trinomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int), (a, Int)) +trinomialPolyView = makeView (isList3 . terms) (buildPairs . list3) + +-- helpers +buildList :: Num a => [a] -> Polynomial a +buildList = buildPairs . flip zip [0..] . reverse + +buildPairs :: Num a => [(a, Int)] -> Polynomial a +buildPairs as + | null as = 0 + | otherwise = sum (map f as) + where + f (a, n) = con a * var Prelude.^ n + +polynomialList :: Num a => Polynomial a -> [a] +polynomialList p = map (`coefficient` p) [d, d-1 .. 0] + where d = degree p + +list1 :: a -> [a] +list1 a = [a] + +list2 :: (a, a) -> [a] +list2 (a, b) = [a, b] + +list3 :: (a, a, a) -> [a] +list3 (a, b, c) = [a, b, c] + +list4 :: (a, a, a, a) -> [a] +list4 (a, b, c, d) = [a, b, c, d] + +isList1 :: [a] -> Maybe a +isList1 [a] = Just a +isList1 _ = Nothing + +isList2 :: [a] -> Maybe (a, a) +isList2 [a, b] = Just (a, b) +isList2 _ = Nothing + +isList3 :: [a] -> Maybe (a, a, a) +isList3 [a, b, c] = Just (a, b, c) +isList3 _ = Nothing + +isList4 :: [a] -> Maybe (a, a, a, a) +isList4 [a, b, c, d] = Just (a, b, c, d) +isList4 _ = Nothing + +------------------------------------------------------------------- +-- Normal form, and list of power factors + +listOfPowerFactors :: Num a => String -> View Expr a -> View Expr [(a, Int)] +listOfPowerFactors pv v = + toView sumView >>> listView (powerFactorViewForWith pv v) + +-- Generalization +polyForm :: Num a => Bool -> View Expr a -> View Expr (String, Polynomial a) +polyForm relaxed v = makeView f (uncurry g) + where + f e = do + pv <- selectVar e + xs <- match (listOfPowerFactors pv v) e + guard (relaxed || distinct (map snd xs)) + return (pv, buildPairs xs) + g pv = build (listOfPowerFactors pv v) . reverse . terms + +polyNormalForm :: Num a => View Expr a -> View Expr (String, Polynomial a) +polyNormalForm = polyForm False + +-- relaxes the condition that all powers should be distinct +polyRelaxedForm :: Num a => View Expr a -> View Expr (String, Polynomial a) +polyRelaxedForm = polyForm True + +------------------------------------------------------------------- +-- Normal forms for equations + +-- Excludes equations such as 1==1 or 0==1 +linearEquationViewWith :: Fractional a => View Expr a -> View (Equation Expr) (String, a) +linearEquationViewWith v = makeView f g + where + f (lhs :==: rhs) = do + (x, a, b) <- match (linearViewWith v) (lhs - rhs) + return (x, -b/a) + g (x, r) = Var x :==: build v r + +linearEquationView :: View (Equation Expr) (String, Rational) +linearEquationView = linearEquationViewWith rationalView + +quadraticEquationsView:: View (OrList (Equation Expr)) (OrList (String, SQ.SquareRoot Rational)) +quadraticEquationsView = makeView f (fmap g) + where + f = liftM (simplify orSetView . foldMap id) + . Data.Traversable.mapM (match quadraticEquationView) + + g (x, a) = Var x :==: build (squareRootViewWith rationalView) a + +quadraticEquationView :: View (Equation Expr) (OrList (String, SQ.SquareRoot Rational)) +quadraticEquationView = makeView f g + where + f (lhs :==: rhs) = do + (s, p) <- match (polyViewWith (squareRootViewWith rationalView)) (lhs - rhs) + guard (degree p <= 2) + liftM (fmap ((,) s)) $ + case polynomialList p of + [a, b, c] -> do + discr <- SQ.fromSquareRoot (b*b - SQ.scale 4 (a*c)) + let sdiscr = SQ.sqrtRational discr + twoA = SQ.scale 2 a + case compare discr 0 of + LT -> return false + EQ -> return $ singleton (-b/twoA) + GT -> return $ toOrList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA] + [a, b] -> return $ singleton (-b/a) + [a] | a==0 -> return true + _ -> return false + + g xs | isTrue xs = 0 :==: 0 + | otherwise = build productView (False, map make (toList xs)) :==: 0 + where + make (x, a) = Var x .-. build (squareRootViewWith rationalView) a + +higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr) +higherDegreeEquationsView = f <-> fmap (:==: 0) + where + f = simplify orSetView . foldMap make . coverUpOrs + make = toOrList . filter (not . hasNegSqrt) + . map (cleanUpExpr . distr) . normHDE . sub + sub (a :==: b) = a-b + + distr = transform g + where + g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c) + g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c) + g a = a + +hasNegSqrt :: Expr -> Bool +hasNegSqrt (Sqrt a) = + case match rationalView a of + Just r | r < 0 -> True + _ -> hasNegSqrt a +hasNegSqrt (Sym s [a, b]) | isRootSymbol s = + case (match rationalView a, match integerView b) of + (Just r, Just n) | r < 0 && even n -> True + _ -> hasNegSqrt a || hasNegSqrt b +hasNegSqrt a = + any hasNegSqrt (children a) + +normHDE :: Expr -> [Expr] +normHDE e = + case match (polyViewWith rationalView) e of + Just (x, p) -> normPolynomial x p + Nothing -> fromMaybe [e] $ do + (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0) + return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] + +normPolynomial :: String -> Polynomial Rational -> [Expr] +normPolynomial x p + | degree p == 0 = + [] + | length (terms p) <= 1 = + [Var x] + | degree p == 1 = + [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)] + | degree p == 2 = + let [a,b,c] = [ coefficient n p | n <- [2,1,0] ] + discr = b*b - 4*a*c + sdiscr = SQ.sqrtRational discr + in if discr < 0 then [] else + map ((Var x .+.) . build (squareRootViewWith rationalView)) + [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr) + , SQ.scale (1/(2*a)) (SQ.con b - sdiscr) + ] + | otherwise = + case terms p of + [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 -> + let list = [(c, 0), (b, 1), (a, e2 `div` e1)] + newp = sum (map (\(y, z) -> con y * (var Prelude.^ z)) list) + sub = map (substitute (x, Var x^fromIntegral e1)) + in concatMap normHDE (sub (normPolynomial x newp)) + [(c, 0), (a, n)] + | odd n -> if c/a >= 0 + then [Var x + root (fromRational (c/a)) (fromIntegral n)] + else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)] + | even n -> if c/a > 0 + then [] + else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n) + , Var x - root (fromRational (abs (c/a))) (fromIntegral n) + ] + _ -> + case factorize p of + ps | length ps > 1 -> concatMap (normPolynomial x) ps + _ -> [build (polyViewWith rationalView) (x, p)] + +substitute :: (String, Expr) -> Expr -> Expr +substitute (s, a) (Var b) | s==b = a substitute pair expr = descend (substitute pair) expr diff --git a/src/Domain/Math/Power/Equation/Examples.hs b/src/Domain/Math/Power/Equation/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Equation/Examples.hs @@ -0,0 +1,356 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Equation.Examples + ( powerEquations, expEquations, logEquations, higherPowerEquations + , rootEquations, rootEquations2, rootSubstEquations, expEquations2 + ) where + +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Prelude hiding ((^)) + +---------------------------------------------------------- +-- HAVO B applets + +-- Hoofdstuk 7, vergelijkingen met machten algebraisch (6) +powerEquations :: [[Equation Expr]] +powerEquations = + -- los vergelijkingen algebraisch op + let x = Var "x" in + [ [ x^14 :==: 25 + , x^(-7) :==: 110 + , 2*x^3.5 :==: 70 + , 8*x^(-9.2) :==: 1000 + ] + , [ root x 5 :==: 2.9 + , 5 * root x 3 :==: 7 + , root (x^3) 4 :==: 720 + , root (x^2) 5 :==: 5.5 + ] + , [ 4*x^(-12) :==: 28 + , 7*x^5.1 + 16 :==: 100 + , 8*x^(-1.9) - 5 :==: 2 + , 0.8 * x^0.7 + 7 :==: 12.5 + ] + , [ 4*root x 7 + 7 :==: 11.8 + , 9*x^3.2+17 :==: 37 + , 6*x^(-3.1)-9 :==: 12 + , 0.7 * x^(-1.1) + 17 :==: 40 + ] + ] + +-- Hoofdstuk 7, exponentiele vergelijkingen algebraisch (7) +expEquations :: [[Equation Expr]] +expEquations = + -- los exponentiele vergelijkingen algebraisch op + let x = Var "x" in + [ [ 2^x :==: 16 * sqrt 2 + , 2^(x+2) :==: 1/4 + , 3^(x-1) :==: 81 + , 3^(x+5) :==: 243/sqrt 3 + ] + , [ 5^(2-x) :==: 0.04 + , 3^(2*x) :==: 1/9 + , 3^(1-3*x) :==: 81 + , 3^(3*x-2) :==: 3*sqrt 3 + ] + , [ 5*2^(x-1) :==: 20*sqrt 2 + , 6*5^(2-x) :==: 150 + , 2*7^(4*x-1) :==: 98 + , 8*3^(5-2*x) :==: 72*sqrt 3 + ] + , [ 2^x-7 :==: 9 + , 4^(3*x)+5 :==: 69 + , 7*3^(2*x+1) :==: 189 + , 5*2^(1-4*x)+11 :==: 51 + ] + , [ 5^(x-4) :==: (1/5)^(2*x+1) + , 7^(1-2*x) :==: 1 + , 4^(2*x-3) :==: 2*sqrt 2 + , 2*9^(1-2*x) :==: 6*sqrt 3 + ] + ] + +-- Hoofdstuk 7, logaritmische vergelijkingen algebraisch (8) +logEquations :: [[Equation Expr]] +logEquations = + -- los algebraisch op + let x = Var "x" in + [ [ logBase 2 x :==: 7 + , logBase 3 (x-2) :==: 2 + , logBase 4 (x-3) :==: 1+(1/2) + , logBase 5 ((1/10)*x-3) :==: -1 + , logBase x 7 :==: 1 + , logBase x 4 :==: -1 + , logBase 2 (x^2-1) :==: 3 + , logBase (1/3) (1-5*x) :==: -1 + ] + ] + +---------------------------------------------------------- +-- VWO A/C applets + +-- Hoofdstuk 5, hogeremachtswortels (1) +higherPowerEquations :: [[Equation Expr]] +higherPowerEquations = + -- bereken exacte oplossing + let x = Var "x" in + [ [ 2*x^3+9 :==: 19 + , 4*x^5-17 :==: 27 + , 3*x^7+8 :==: 62 + , 5*x^3-1 :==: 9 + , 6-5*x^3 :==: 76 + , 11-7*x^5 :==: 53 + , 4-(1/5)*x^7 :==: 9 + , 18-11*x^7 :==: 62 + ] + , [ (1/2)*x^4+5 :==: 12 + , 5*x^6-37 :==: 68 + , 4*x^8-19 :==: 9 + , 5*x^6+7 :==: 97 + , 18-7*x^4 :==: -38 + , 3+(1/3)*x^6 :==: 7 + , 1-(1/9)*x^8 :==: -4 + , 47+15*x^8 :==: 77 + ] + , [ 18*x^8-11 :==: 7 + , (1/4)*x^6+14 :==: 30 + , 5*x^4+67 :==: 472 + , 5*x^4-1 :==: 4 + , (1/8)*x^7+24 :==: 40 + , (1/5)*x^3+27 :==: 52 + , 32*x^3+18 :==: 22 + , 4*x^3-8 :==: 100 + ] + , [ 14-2*x^3 :==: 700 + , 4-3*x^5 :==: 100 + , 14-11*x^7 :==: 25 + , 1-3*x^5 :==: 97 + ] + -- Geef in twee decimalen nauwkeurig + , [ 3*x^5+7 :==: 15 + , 0.7 * x^4 - 1.3 :==: 2 + , (1/3)*x^7 :==: 720 + ] + ] + +-- Hoofdstuk 5, hogeremachtswortels (2) +rootEquations :: [[Equation Expr]] +rootEquations = + -- Bereken exacte oplossing + let x = Var "x" in + let y = Var "y" in + [ [ x^4 :==: 6 + , root x 4 :==: 6 + , sqrt x :==: 10 + , root x 5 :==: 2 + ] + , [ 3*x^5-1 :==: 20 + , 3*root (x-1) 5 - 1 :==: 20 + , (1/10)*sqrt x + 2 :==: 12 + , (1/5)*x^7+8 :==: 26 + ] + , [ 3*root x 4+2 :==: 14 + , (1/2)*x^8-2 :==: 18 + , 5-2*root x 3 :==: 3 + ] + -- Maak x vrij + , [ y :==: x^5 + , y :==: 2*x^5+4 + , y :==: (1/10)*x^3-6 + , y :==: root x 7 + , y :==: 2*root x 3+8 + , y :==: (1/10)*root x 5-6 + ] + , [ y :==: 3*root x 7-6 + , y :==: (1/4)*x^9-6 + , y :==: 8+(1/2)*root x 3 + ] + ] + +---------------------------------------------------------- +-- VWO B applets + +-- Hoofdstuk 1, wortelvergelijkingen +rootEquations2 :: [[Equation Expr]] +rootEquations2 = + let x = Var "x" in + -- los algebraisch op + [ [ 5-2*sqrt x :==: 1 + , 7-3*sqrt x :==: 5 + , 4-2*sqrt x :==: -3 + , 6-3*sqrt x :==: 2 + ] + , [ 2*sqrt x :==: x + , 2*sqrt x :==: 3*x + , x-3*sqrt x :==: 0 + , 3*x-5*sqrt x :==: 0 + ] + , [ x :==: sqrt (2*x+3) + , x :==: sqrt (3*x+10) + , x :==: sqrt (4*x+21) + , x :==: sqrt (3*x+4) + ] + , [ 5*x :==: sqrt (50*x+75) + , 2*x :==: sqrt (24*x+28) + , 3*x :==: sqrt (27*x-18) + , 2*x :==: sqrt (28*x-40) + , 3*x :==: sqrt (3*x+42) + , 5*x :==: sqrt (49*x+2) + , 3*x :==: sqrt (10*x-1) + , 5*x :==: sqrt (30*x-5) + ] + , [ x-sqrt x :==: 6 + , x-4*sqrt x :==: 12 + , x-sqrt x :==: 12 + , x-sqrt x :==: 2 + , 2*x+sqrt x :==: 3 + , 3*x+4*sqrt x :==: 20 + , 2*x+sqrt x :==: 15 + , 2*x-3*sqrt x :==: 27 + ] + ] + +-- Hoofdstuk 1, wortelvergelijkingen +rootSubstEquations :: [[Equation Expr]] +rootSubstEquations = + let x = Var "x" in + -- los algebraisch op + [ [ 8*x^3+1 :==: 9*x*sqrt x + , 27*x^3 :==: 28*x*sqrt x-1 + , x^3+3 :==: 4*x*sqrt x + , x^3 :==: 10*x*sqrt x-16 + ] + , [ x^3 :==: 6*x*sqrt x+16 + , x^3-24*x*sqrt x :==: 81 + , x^3+x*sqrt x :==: 20 + , x^3-15 :==: 2*x*sqrt x + ] + , [ x^5+32 :==: 33*x^2*sqrt x + , 243*x^5-244*x^2*sqrt x+1 :==: 0 + , 32*x^5+31*x^2*sqrt x :==: 1 + , x^5 :==: 242*x^2*sqrt x+243 + ] + , [ x^5+8 :==: 6*x^2*sqrt x + , x^5 :==: 9*x^2*sqrt x-18 + , x^5 :==: 5*x^2*sqrt x+24 + , x^5+4*x^2*sqrt x :==:12 + ] + ] + +-- Hoofdstuk 5, exponentiele vergelijkingen exact oplossen (1, 2, 2a) +expEquations2 :: [[Equation Expr]] +expEquations2 = + let x = Var "x" in + -- los algebraisch op + -- 1 + [ [ 2^(2*x-1) :==: 1/16 + , 3^(1-x) :==: 81 + , 5^(1-2*x) :==: 1/5 + , (1/2)^(4*x-3) :==: 1/4 + , (1/3)^(5*x+2) :==: 1/3 + , 6^(3*x-2) :==: 1/216 + ] + , [ 2^(3*x+2) :==: 2*sqrt 2 + , 3^(2*x+1) :==: 9*sqrt 3 + , 5^(4*x+3) :==: 625*sqrt 5 + , (1/2)^(x+1) :==: 4 + , (1/3)^(x-3) :==: 3 + , 4^(x+2) :==: 64*root 4 3 + ] + , [ 2^(x+3) :==: (1/2)*root 2 3 + , 3^(4*x+1) :==: 27 + , 5^(-x+2) :==: 1/25 + , (1/2)^(1-x) :==: sqrt 2 + , (1/3)^(x+1) :==: (1/9)*sqrt 3 + , 2^(1-3*x) :==: (1/8)*sqrt 2 + ] + , [ 3*2^x+1 :==: 25 + , 4*3^x-9 :==: 27 + , 2*5^x+4 :==: 14 + , 5*(1/2)^x+11 :==: 51 + , 8*(1/3)^x+27 :==: 99 + , 3*(1/5)^x-35 :==: 40 + ] + , [ 2^(4*x+3) :==: 1 + , (1/2)^(2*x-1) :==: 1 + , 3^(2*x+4) :==: 1 + , (1/3)^(x-3) :==: 1 + , 4^(4*x-7) :==: 1 + , 5^(3*x-6) :==: 1 + ] + -- 2 + , [ 2^(2*x+1) :==: (1/2)^(x+2) + , 4^(2*x-1) :==: 2^(3*x+2) + , 2^(5*x-4) :==: 8^(x-3) + , (1/4)^(2*x+1) :==: 2^(6-2*x) + , (1/3)^(2*x-3) :==: 3^(4*x-3) + , 3^(3*x-2) :==: 9^(2-x) + , 27^(2*x+1) :==: 3^(2*x-5) + , 3^(5*x-1) :==: (1/9)^(2*x-1) + ] + , [ 6^(7*x-3) :==: 36^(2*x+3) + , (1/7)^(2*x-1) :==: 7^(2*x-7) + , 5^(5-2*x) :==: (1/5)^(x+2) + , 25^(4*x+1) :==: 5^(5*x-4) + , 3^(x^2) :==: (1/3)^(2*x) + , (1/2)^(x^2) :==: 2^(2*x) + , 5^(x^2) :==: 25^(3*x) + , 2^(x^2) :==: (1/8)^(-x) + ] + , [ (1/2)^(2-2*x) :==: 4^(3*x+5) + , 8^(x+1) :==: (1/2)^(x+7) + , (1/4)^(x+2) :==: 8^(2*x-1) + , 8^(2*x-3) :==: 16^(2*x+3) + , (1/3)^(x-2) :==: 9^(x+4) + , 9^(2*x-1) :==: 27^(2*x-1) + , (1/9)^(x+3) :==: 27^(2*x+2) + , 27^(3-2*x) :==: (1/3)^(4*x+3) + ] + , [ 4*2^x :==: 2^(3*x-2) + , 2^(5*x-9) :==: (1/8)*2^x + , 3^(4*x+6) :==: 27*3^x + , (1/9)*3^x :==: 3^(2-3*x) + , 3*3^x :==: (1/3)^(2*x+5) + , 4^(x+1) :==: 8*2^x + , (1/2)*2^x :==: (1/2)^x + , 9^(x+2) :==: (1/3)*3^x + ] + , [ (1/5)*5^(3*x-2) :==: 25^(x+1) + , 9*3^(2*x+1) :==: (1/3)^(4*x-3) + , 4^(3*x-5) :==: 8*2^(x+2) + , (1/2)^(3-2*x) :==: (1/4)*2^(3*x-4) + , 2^(x+2)+2^x :==: 40 + , 2^(x+4) :==: 3/4+2^(x+2) + , 2^(x-2)+2^(x+1) :==: 9 + , 2^(x+5)-2^(x+4) :==: 16 + ] + -- 2a + , [ 3^(x+2) :==: 72+3^x + , 3^(x-1)+3^(x+1) :==: 10 + , 3^(x+3)+3^(x+2) :==: 12 + , 3^x-3^(x-1) :==: 54 + ] + , [ 5^(x+1)+5^x :==: 150 + , 5^(x+1) :==: 100+5^x + , 5^(x+2)+5^x :==:1+1/25 + , 5^(x+1)+5^(x+2) :==: 30 + ] + , [ 2^(x+4)-2^(x-2) :==: 63*sqrt 2 + , 3^(x-1)+3^x :==: 12*sqrt 3 + , 5^x-5^(x-1) :==: 4*sqrt 5 + , 2^(x+2)+2^(x-3) :==: 66*sqrt 2 + ] + ] diff --git a/src/Domain/Math/Power/Equation/Exercises.hs b/src/Domain/Math/Power/Equation/Exercises.hs --- a/src/Domain/Math/Power/Equation/Exercises.hs +++ b/src/Domain/Math/Power/Equation/Exercises.hs @@ -1,101 +1,114 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Power.Equation.Exercises - ( powerEqExercise - , expEqExercise - , logEqExercise - , higherPowerEqExercise - ) where - -import Prelude hiding ( (^) ) - -import Common.Context -import Common.Exercise -import Common.View -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Equation.Views -import Domain.Math.Examples.DWO4 -import Domain.Math.Expr hiding (isPower) -import Domain.Math.Numeric.Views -import Domain.Math.Power.Rules -import Domain.Math.Power.Equation.Strategies -import Domain.Math.Power.Equation.NormViews - - ------------------------------------------------------------- --- Exercises - -powerEqExercise :: Exercise (Relation Expr) -powerEqExercise = let precision = 2 in makeExercise - { status = Provisional - , parser = parseExprWith (pRelation pExpr) - , strategy = powerEqApproxStrategy - , navigation = termNavigator - , exerciseId = describe "solve power equation algebraically with x > 0" $ - newId "algebra.manipulation.exponents.equation" - , examples = concatMap (map $ build equationView) $ - powerEquations ++ [last higherPowerEquations] - , isReady = solvedRelation - , isSuitable = (`belongsTo` (normPowerEqApproxView precision)) - , equivalence = viewEquivalent (normPowerEqApproxView precision) - } - -expEqExercise :: Exercise (Equation Expr) -expEqExercise = makeExercise - { status = Provisional - , parser = parseExprWith (pEquation pExpr) - , strategy = expEqStrategy - , navigation = termNavigator - , exerciseId = describe "solve exponential equation algebraically" $ - newId "algebra.manipulation.exponential.equation" - , examples = concat expEquations - , isReady = \ rel -> isVariable (leftHandSide rel) - && rightHandSide rel `belongsTo` rationalView - , isSuitable = (`belongsTo` normExpEqView) - , equivalence = viewEquivalent normExpEqView - , ruleOrdering = ruleOrderingWithId [ getId root2power ] - } - -logEqExercise :: Exercise (OrList (Relation Expr)) -logEqExercise = makeExercise - { status = Provisional - , parser = parseExprWith (pOrList (pRelation pExpr)) - , strategy = logEqStrategy - , navigation = termNavigator - , exerciseId = describe "solve logarithmic equation algebraically" $ - newId "algebra.manipulation.logarithmic.equation" - , examples = map (orList . return . build equationView) (concat logEquations) - , isReady = solvedRelations - , isSuitable = (`belongsTo` (switchView equationView >>> normLogEqView)) - , equivalence = viewEquivalent (switchView equationView >>> normLogEqView) - , ruleOrdering = ruleOrderingWithId [ getId calcPower - , getId calcRoot ] - } - -higherPowerEqExercise :: Exercise (OrList (Equation Expr)) -higherPowerEqExercise = makeExercise - { status = Provisional - , parser = parseExprWith (pOrList (pEquation pExpr)) - , strategy = higherPowerEqStrategy - , navigation = termNavigator - , exerciseId = describe "solve higher power equation algebraically" $ - newId "algebra.manipulation.exponents.equation" - , examples = map (orList . return) $ concat $ init higherPowerEquations - , isReady = solvedRelations - , isSuitable = maybe False and . disjunctions . fmap (`belongsTo` normPowerEqView) - , equivalence = let f = normalize . fmap (simplify normPowerEqView') - in \ x y -> f x == f y - , ruleOrdering = ruleOrderingWithId [ getId calcPower - , getId calcRoot ] +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Equation.Exercises + ( powerEqExercise + , expEqExercise + , logEqExercise + , higherPowerEqExercise + , rootEqExercise + ) where + +import Prelude hiding ( (^) ) + +import Common.Library +import Data.Function (on) +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.Views +import Domain.Math.Expr hiding (isPower) +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Views +import Domain.Math.Power.Equation.Examples +import Domain.Math.Power.Equation.NormViews +import Domain.Math.Power.Equation.Strategies +import Domain.Math.Power.Rules +import Domain.Math.Power.Utils (sortOrList) + +------------------------------------------------------------ +-- Exercises + +powerEqExercise :: Exercise (Relation Expr) +powerEqExercise = let precision = 2 in makeExercise + { status = Provisional + , parser = parseRelExpr + , strategy = powerEqApproxStrategy + , navigation = termNavigator + , exerciseId = describe "solve power equation algebraically with x > 0" $ + newId "algebra.manipulation.exponents.equation" + , examples = level Medium $ concatMap (map $ build equationView) $ + powerEquations ++ [last higherPowerEquations] + , ready = predicateView relationSolvedForm + , suitable = predicateView (normPowerEqApproxView precision) + , equivalence = withoutContext (viewEquivalent (normPowerEqApproxView precision)) + } + +expEqExercise :: Exercise (Equation Expr) +expEqExercise = makeExercise + { status = Provisional + , parser = parseEqExpr + , strategy = expEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve exponential equation algebraically" $ + newId "algebra.manipulation.exponential.equation" + , examples = level Medium $ concat expEquations + , ready = predicate $ \ rel -> isVariable (leftHandSide rel) + && rightHandSide rel `belongsTo` rationalView + , suitable = predicateView normExpEqView + , equivalence = withoutContext (viewEquivalent normExpEqView) + , ruleOrdering = ruleOrderingWithId [getId root2power] + } + +logEqExercise :: Exercise (OrList (Relation Expr)) +logEqExercise = makeExercise + { status = Provisional + , parser = parseOrsRelExpr + , strategy = logEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve logarithmic equation algebraically" $ + newId "algebra.manipulation.logarithmic.equation" + , examples = level Medium $ map (singleton . build equationView) (concat logEquations) + , ready = predicateView relationsSolvedForm + , suitable = predicateView (traverseView equationView >>> normLogEqView) + , equivalence = withoutContext (viewEquivalent (traverseView equationView >>> normLogEqView)) + , ruleOrdering = ruleOrderingWithId [getId calcPower] + } + +higherPowerEqExercise :: Exercise (OrList (Equation Expr)) +higherPowerEqExercise = makeExercise + { status = Provisional + , parser = parseOrsEqExpr + , strategy = higherPowerEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve higher power equation algebraically" $ + newId "algebra.manipulation.exponents.equation" + , examples = level Medium $ map singleton $ concat $ + higherPowerEquations ++ take 3 rootEquations + , ready = predicateView relationsSolvedForm + , suitable = predicateView (traverseView normPowerEqView) + , equivalence = withoutContext (viewEquivalent (normPowerEqView' hasSomeVar >>> higherDegreeEquationsView)) + , ruleOrdering = ruleOrderingWithId [getId calcPower] + } + +rootEqExercise :: Exercise (OrList (Equation Expr)) +rootEqExercise = makeExercise + { status = Provisional + , parser = parseOrsEqExpr + , strategy = rootEqStrategy + , navigation = termNavigator + , exerciseId = describe "solve higher power equation algebraically" $ + newId "algebra.manipulation.exponents.equation" + , examples = level Medium $ map singleton $ concat $ drop 3 rootEquations + , ready = predicateView relationsSolvedForm + , suitable = predicateView (traverseView normPowerEqView) + , equivalence = withoutContext (on (==) (sortOrList . simplify (normPowerEqView' $ elem "x" . vars))) + , ruleOrdering = ruleOrderingWithId [getId calcPower] } - diff --git a/src/Domain/Math/Power/Equation/NormViews.hs b/src/Domain/Math/Power/Equation/NormViews.hs --- a/src/Domain/Math/Power/Equation/NormViews.hs +++ b/src/Domain/Math/Power/Equation/NormViews.hs @@ -1,215 +1,204 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Equation.NormViews -{- ( normPowerEqApproxView - , normPowerEqView - , normExpEqView - , normLogEqView --- , normLogView - ) -} where - -import Common.Classes -import Common.View -import Common.Rewriting hiding (rewrite) -import Control.Arrow ( (>>^) ) -import Control.Monad -import Data.List -import Data.Maybe -import Data.Ratio -import Domain.Math.Approximation -import Domain.Math.Data.OrList -import Domain.Math.Data.PrimeFactors -import Domain.Math.Data.Relation -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Views -import Domain.Math.Power.NormViews -import Domain.Math.Power.Utils -import Domain.Math.Power.Views -import Domain.Math.Simplification hiding (simplify, simplifyWith) - -import Common.Uniplate - --- Change to configurable strategy! -normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr) -normPowerEqApproxView d = makeView f (uncurry (.~=.)) - where - f rel = case relationType rel of - EqualTo -> fmap (second (simplifyWith (precision d) doubleView)) - $ match (equationView >>> normPowerEqView) rel - Approximately -> return (leftHandSide rel, rightHandSide rel) - _ -> Nothing - -normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0! -normPowerEqView = makeView f (uncurry (:==:)) - where - f expr = do - -- selected var to the left, the rest to the right - (lhs :==: rhs) <- varLeft expr >>= constRight - -- match power - (c, ax) <- match (timesView <&> (identity >>^ (,) 1)) $ - simplify normPowerView lhs - (a, x) <- match myPowerView ax - -- simplify, scale and take root - let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x) - return (a, simplify rationalView y) - - myPowerView = powerView - <&> (rootView >>> second (makeView (\a->Just (1 ./. a)) (1 ./.))) - <&> (identity >>^ \a->(a,1)) - -normPowerEqView' :: View (Equation Expr) (Expr, Expr) -- with x>0! -normPowerEqView' = makeView f (uncurry (:==:)) - where - f expr = do - -- selected var to the left, the rest to the right - (lhs :==: rhs) <- varLeft expr >>= constRight - -- match power - (c, (a, x)) <- match unitPowerView lhs - -- simplify, scale and take root - let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x) - return (a, simplify myRationalView y) - -constRight :: Equation Expr -> Maybe (Equation Expr) -constRight (lhs :==: rhs) = do - (vs, cs) <- fmap (partition hasSomeVar) (match sumView lhs) - let rhs' = rhs .+. build sumView (map neg cs) - return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs' - -negateEq :: Equation Expr -> Equation Expr -negateEq (lhs :==: rhs) = - case lhs of - Negate lhs' -> lhs' :==: neg rhs - _ -> lhs :==: rhs - -varLeft :: Equation Expr -> Maybe (Equation Expr) -varLeft (lhs :==: rhs) = do - (vs, cs) <- fmap (partition hasSomeVar) (match sumView rhs) - return $ lhs .+. build sumView (map neg vs) :==: build sumView cs - -scaleLeft :: Equation Expr -> Maybe (Equation Expr) -scaleLeft (lhs :==: rhs) = - match timesView lhs >>= \(c, x) -> return $ - x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c) - -normExpEqView :: View (Equation Expr) (String, Rational) -normExpEqView = makeView f id >>> linearEquationView - where - try g a = fromMaybe a $ g a - f e = do - let (l :==: r) = try scaleLeft $ try constRight e - return $ case match powerView l of - Just (b, x) -> x :==: simplify normLogView (logBase b r) - Nothing -> l :==: r - -normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr)) -normLogEqView = makeView (liftM g . switch . fmap f) id -- AG: needs to be replaced by higherOrderEqView - where - f expr@(lhs :==: rhs) = return $ - case match logView lhs of - Just (b, x) -> x :==: simplify myRationalView (b .^. rhs) - Nothing -> expr - g = fmap (fmap (simplify myRationalView) . simplify normPowerEqView) - . simplify quadraticEquationsView - --- liftToOrListView :: View a b -> View (OrList a) (OrList b) --- liftToOrListView v = makeView (switch . fmap (match v)) () - -normLogView :: View Expr Expr -normLogView = makeView g id - where - g expr = - case expr of - Sym s [x, y] - | isLogSymbol s -> do - b <- match integerView x - let divExp (be, n) = return $ f be y ./. fromInteger n - maybe (Just $ f b y) divExp $ greatestPower b - | otherwise -> Nothing - _ -> Nothing - f b expr= - case expr of - Nat 1 -> Nat 0 - Nat n - | n == b -> Nat 1 - | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) Nat - $ lookup b (allPowers n) - e1 :*: e2 -> f b e1 .+. f b e2 - e1 :/: e2 -> f b e1 .-. f b e2 - Sqrt e -> f b (e .^. (1 ./. 2)) - Negate e -> Negate $ f b e - Sym s [x,y] - | isPowerSymbol s -> y .*. f b x - | isRootSymbol s -> f b (x .^. (1 ./. y)) - _ -> expr - -myRationalView :: View Expr Rational -myRationalView = makeView (return . rewrite simplerPower) id >>> rationalView - -simplerPower :: Expr -> Maybe Expr -simplerPower expr = - case expr of - Sqrt x -> simplerPower $ x .^. (1/2) - Sym s [x, y] - | isRootSymbol s -> simplerPower $ x .^. (1/y) - | isPowerSymbol s -> f - | otherwise -> Nothing - where f | y == 0 || x == 1 = Just 1 - | y == 1 = Just x - | x == 0 = Just 0 - | otherwise = - -- geheel getal - liftM fromRational (match rationalView expr) - `mplus` - -- wortel - do - ry <- match rationalView y - rx <- match rationalView x - guard $ numerator ry == 1 && denominator rx == 1 - liftM fromInteger $ takeRoot (numerator rx) (denominator ry) - `mplus` - -- (a/b)^y -> a^x/b^y - do - (a, b) <- match divView x - return $ build divView (a .^. y, b .^. y) - _ -> Nothing - --- myRationalView = makeView (exprToNum f) id >>> rationalView --- where --- f s [x, y] --- | isDivideSymbol s = --- fracDiv x y --- | isPowerSymbol s = do --- ry <- match rationalView y --- rx <- match rationalView x --- if ry == 0 then return 1 -- 0 --- else if ry == 1 then return rx -- 1 --- else if denominator ry == 1 then -- geheel getal --- let a = x Prelude.^ abs (numerator ry) --- in return $ if numerator ry < 0 then 1 / a else a --- else if numerator ry == 1 then -- breuk / root --- if denominator ry > 1 then --- if denominator rx == 1 then --- takeRoot (numerator rx) (denominator ry) -- breuk/root --- else --- f powerSymbol [numerator rx, ] / f powerSymbol [] --- else --- take --- else -- no calculation --- | isRootSymbol s = do --- n <- match integerView y --- b <- match integerView x --- liftM fromInteger $ lookup b $ map swap (allPowers n) --- f _ _ = Nothing - +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Equation.NormViews + ( normPowerEqApproxView, normExpEqView, normLogEqView + , normPowerEqView, normPowerEqView' + ) where + +import Common.Rewriting hiding (rewrite) +import Common.Utils.Uniplate +import Common.View +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ratio +import Domain.Math.Approximation +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.PrimeFactors +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.Views +import Domain.Math.Power.NormViews +import Domain.Math.Power.Utils +import Domain.Math.Power.Views +import Domain.Math.Simplification hiding (simplify, simplifyWith) +import Prelude hiding ((^)) +import qualified Data.Traversable as T +import qualified Prelude + +normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr) +normPowerEqApproxView d = makeView f (uncurry (.~=.)) + where + f rel = case relationType rel of + EqualTo -> fmap (second (simplifyWith (precision d) doubleView)) + $ match (equationView >>> normPowerEqView) rel + Approximately -> return (leftHandSide rel, rightHandSide rel) + _ -> Nothing + +normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0! +normPowerEqView = makeView f (uncurry (:==:)) + where + f expr = do + -- selected var to the left, the rest to the right + (lhs :==: rhs) <- varLeft hasSomeVar expr >>= constRight hasSomeVar + -- match power + let simpl = simplify normPowerView lhs + (c, ax) = fromMaybe (1, simpl) (match timesView simpl) + (a, x) = fromMaybe (simpl, 1) $ + match powerView ax + `mplus` do + (h, k) <- match rootView ax + return (h, 1 ./. k) + -- simplify, scale and take root + guard $ c /= 0 && x /= 0 + let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x) + return (a, simplify rationalView y) + +normPowerEqView' :: (Expr -> Bool) -> View (OrList (Equation Expr)) (OrList (Equation Expr)) +normPowerEqView' isVar = makeView f id + where -- general clean up, write root as power, try to simplify powers + f = fmap ( fmap (fmap (cleanUpExpr . root2power . simplerPower)) + . catOrList + ) + . T.mapM takeRoot' -- power to left and take root + + root2power (Sym s [x, y]) + | isRootSymbol s = x .^. (1 ./. y) + root2power expr = expr + + takeRoot' expr = do + -- selected var to the left, the rest to the right + (lhs :==: rhs) <- varLeft isVar expr >>= constRight isVar + -- match power + (c, (a, x)) <- match unitPowerView lhs + -- simplify, scale and take root + let rhs' = simplify rationalView $ cleanUpExpr $ rhs ./. c + y <- maybe (Just [rhs' .^. (1 ./. x)]) (tr rhs') $ match integerView x + return $ toOrList $ map (a :==:) y + +tr :: Expr -> Integer -> Maybe [Expr] +tr n x | odd x = case n of + Negate n' -> Just [neg (n' .^. (1 ./. x'))] + _ -> Just [n .^. (1 ./. x')] + | otherwise = case n of + Negate _ -> Nothing + _ -> Just $ let e = n .^. (1 ./. x') in [e, neg e] + where x' = fromInteger x + +constRight :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr) +constRight isVar (lhs :==: rhs) = do + (vs, cs) <- fmap (partition isVar) (match sumView lhs) + let rhs' = rhs .+. build sumView (map neg cs) + return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs' + +negateEq :: Equation Expr -> Equation Expr +negateEq (lhs :==: rhs) = + case lhs of + Negate lhs' -> lhs' :==: neg rhs + _ -> lhs :==: rhs + +varLeft :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr) +varLeft isVar (lhs :==: rhs) = do + (vs, cs) <- fmap (partition isVar) (match sumView rhs) + return $ lhs .+. build sumView (map neg vs) :==: build sumView cs + +scaleLeft :: Equation Expr -> Maybe (Equation Expr) +scaleLeft (lhs :==: rhs) = + match timesView lhs >>= \(c, x) -> return $ + x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c) + +normExpEqView :: View (Equation Expr) (String, Rational) +normExpEqView = makeView f id >>> linearEquationView + where + try g a = fromMaybe a $ g a + f e = do + let (l :==: r) = try scaleLeft $ try (constRight hasSomeVar) e + return $ case match powerView l of + Just (b, x) -> x :==: simplify normLogView (logBase b r) + Nothing -> l :==: r + +normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr)) +normLogEqView = makeView (liftM g . T.mapM f) id + where + f expr@(lhs :==: rhs) = return $ + case match logView lhs of + Just (b, x) -> x :==: b .^. rhs + Nothing -> expr + g = simplify orSetView . fmap (fmap cleaner) . simplify (normPowerEqView' hasSomeVar) + . simplify higherDegreeEquationsView + + -- Quick fix: 4^(3/2) should be simplified to sqrt (4^3), which is 8 + cleaner = cleanUpExpr . transform h . cleanUpExpr + h expr@(Sym s [a, b]) | isPowerSymbol s = + case (match rationalView a, match rationalView b) of + (Just x, Just y) | denominator y /= 1 -> + root (fromRational (x Prelude.^ numerator y)) (fromInteger $ denominator y) + _ -> expr + h expr = expr + +normLogView :: View Expr Expr +normLogView = makeView g id + where + g expr = + case expr of + Sym s [x, y] + | isLogSymbol s -> do + b <- match integerView x + let divExp (be, n) = return $ f be y ./. fromInteger n + maybe (Just $ f b y) divExp $ greatestPower b + | otherwise -> Nothing + _ -> Nothing + f b expr= + case expr of + Nat 1 -> 0 + Nat n + | n == b -> 1 + | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) fromInteger + $ lookup b (allPowers n) + e1 :*: e2 -> f b e1 .+. f b e2 + e1 :/: e2 -> f b e1 .-. f b e2 + Sqrt e -> f b (e .^. (1 ./. 2)) + Negate e -> Negate $ f b e + Sym s [x,y] + | isPowerSymbol s -> y .*. f b x + | isRootSymbol s -> f b (x .^. (1 ./. y)) + _ -> expr + +simplerPower :: Expr -> Expr +simplerPower expr = + case expr of + Sqrt x -> x ^ (1/2) + Sym s [x, y] + | isRootSymbol s -> x ^ (1/y) + | isPowerSymbol s -> f x y + _ -> expr + where + f x y + | y == 0 = 1 + | y == 1 = x + | x == 0 = 0 + | otherwise = fromMaybe expr $ + -- geheel getal + liftM fromRational (match rationalView expr) + `mplus` do + -- breuk + ry <- match rationalView y + rx <- match rationalView x + guard $ denominator rx == 1 && denominator ry /= 1 + fmap fromInteger $ + takeRoot (numerator rx Prelude.^ numerator ry) (denominator ry) + `mplus` do + -- (a/b)^y -> a^y/b^y + (a, b) <- match divView x + return $ build divView (a .^. y, b .^. y) diff --git a/src/Domain/Math/Power/Equation/Rules.hs b/src/Domain/Math/Power/Equation/Rules.hs --- a/src/Domain/Math/Power/Equation/Rules.hs +++ b/src/Domain/Math/Power/Equation/Rules.hs @@ -1,123 +1,136 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Equation.Rules - ( -- * Power equation rules - commonPower, nthRoot, sameBase, equalsOne, greatestPower - , approxPower, reciprocalFor - ) where - -import Common.Transformation -import Common.Rewriting -import Common.View hiding (simplify) -import Control.Monad -import Domain.Math.Approximation (precision) -import qualified Domain.Math.Data.PrimeFactors as PF -import Domain.Math.Data.Relation -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Power.Utils -import Domain.Math.Power.Views -import Domain.Math.Simplification (simplify) - - --- | Identifier prefix -------------------------------------------------------- - -powereq :: String -powereq = "algebra.manipulation.exponents.equation" - --- | Power relation rules ----------------------------------------------------- - --- | a^x = b^y => a^(x/c) = b^(y/c) where c = gcd x y -commonPower :: Rule (Equation Expr) -commonPower = makeSimpleRule (powereq, "common-power") $ \expr -> do - let v = eqView (powerView >>> second integerView) - ((a, x), (b, y)) <- match v expr - let c = gcd x y - guard $ c > 1 - return $ build v ((a, x `div` c), (b, y `div` c)) - --- | a^x = n => a^x = b^e -greatestPower :: Rule (Equation Expr) -greatestPower = makeSimpleRule (powereq, "greatest-power") $ \(lhs :==: rhs) -> do - n <- match integerView rhs - (_, x) <- match (powerView >>> second integerView) lhs - (b, e) <- PF.greatestPower n - guard $ gcd x e > 1 - return $ lhs :==: fromInteger b .^. fromInteger e - --- a^x = c*b^y => a = c*b^(y/x) -nthRoot :: Rule (Equation Expr) -nthRoot = makeSimpleRule (powereq, "nth-root") $ \(lhs :==: rhs) -> do - guard $ hasSomeVar lhs - (a, x) <- match powerView lhs - (c, (b, y)) <- match unitPowerView rhs - return $ a :==: build unitPowerView (c, (b, simplify (y ./. x))) - --- -- root a x = b => a = b^x --- nthPower :: Rule (Equation Expr) --- nthPower = makeSimpleRule (powereq, "nth-power") $ \(lhs :==: rhs) -> do --- guard $ hasSomeVar lhs --- (a, x) <- match rootView lhs --- return $ a :==: rhs .^. x - --- x = a^x => x ~= d -approxPower :: Rule (Relation Expr) -approxPower = makeRule (powereq, "approx-power") $ approxPowerT 2 - --- x = a^x => x ~= d -approxPowerT :: Int -> Transformation (Relation Expr) -approxPowerT n = makeTrans $ \ expr -> - match equationView expr >>= f - where - f (Var x :==: d) = - match doubleView d >>= Just . (Var x .~=.) . Number . precision n - f (d :==: Var x) = - match doubleView d >>= Just . (.~=. Var x) . Number . precision n - f _ = Nothing - --- -- a*x + c = b*y + d => a*x - b*y = d - c (move vars to the left, cons to the right) --- varLeftConRight :: Rule (Equation Expr) --- varLeftConRight = makeSimpleRule (powereq, "var-left-con-right") $ --- \(lhs :==: rhs) -> do --- (xs, cs) <- fmap (partition hasSomeVar) (match sumView lhs) --- (ys, ds) <- fmap (partition hasSomeVar) (match sumView rhs) --- guard $ length cs > 0 || length ys > 0 --- return $ fmap collectLikeTerms $ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Equation.Rules + -- ( -- * Power equation rules + -- commonPower, nthRoot, sameBase, equalsOne, greatestPower + -- , approxPower, reciprocalFor, coverUpRootWith, coverUpRoot + -- ) + where + +import Common.Library hiding (simplify) +import Control.Monad +--import Data.List (partition) +import Domain.Math.Approximation (precision) +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import qualified Domain.Math.Data.PrimeFactors as PF +--import Domain.Math.CleanUp (collectLikeTerms) +import Domain.Math.Polynomial.Rules (distributeTimes, distributeDivisionT) +import Domain.Math.Power.Utils +import Domain.Math.Power.Views +import Domain.Math.Simplification (simplify) + +-- | Identifier prefix -------------------------------------------------------- + +powereq :: String +powereq = "algebra.manipulation.exponents.equation" + +-- | Power relation rules ----------------------------------------------------- + +-- | a^x = b^y => a^(x/c) = b^(y/c) where c = gcd x y +commonPower :: Rule (Equation Expr) +commonPower = makeSimpleRule (powereq, "common-power") $ \expr -> do + let v = eqView (powerView >>> second integerView) + ((a, x), (b, y)) <- match v expr + let c = gcd x y + guard $ c > 1 + return $ build v ((a, x `div` c), (b, y `div` c)) + +-- | a^x = n => a^x = b^e +greatestPower :: Rule (Equation Expr) +greatestPower = makeSimpleRule (powereq, "greatest-power") $ \(lhs :==: rhs) -> do + n <- match integerView rhs + (_, x) <- match (powerView >>> second integerView) lhs + (b, e) <- PF.greatestPower n + guard $ gcd x e > 1 + return $ lhs :==: fromInteger b .^. fromInteger e + +-- a^x = c*b^y => a = c*b^(y/x) +nthRoot :: Rule (Equation Expr) +nthRoot = makeSimpleRule (powereq, "nth-root") $ \(lhs :==: rhs) -> do + guard $ hasSomeVar lhs + (a, x) <- match powerView lhs + (c, (b, y)) <- match unitPowerView rhs + return $ a :==: build unitPowerView (c, (b, simplify (y ./. x))) + +-- x = a^x => x ~= d +approxPower :: Rule (Relation Expr) +approxPower = makeRule (powereq, "approx-power") $ approxPowerT 2 + +-- x = a^x => x ~= d +approxPowerT :: Int -> Transformation (Relation Expr) +approxPowerT n = makeTrans $ \ expr -> + match equationView expr >>= f + where + f (Var x :==: d) = + match doubleView d >>= Just . (Var x .~=.) . fromDouble . precision n + f (d :==: Var x) = + match doubleView d >>= Just . (.~=. Var x) . fromDouble . precision n + f _ = Nothing + +-- a^x = a^y => x = y +sameBase :: Rule (Equation Expr) +sameBase = makeSimpleRule (powereq, "same-base") $ \ expr -> do + ((a, x), (b, y)) <- match (eqView powerView) expr + guard $ a == b + return $ x :==: y + +-- | c*a^x = d*(1/a)^y => c*a^x = d*a^-y +reciprocalFor :: Rule (Equation Expr) +reciprocalFor = makeSimpleRule (powereq, "reciprocal-for-base") $ + \ (lhs :==: rhs) -> do + (_, (a, _)) <- match unitPowerView lhs + (one, _) <- match divView rhs + (d, (a'', y)) <- match consPowerView rhs + guard $ one == 1 && a'' == a + return $ lhs :==: d .*. a'' .^. negate y + +-- | a^x = 1 => x = 0 +equalsOne :: Rule (Equation Expr) +equalsOne = makeSimpleRule (powereq, "equals-one") $ \ (lhs :==: rhs) -> do + guard $ rhs == 1 + (_, x) <- match powerView lhs + return $ x :==: 0 + +----------------------- Move these funcs to right place ---------------------- + +-- add these two functions to coverUpRules? +coverUpRootWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpRootWith = coverUpBinaryRule "root" (isBinary rootSymbol) (.^.) + +coverUpRoot :: Rule (Equation Expr) +coverUpRoot = coverUpRootWith configCoverUp + +-- | Negations are pushed inside +myCoverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr) +myCoverUpTimesWith = doAfter f . coverUpTimesWith + where + f (lhs :==: rhs) = + lhs :==: applyD distributeDivisionT (applyD distributeTimes rhs) + +condXisRight :: Rule (Equation Expr) +condXisRight = describe "flip condition" $ checkRule $ \(lhs :==: rhs) -> + hasVar "x" rhs && withoutVar "x" lhs + +--xToLeft = makeRule (powereq, "x -to-left") $ toLeftRightT $ elem "x" . vars + +-- toLeftRightT :: (Expr -> Bool) -> Transformation (Equation Expr) +-- toLeftRightT p = makeTrans $ +-- \ (lhs :==: rhs) -> do +-- (xs, cs) <- fmap (partition p) (match sumView lhs) +-- (ys, ds) <- fmap (partition p) (match sumView rhs) +-- guard $ length cs > 0 || length ys > 0 +-- return $ fmap collectLikeTerms $ -- build sumView (xs ++ map neg ys) :==: build sumView (ds ++ map neg cs) - --- a^x = a^y => x = y -sameBase :: Rule (Equation Expr) -sameBase = makeSimpleRule (powereq, "same-base") $ \ expr -> do - ((a, x), (b, y)) <- match (eqView powerView) expr - guard $ a == b - return $ x :==: y - --- | c*a^x = d*(1/a)^y => c*a^x = d*a^-y --- this reciprocal rule is more strict, it demands a same base on the lhs --- of the equation. Perhaps do this via the enviroment? -reciprocalFor :: Rule (Equation Expr) -reciprocalFor = makeSimpleRule (powereq, "reciprocal-for-base") $ - \ (lhs :==: rhs) -> do - (_, (a, _)) <- match unitPowerView lhs - (one, _) <- match divView rhs - (d, (a'', y)) <- match consPowerView rhs - guard $ one == 1 && a'' == a - return $ lhs :==: d .*. a'' .^. negate y - --- | a^x = 1 => x = 0 -equalsOne :: Rule (Equation Expr) -equalsOne = makeSimpleRule (powereq, "equals-one") $ \ (lhs :==: rhs) -> do - guard $ rhs == 1 - (_, x) <- match powerView lhs - return $ x :==: 0 - diff --git a/src/Domain/Math/Power/Equation/Strategies.hs b/src/Domain/Math/Power/Equation/Strategies.hs --- a/src/Domain/Math/Power/Equation/Strategies.hs +++ b/src/Domain/Math/Power/Equation/Strategies.hs @@ -1,115 +1,135 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Equation.Strategies - -- ( powerEqStrategy - -- , powerEqApproxStrategy - -- , expEqStrategy - -- , logEqStrategy - -- , higherPowerEqStrategy - -- ) - where - -import Prelude hiding (repeat, not) - -import Common.Classes -import Common.Context -import Common.Id -import Common.Navigator -import Common.Rewriting -import Common.Strategy -import Common.View (belongsTo) -import Control.Arrow -import Data.Maybe -import Domain.Math.Data.Relation -import Domain.Math.Data.OrList -import Domain.Math.Expr -import Domain.Math.Equation.CoverUpExercise -import Domain.Math.Equation.CoverUpRules -import Domain.Math.Polynomial.CleanUp -import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy) -import Domain.Math.Polynomial.Rules (flipEquation) -import Domain.Math.Power.Rules -import Domain.Math.Power.Utils -import Domain.Math.Power.Equation.Rules -import Domain.Math.Numeric.Rules - --- | Strategies --------------------------------------------------------------- - -powerEqStrategy :: IsTerm a => LabeledStrategy (Context a) -powerEqStrategy = cleanUpStrategy clean strat - where - strat = label "Power equation" $ repeat - $ myCoverUpStrategy - <*> option (use greatestPower <*> use commonPower) - <*> use nthRoot - <*> remove (label "useApprox" $ try $ use approxPower) - - clean = applyD $ exhaustiveUse rules - rules = onePower : fractionPlus : naturalRules ++ rationalRules - -powerEqApproxStrategy :: LabeledStrategy (Context (Relation Expr)) -powerEqApproxStrategy = label "Power equation with approximation" $ - configureNow (configure cfg powerEqStrategy) - where - cfg = [ (byName (newId "useApprox"), Reinsert) ] - -expEqStrategy :: LabeledStrategy (Context (Equation Expr)) -expEqStrategy = cleanUpStrategy cleanup strat - where - strat = label "Exponential equation" - $ myCoverUpStrategy - <*> repeat (somewhereNotInExp (use factorAsPower)) - <*> repeat (somewhereNotInExp (use reciprocal)) - <*> powerS - <*> (use sameBase <|> use equalsOne) - <*> linearStrategy - - cleanup = applyD (exhaustiveUse $ naturalRules ++ rationalRules) - . applyTop (fmap (mergeConstantsWith isIntRatio)) - - isIntRatio x = x `belongsTo` myIntegerView || x `belongsTo` v - where v = divView >>> first myIntegerView >>> second myIntegerView - - powerS = exhaustiveUse [ root2power, addExponents, subExponents - , mulExponents, simpleAddExponents ] - -logEqStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) -logEqStrategy = label "Logarithmic equation" - $ use logarithm - <*> try (use flipEquation) - <*> repeat (somewhere $ use nthRoot - <|> use calcPower - <|> use calcPowerPlus - <|> use calcPowerMinus - <|> use calcPlainRoot - <|> use calcPowerRatio) - <*> quadraticStrategy - - -higherPowerEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) -higherPowerEqStrategy = cleanUpStrategy cleanup coverUpStrategy - where - cleanup = applyTop $ fmap $ fmap cleanUpExpr - - - --- | Help functions ----------------------------------------------------------- - -myCoverUpStrategy :: IsTerm a => Strategy (Context a) -myCoverUpStrategy = repeat $ alternatives $ map use coverUpRules - -somewhereNotInExp :: IsStrategy f => f (Context a) -> Strategy (Context a) -somewhereNotInExp = somewhereWith "somewhere but not in exponent" f - where - f a = if isPowC a then [1] else [0 .. arity a-1] - isPowC = maybe False (isJust . isPower :: Term -> Bool) . currentT +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Equation.Strategies + -- ( powerEqStrategy + -- , powerEqApproxStrategy + -- , expEqStrategy + -- , logEqStrategy + -- , higherPowerEqStrategy + -- ) + where + +import Common.Library +import Data.Maybe +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Rules +import Domain.Math.Polynomial.Rules (flipEquation, conditionVarsRHS) +import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy) +import Domain.Math.Power.Equation.Rules +import Domain.Math.Power.Rules +import Domain.Math.Power.Utils + +-- | Strategies --------------------------------------------------------------- + +powerEqStrategy :: IsTerm a => LabeledStrategy (Context a) +powerEqStrategy = cleanUpStrategy clean strat + where + strat = label "Power equation" $ repeatS + $ myCoverUpStrategy + <*> option (use greatestPower <*> use commonPower) + <*> use nthRoot + <*> remove (label "useApprox" $ try $ use approxPower) + + clean = applyD $ exhaustiveUse rules + rules = onePower : fractionPlus : naturalRules ++ rationalRules + +powerEqApproxStrategy :: LabeledStrategy (Context (Relation Expr)) +powerEqApproxStrategy = label "Power equation with approximation" $ + configureNow (configure cfg powerEqStrategy) + where + cfg = [ (byName (newId "useApprox"), Reinsert) ] + +expEqStrategy :: LabeledStrategy (Context (Equation Expr)) +expEqStrategy = cleanUpStrategy cleanup strat + where + strat = label "Exponential equation" + $ myCoverUpStrategy + <*> repeatS (somewhereNotInExp (use factorAsPower)) + <*> repeatS (somewhereNotInExp (use reciprocal)) + <*> powerS + <*> (use sameBase <|> use equalsOne) + <*> linearStrategy + + cleanup = applyD (exhaustiveUse $ naturalRules ++ rationalRules) + . applyTop (fmap (mergeConstantsWith isIntRatio)) + + isIntRatio x = x `belongsTo` myIntegerView || x `belongsTo` v + where v = divView >>> first myIntegerView >>> second myIntegerView + + powerS = exhaustiveUse [ root2power, addExponents, subExponents + , mulExponents, simpleAddExponents ] + +logEqStrategy :: LabeledStrategy (Context (OrList (Relation Expr))) +logEqStrategy = label "Logarithmic equation" + $ try (use logarithm) + <*> try (use conditionVarsRHS <*> use flipEquation) + <*> repeatS (somewhere $ use nthRoot + <|> use calcPower + <|> use calcPowerPlus + <|> use calcPowerMinus + <|> use calcPlainRoot + <|> use calcPowerRatio) + <*> quadraticStrategy + +higherPowerEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +higherPowerEqStrategy = cleanUpStrategy cleanup coverUpStrategy' + where + cleanup = applyTop $ fmap $ fmap cleanUpExpr + +rootEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +rootEqStrategy = cleanUpStrategy cleanup strat + where + strat = label "Cover up" + $ try ( use condXisRight <*> use flipEquation ) + <*> exhaustiveSomewhere myCoverUpRulesOr + cleanup = applyTop $ fmap $ fmap cleanUpExpr + +-- | Help functions ----------------------------------------------------------- + +myCoverUpStrategy :: IsTerm a => Strategy (Context a) +myCoverUpStrategy = repeatS $ alternatives $ map use coverUpRules + +coverUpStrategy' :: LabeledStrategy (Context (OrList (Equation Expr))) +coverUpStrategy' = cleanUpStrategy (applyTop $ fmap $ fmap cleanUpExpr) $ + label "Cover-up" $ + repeatS $ somewhere $ alternatives $ use coverUpRoot : coverUpRulesOr + +somewhereNotInExp :: IsStrategy f => f (Context a) -> Strategy (Context a) +somewhereNotInExp = somewhereWith "somewhere but not in exponent" f + where + f a = if isPowC a then [1] else [0 .. arity a-1] + isPowC = maybe False (isJust . isPower :: Term -> Bool) . currentT + +myConfigCoverUp :: ConfigCoverUp +myConfigCoverUp = configCoverUp + { configName = "" + , predicateCovered = elem "x" . vars + , predicateCombined = notElem "x" . vars + , coverLHS = True + , coverRHS = True + } + +myCoverUpRulesOr :: IsTerm a => [Rule (Context a)] +myCoverUpRulesOr = use (coverUpPowerWith myConfigCoverUp) + : map (\f -> use $ f myConfigCoverUp) coverUpRulesWith + +coverUpRulesWith :: [ConfigCoverUp -> Rule (Equation Expr)] +coverUpRulesWith = + [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith + , coverUpNegateWith, {-myCoverUpTimesWith-} coverUpTimesWith, coverUpNumeratorWith + , coverUpDenominatorWith, coverUpSqrtWith, coverUpRootWith + ] diff --git a/src/Domain/Math/Power/Examples.hs b/src/Domain/Math/Power/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Examples.hs @@ -0,0 +1,482 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO), +-- see: http://www.fi.uu.nl/dwo/gr/frameset.html. +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Examples where + +import Common.Rewriting +import Domain.Math.Expr +import Prelude hiding ((^)) + +---------------------------------------------------------- +-- HAVO B, hfd 7 applets + +simplerPowers :: [[Expr]] +simplerPowers = [level1, level2, level3, level4] + where + a = variable "a" + b = variable "b" + level1 = + [ 4*a^3 * 5*a^2 + , 14*a^6 / (-2*a^3) + , -21*a^7 / (3*a) + , 5*a * (-3)*a^2 * 2*a^3 + ] + + level2 = + [ a^2 * (-2*a)^3 + , (2*a)^5 / (-4*a)^2 + , (2*a)^4 * (-3)*a^2 + , (-3*a)^4 / (9*a^2) + ] + + level3 = + [ (a^2 * b^3)^7 + , -a^3 * (2*b)^5 * a^2 + , 3*a * (-2*b)^3 * (-a*b)^2 + , (2*a*b^3)^2 * (-3*a^2*b)^3 + ] + + level4 = + [ ((1/2)*a)^3 - (4*a)^2 * (1/4)*a + , (2*a)^5 + ((1/3)*a)^2 * (-3*a)^3 + , (2*a^3)^4 - 6*a^3 * (-a^3)^3 + , (-2*a^3)^2 - 6*(3*a)^2 * (-4*a^4) + ] + +powersOfA :: [[Expr]] +powersOfA = [level1, level2, level3, level4] + where + a = variable "a" + level1 = + [ a^3 * a^(-4) + , a^4 * (1/a^2) + , a^(-1) * a^5 + , (1/a^3) * a + ] + + level2 = + [ (a^(-2))^3 + , (a^(-3))^4 + , (1/a^6) * a^(-2) + , (1/a^2) * (1/a^4) + ] + + level3 = + [ (a^(-2))^3 * (1/a^4) + , (1/a^3)^2 + , (a^3)^2 * (1/a) + , (a^(-2))^(-3) * a^(-4) + ] + + level4 = + [ (a^(-1))^2 / a^3 + , (a^2)^(-3) / a^(-1) + , ((a^(-2))^4 / (a^2)^3) * a + , (1/a^(-3))^4 * (1/a)^3 + ] + +nonNegExp :: [[Expr]] +nonNegExp = [level1, level2] + where + a = variable "a" + b = variable "b" + level1 = + [ a * b^(-2) + , a^(-1) * b^2 + , a^(-2) * b^(-3) + , (1/a^(-3)) * (b^(-2))^2 + ] + + level2 = + [ (1/(a*b)^(-2)) * a * b^(-1) + , (2*a)^(-1) / (4*b)^(-2) + , (4*a*b)^(-1) * (b^2)^(-3) + , (5*a)^(-2) * 10*b^(-1) + ] + +-- schrijf als een macht van x +powersOfX :: [[Expr]] +powersOfX = + [ [root x 3, 1/root x 4, sqrt (1/x), (x^2) / root (x^2) 5] + , [sqrt x/(x^2), root (x/(x^3)) 3, x*root x 3, root x 3 * root (1/(x^2)) 4] + ] + where + x = Var "x" + +-- Schrijf zonder negatieve of gebroken exponenten +nonNegExp2 :: [[Expr]] +nonNegExp2 = + [ [ 4^(1/3), 5^(-(1/4)), 5*a^(1/2), 3*a^(-(1/4))] + , [ 4/(a^(-1)*b^(1/3)), a^(-1)/(8*b^(-(2/3))) + , 1/(3*a^(2/5)*b^(-1)), 3*a^(1/4)*b^(-(1/2)) + ] + ] + where + a = Var "a" + b = Var "b" + +---------------------------------------------------------- +-- VWO A/C applets, hfd 5 + +-- herleid +powers1 :: [[Expr]] +powers1 = + [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7 + , 2*a^4*5*a^3, 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a + ] + , [ 5*a^4*(1/a), 8*a^4*(1/2*a^2), 2*a^6*(6/a^4), a^2*(8/a) + , (4*a^3)/(a^5), a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3) + ] + , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3 + , (-a^6)^5, (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4 + ] + , [ 6*a^5+7*a^5-4*a^9, 8*a^2-4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2 + , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7 + , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3 + ] + , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2 + , 6*a^7*(2*a^4)^3, a^17/((a^3)^5), a^9/((a^3)^2) + , a^14/((a^2)^4), a^16/((a^5)^3) + ] + ] + where + a = Var "a" + +-- herleid +powers2 :: [[Expr]] +powers2 = + [ [ 4*a^3*5*a^2, (14*a^6)/(-2*a^3), (-21*a^7)/(3*a) + , 5*a*(-3*a^2)*(2*a^3) + ] + , [ a^2*(-2*a)^3, (2*a)^5/(-4*a)^2 + , (2*a)^4*(-3*(a^2)), (-3*a)^4/(9*a^2) + ] + , [ (a^2*b^3)^7, (-a)^3*(2*b)^5*a^2 + , 3*a*(-2*b)^3*(-a*b)^2, (2*a*b^3)^2*(-3*a^2*b)^3 + ] + , [ (2*a^3)^4-6*a^3*(-a^3)^3, (-2*a^3)^2-6*(3*a)^2*(-4*a^4) + ] + ] + where + a = Var "a" + b = Var "b" + +negExp1 :: [[Expr]] +negExp1 = + [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5 + , (1/a^3)/a, a/a^7, (1/a^2)/a + ] + , [ (1/(a^4))/a^6, (1/(a^3))/a^5, (1/a^5)/a^2, 1/(a^4)/a^3 + , 1/a^3, 1/a^5, 1/a^(-4), 1/a^(-6) + ] + , [ a^8/(1/a^2), a^4/(1/a^4), (a^6)/(1/a^5), a^3/(1/a^6) + , 1/(a^3)/a^(-2), (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8) + ] + ] + where + a = Var "a" + +negExp2 :: [[Expr]] +negExp2 = + [ [ a^3*a^(-4), a^4*(1/a^2), a^(-1)*a^5, (1/a^3)*a] + , [ (a^(-2))^3,(a^(-3))^4, (1/a^6)*a^(-2), (1/a^2)*(1/a^4)] + , [ (a^(-2))^3*(1/a^4), (1/a^3)^2, (a^3)^2*(1/a), (a^(-2))^(-3)*a^(-4)] + , [ (a^(-1))^2/a^3, (a^2)^(-3)/a^(-1), ((a^(-2))^4/(a^2)^3)*a + , (1/a^(-3))^4*(1/a)^3 + ] + ] + where + a = Var "a" + +negExp3 :: [[Expr]] +negExp3 = + [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5) + , (1/4)^(-3), (1/7)^(-2), (1/2)^(-4), (1/3)^(-4) + ] + , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1) + , 5*3^(-2), 7*2^(-5), 6*5^(-2), 4*7^(-2) + ] + , [ (1/3)/(6^(-2)), (1/2)/(8^(-2)), (1/8)/4^(-2), (1/10)/5^(-2) -- original in negExp5 + , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3) + ] + ] + +negExp4 :: [[Expr]] +negExp4 = + [ [ a*b^(-2), a^(-1)*b^2, a^(-2)*b^(-3), (1/a^(-3))*(b^(-2))^2] + , [ (1/((a*b)^(-2)))*a*b^(-1), (2*a)^(-1)/(4*b)^(-2) + , (4*a*b)^(-1)*(b^2)^(-3), (5*a)^(-2) * 10*b^(-1) + ] + ] + where + a = Var "a" + b = Var "b" + +negExp5 :: [[Expr]] +negExp5 = + [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3) + , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3) + ] + , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7) + , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2) + ] + , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5) + , 9*a^(-7)*(2*b)^(-4), (a^5) / ((2*b)^(-2)), ((2*a)^(-3))/b^2 + , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4) + ] + ] + where + a = Var "a" + b = Var "b" + +brokenExp1, brokenExp1' :: [[Expr]] +brokenExp1 = + [ [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5) + , 4*a^(2/3), 2*a^(3/4), 3*a^(2/5), 4*a^(3/5) + ] + , [ 6*a^(-(1/2)), 4*a^(-(1/3)), 2*(3*a)^(-(1/4)), (3*a)^(-(1/5)) + , 5*a^(-(2/3)), 7*a^(-(3/4)), 6*a^(-(2/5)), 2*a^(-(3/7)) + ] + , [ (1/2)*a^(1/3)*b^(-(1/2)), (1/7)*a^(-(1/4))*b^(2/3), 4*a^(1/2)*b^(-(1/5)) + , 3*a^(-(3/5))*b^(1/3), (2*a)^(-(2/3)), (6*a)^(-(2/5)) + , (3*a)^(-(3/5)), (2*a)^(-(4/7)) + ] + ] + where + a = Var "a" + b = Var "b" + +brokenExp1' = + [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7 + , a*root (a^2) 3, a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6 + ] + , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3) + , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3) + ] + ] + where + a = Var "a" + +brokenExp2 :: [[Expr]] +brokenExp2 = + [ [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5 + , sqrt (a^6), root (a^6) 3, sqrt (a^4), root (a^9) 3 + ] + , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a/(1/a^2) + , root a 3/(1/a^5), (a^2*sqrt a)/(a*root a 3) + , (a^3*sqrt a)/(a^2*root (a^2) 3), (a^2*root a 5)/(a^3*root a 3) + , (a^4*root a 3)/(a^6*sqrt a) + ] + ] + where + a = Var "a" + +brokenExp3 :: [[Expr]] +brokenExp3 = + [ [root x 3, 1/root x 4, sqrt (1/x), x^2/root (x^2) 5] + , [sqrt x/x^2, root (x/x^3) 3, x*root x 3, root x 3*root (1/x^2) 4] + ] + where + x = Var "x" + +---------------------------------------------------------- +-- VWO B applets (hoofdstuk 4) + +-- herleiden van wortelvormen +normSqrt1 :: [[Expr]] +normSqrt1 = + [ [ 9*sqrt 5 * 7*sqrt 3, 3*sqrt 2 * 2 * sqrt 5, 5*sqrt 2*6*sqrt 7 + , 4*sqrt 6 * 2*sqrt 7, 6*a*sqrt 3*9*sqrt 2, 5*sqrt 5 * 2 * a * sqrt 7 + , a*sqrt 6 * 7 * sqrt 5, 8*sqrt 7*a*sqrt 3 + ] + , [ sqrt 15/(6*sqrt 3), (5*sqrt 30)/sqrt 5, (4*sqrt 10)/(5*sqrt 2) + , (5*sqrt 21)/(2*sqrt 7), (6*a*sqrt 35)/(3*sqrt 5), (5*a*sqrt 14)/(9*sqrt 2) + , (a*sqrt 6)/(7*sqrt 3), (3*a*sqrt 42)/(7*sqrt 7) + ] + , [ 5/(2*sqrt 2), 2/(5*sqrt 3), 3/(2*sqrt 5), 8/(7*sqrt 6), (2*a)/(3*sqrt 7) + , (6*a)/(7*sqrt 10), (5*a)/(3*sqrt 11), (6*a)/(5*sqrt 13) + ] + , [ sqrt (2/3), sqrt (5+1/3), sqrt (1+1/2), sqrt (3+4/7), sqrt (5*a^2) + , sqrt (7*a^2), sqrt (3*a^2), sqrt (6*a^2) + ] + , [ sqrt ((2/9)*a^2), sqrt ((5/16)*a^2), sqrt ((3/25)*a^2), sqrt ((7/16)*a^2) + , ((1/3)*sqrt 2)^2, ((1/2)*sqrt 3)^2, ((2/7)*sqrt 5)^2, ((2/3)*sqrt 7)^2 + ] + ] + where + a = Var "a" + +normSqrt2 :: [[Expr]] +normSqrt2 = + [ [ ((1/7)*a*sqrt 2)^2, ((3/5)*a*sqrt 3)^2, ((1/3)*a*sqrt 5)^2 + , ((4/7)*a*sqrt 6)^2, sqrt 8 + sqrt 2, sqrt 2 + sqrt 18 + , sqrt 12 - sqrt 3, sqrt 7 - sqrt 28 + ] + , [ sqrt 12 + sqrt 48, sqrt 18 - sqrt 8, sqrt 45 - sqrt 20, sqrt 80 + sqrt 45 + , sqrt (50*a^2) - sqrt (32*a^2), sqrt (75*a^2) - sqrt (12*a^2) + , sqrt (27*a^2) + sqrt (3*a^2), sqrt (24*a^2) + sqrt (96*a^2) + ] + , [ sqrt 27 + 1/sqrt 3, sqrt 24 + 5/sqrt 6, sqrt 72 - 7/sqrt 2 + , sqrt 98 - 5/sqrt 2, sqrt 24 + sqrt (1+1/2), sqrt 40 - sqrt (2+1/2) + , sqrt 75 - sqrt (1+1/3), sqrt (1+2/3) + sqrt 60 + ] + ] + where + a = Var "a" + +normSqrt3 :: [[Expr]] +normSqrt3 = + [ [ (2*sqrt 7 + 7*sqrt 3)^2, (sqrt 2+6*sqrt 3)^2, (4*sqrt 3 + 3*sqrt 2)^2 + , (2*sqrt 5 + sqrt 7)^2, (3*sqrt 6-4*sqrt 5)^2, (5*sqrt 3 - sqrt 2)^2 + , (4*sqrt 6 - 2*sqrt 7)^2, (sqrt 5 - 2*sqrt 3)^2 + ] + , [ (2*sqrt 3 - 2)^2, (5*sqrt 2-1)^2, (3+4*sqrt 3)^2, (2+3*sqrt 6)^2 + , (4*sqrt 2 + 3)*(4*sqrt 2 - 3), (sqrt 7+sqrt 3)*(sqrt 7-sqrt 3) + , (2*sqrt 2 - sqrt 5)*(2*sqrt 2 + sqrt 5), (6-3*sqrt 3)*(6+3*sqrt 3) + ] + , [ (a-sqrt 3)^2, (2*sqrt 6+a)^2, (2*a+a*sqrt 5)^2, (a*sqrt 3 - 2*a*sqrt 2)^2 + , (a-sqrt 7)*(a+sqrt 7), (3*a+2*sqrt 3)*(3*a-2*sqrt 3) + , (2*a+a*sqrt 2)*(2*a-a*sqrt 2), (3*a*sqrt 5 - a)*(3*a*sqrt 5 + a) + ] + , [ 4/ (sqrt 2 + 2), 3/(sqrt 5 + 1), 2 / (sqrt 3 - 3), 5/(sqrt 6-2) + , 6/(sqrt 7+sqrt 5), 4/(2*sqrt 3 + sqrt 6), 5/(3*sqrt 2 - sqrt 3) + , 2 / (sqrt 11 - sqrt 2) + ] + , [ (2*sqrt 3)/(sqrt 5 + sqrt 2), (6*sqrt 5)/(sqrt 7+sqrt 3) + , (4*sqrt 3)/(sqrt 5 - sqrt 3), (8*sqrt 7)/(sqrt 6 - sqrt 5) + ] + ] + where + a = Var "a" + +-- Machten herleiden +normPower1 :: [[Expr]] +normPower1 = + [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7, 2*a^4*5*a^3 + , 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a + ] + , [ 5*a^4*(1/a), 8*a^4*(1/(2*a^2)), 2*a^6*(6/a^4), a^2*8/a + , (4*a^3)/a^5, a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3) + ] + , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3, (-(a^6))^5 + , (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4 + ] + , [ 6*a^5 + 7*a^5 - 4*a^9, 8*a^2 - 4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2 + , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7 + , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3 + ] + , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2, 6*a^7*(2*a^4)^3 + , a^17/(a^3)^5, a^9/(a^3)^2, a^14/(a^2)^4, a^16/(a^5)^3 + ] + ] + where + a = Var "a" + +normPower2 :: [[Expr]] +normPower2 = + [ -- one level only + [ (3*a)^3+4*a^3, (2*a^2)^3 +(4*a^3)^2, (-2*a^6)^2+(a^2)^6 + , (-3*a^2)^3+(4*a^3)^2, (4*a*b^2)^2, (2*a^2*b^3)^3 + , (3*a^2*b)^2, (-3*a^2*b^2)^4 + ] + ] + where + a = Var "a" + b = Var "b" + +normPower3, normPower3' :: [[Expr]] +normPower3 = + [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5, (1/a^3)/a, a/a^7, (1/a^2)/a + ] + , [ (1/a^4)/a^6, (1/a^3)/a^5, (1/a^5)/a^2, (1/a^4)/a^3, 1/a^3, 1/a^5 + , 1/a^(-4), 1/a^(-6) + ] + , [ a^8/(1/a^2), a^4/(1/a^4), a^6/(1/a^5), a^3/(1/a^6), (1/a^3)/a^(-2) + , (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8) + ] + ] + where + a = Var "a" +normPower3' = -- bereken zonder rekenmachine + [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5), (1/4)^(-3), (1/7)^(-2) + , (1/2)^(-4), (1/3)^(-4) + ] + , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1), 5*3^(-2), 7*2^(-5) + , 6*5^(-2), 4*7^(-2) + ] + ] + +normPower4, normPower4' :: [[Expr]] +normPower4 = + [ -- bereken zonder rekenmachine + [ (1/3)/6^(-2), (1/2)/8^(-2), (1/8)/4^(-2), (1/10)/5^(-2) + , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3) + ] + ] +normPower4' = -- schrijf zonder negatieve exponenten + [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3) + , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3) + ] + , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7) + , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2) + ] + , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5) + , 9*a^(-7)*(2*b)^(-4), a^5/(2*b)^(-2), (2*a)^(-3)/b^2 + , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4) + ] + ] + where + a = Var "a" + b = Var "b" + +normPower5, normPower5' :: [[Expr]] +normPower5 = + [ -- schrijf zonder negatieve en gebroken exponent + [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5), (4*a)^(2/3) + , 2*a^(3/4), (3*a)^(2/5), 4*a^(3/5) + ] + , [ 6*a^(-1/2), 4*a^(-1/3), 2*(3*a)^(-1/4), (3*a)^(-1/5), 5*a^(-2/3) + , 7*a^(-3/4), 6*a^(-2/5), 2*a^(-3/7) + ] + , [ (1/2)*a^(1/3)*b^(-1/2), (1/7)*a^(-1/4)*b^(2/3), 4*a^(1/2)*b^(-1/5) + , 3*a^(-3/5)*b^(1/3), (2*a)^(-2/3), (6*a)^(-2/5), (3*a)^(-3/5), (2*a)^(-4/7) + ] + ] + where + a = Var "a" + b = Var "b" +normPower5' = -- schrijf als macht van a + [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7, a*root (a^2) 3 + , a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6 + ] + , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3) + , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3) + ] + ] + where + a = Var "a" + +normPower6 :: [[Expr]] +normPower6 = + [ -- schrijf als macht van a + [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5, sqrt (a^6) + , root (a^6) 3, sqrt (a^4), root (a^9) 3 + ] + , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a / (1/a^2), root a 3/(1/a^5) + , (a^2*sqrt a)/(a*root a 3), (a^3*sqrt a)/(a^2*root (a^2) 3) + , (a^2*root a 5)/(a^3*root a 3), (a^4*root a 3)/(a^6*sqrt a) + ] + ] + where + a = Var "a" 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 @@ -1,132 +1,159 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Exercises - ( -- * Power exercises - simplifyPowerExercise - , powerOfExercise - , nonNegBrokenExpExercise - , calcPowerExercise - ) where - -import Prelude hiding ( (^) ) - -import Common.Classes -import Common.Context -import Common.Exercise -import Common.Navigator -import Common.Rewriting -import Common.Strategy hiding (not, replicate) -import Common.Utils (distinct) -import Common.View -import Data.Maybe -import Domain.Math.Examples.DWO3 -import Domain.Math.Expr hiding (isPower) -import Domain.Math.Numeric.Views -import Domain.Math.Power.Rules -import Domain.Math.Power.Strategies -import Domain.Math.Power.NormViews -import Domain.Math.Power.Views - - --- | Exercises ---------------------------------------------------------------- - -powerExercise :: LabeledStrategy (Context Expr) -> Exercise Expr -powerExercise s = makeExercise - { status = Provisional - , parser = parseExpr - , navigation = navigator - , strategy = s - } - -simplifyPowerExercise :: Exercise Expr -simplifyPowerExercise = (powerExercise simplifyPowerStrategy) - { exerciseId = describe "simplify expression (powers)" $ - newId "algebra.manipulation.exponents.simplify" - , isReady = isPowerAdd - , isSuitable = (`belongsTo` normPowerMapView) - , equivalence = viewEquivalent normPowerMapView - , examples = concat $ simplerPowers - ++ powers1 ++ powers2 - ++ negExp1 ++ negExp2 - ++ normPower1 ++ normPower2 ++ normPower3 - , ruleOrdering = ruleOrderingWithId $ map getId - [ root2power, subExponents, reciprocalVar, addExponents - , mulExponents, distributePower ] - } - -powerOfExercise :: Exercise Expr -powerOfExercise = (powerExercise powerOfStrategy) - { exerciseId = describe "write as a power of a" $ - newId "algebra.manipulation.exponents.powerof" - , isReady = isSimplePower - , isSuitable = (`belongsTo` normPowerView) - , equivalence = viewEquivalent normPowerNonNegRatio - , examples = concat $ powersOfA ++ powersOfX - ++ brokenExp1' ++ brokenExp2 ++ brokenExp3 - ++ normPower5' ++ normPower6 - , ruleOrdering = ruleOrderingWithId $ map getId - [ root2power, addExponents, subExponents, mulExponents - , distributePower, reciprocalVar ] - } - -nonNegBrokenExpExercise :: Exercise Expr -nonNegBrokenExpExercise = (powerExercise nonNegBrokenExpStrategy) - { exerciseId = describe "write with a non-negative exponent" $ - newId "algebra.manipulation.exponents.nonnegative" - , isReady = isPower plainNatView - , isSuitable = (`belongsTo` normPowerNonNegDouble) - , equivalence = viewEquivalent normPowerNonNegDouble - , examples = concat $ nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 - ++ brokenExp1 - ++ normPower4' ++ normPower5 - , ruleOrdering = ruleOrderingWithId [ getId mulExponents - , getId reciprocalFrac - , getId reciprocalInv - , getId power2root - , getId distributePower ] - } - -calcPowerExercise :: Exercise Expr -calcPowerExercise = (powerExercise calcPowerStrategy) - { exerciseId = describe "simplify expression (powers)" $ - newId "arithmetic.exponents" - , isReady = isPowerAdd - , isSuitable = (`belongsTo` normPowerMapView) - , equivalence = viewEquivalent normPowerMapView - , examples = concat $ negExp3 ++ normPower3' ++ normPower4 - } - - --- | Ready checks ------------------------------------------------------------- - -isSimplePower :: Expr -> Bool -isSimplePower (Sym s [Var _, y]) - | isPowerSymbol s = y `belongsTo` rationalView -isSimplePower _ = False - -isPower :: View Expr a -> Expr -> Bool -isPower v expr = - let Just (_, xs) = match productView expr - f (Nat 1 :/: a) = g a - f a = g a - g (Sym s [Var _, a]) | isPowerSymbol s = isJust (match v a) - g (Sym s [x, Nat _]) | isRootSymbol s = isPower v x - g (Sqrt x) = g x - g (Var _) = True - g a = a `belongsTo` rationalView - in distinct (concatMap vars xs) && all f xs - -isPowerAdd :: Expr -> Bool -isPowerAdd expr = - let Just xs = match sumView expr +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Exercises + ( -- * Power exercises + simplifyPowerExercise + , powerOfExercise + , nonNegBrokenExpExercise + , calcPowerExercise + ) where + +import Prelude hiding ( (^) ) + +import Common.Library +import Common.Utils (distinct) +import Domain.Math.Expr hiding (isPower) +import Domain.Math.Numeric.Views +import Domain.Math.Power.Examples +import Domain.Math.Power.NormViews +import Domain.Math.Power.Rules +import Domain.Math.Power.Strategies +import Domain.Math.Power.Views + +-- Exercises + +powerExercise :: Exercise Expr +powerExercise = makeExercise + { status = Provisional + , parser = parseExpr + , navigation = navigator + } + +-- | Simplify an expression containing powers as far as possible. This +-- exercise supports the following DWO-applets: +-- +-- * HAVO B, hoofdstuk 7, activiteit 1 +-- +-- * VWO A/C, hoofdstuk 5, activiteit 3 t/m 6 +-- +-- * VWO B, hoofdstuk 4, activiteit 8, 9, part of 10 +simplifyPowerExercise :: Exercise Expr +simplifyPowerExercise = powerExercise + { exerciseId = describe "simplify expression (powers)" $ + newId "algebra.manipulation.exponents.simplify" + , strategy = simplifyPowerStrategy + , ready = predicate isPowerAdd + , suitable = predicateView normPowerMapView + , equivalence = withoutContext (viewEquivalent normPowerMapView) + , examples = level Medium $ concat $ + simplerPowers + ++ powers1 ++ powers2 + ++ negExp1 ++ negExp2 + ++ normPower1 ++ normPower2 ++ normPower3 + , ruleOrdering = ruleOrderingWithId $ map getId + [ root2power, subExponents, reciprocalVar, addExponents + , mulExponents, distributePower ] + } + +-- | The @powerOfExercise@ is more strict than the 'simplifyPowerExercise'. +-- It only allows one variable experssions. This exercise supports the +-- following DWO-applets: +-- +-- * HAVO B, hoofdstuk 7, activiteit 2 and 4 +-- +-- * VWO A/C, hoofdstuk 5, activiteit part of 10 and 11 and 12 +-- +-- * VWO B, hoofdstuk 4, activiteit 12 partly, and 13 +powerOfExercise :: Exercise Expr +powerOfExercise = powerExercise + { exerciseId = describe "write as a power of a" $ + newId "algebra.manipulation.exponents.powerof" + , ready = predicate isSimplePower + , strategy = simplifyPowerStrategy + , suitable = predicateView normPowerView + , equivalence = withoutContext (viewEquivalent normPowerNonNegRatio) + , examples = level Medium $ concat $ powersOfA ++ powersOfX + ++ brokenExp1' ++ brokenExp2 ++ brokenExp3 + ++ normPower5' ++ normPower6 + , ruleOrdering = ruleOrderingWithId $ map getId + [ root2power, addExponents, subExponents, mulExponents + , distributePower, reciprocalVar ] + } + +-- | Rewrite power expressions so that they have any negative or broken +-- exponents. Supported DWO-applets: +-- +-- * HAVO B, hoofdstuk 7, activiteit 3 and 5 +-- +-- * VWO A/C, hoofdstuk 5, activiteit 8,9 and part of 10 +-- +-- * VWO B, hoofdstuk 4, activiteit 11 partly, and 12 partly +nonNegBrokenExpExercise :: Exercise Expr +nonNegBrokenExpExercise = powerExercise + { exerciseId = describe "write with a non-negative exponent" $ + newId "algebra.manipulation.exponents.nonnegative" + , strategy = nonNegBrokenExpStrategy + , ready = predicate (isPower plainNatView) + , suitable = predicateView normPowerNonNegDouble + , equivalence = withoutContext (viewEquivalent normPowerNonNegDouble) + , examples = level Medium $ concat $ nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 + ++ brokenExp1 + ++ normPower4' ++ normPower5 + , ruleOrdering = ruleOrderingWithId [ getId mulExponents + , getId reciprocalFrac + , getId reciprocalInv + , getId power2root + , getId distributePower ] + } + +-- | Calculate the integer number for the given power expression. Supported +-- DWO-applets: +-- +-- * VWO A/C, hoofdstuk 5, activiteit 7 +-- +-- * VWO B, hoofdstuk 4, activiteit 10 partly, 11 partly +calcPowerExercise :: Exercise Expr +calcPowerExercise = powerExercise + { exerciseId = describe "simplify expression (powers)" $ + newId "arithmetic.exponents" + , strategy = calcPowerStrategy + , ready = predicate isPowerAdd + , suitable = predicateView normPowerMapView + , equivalence = withoutContext (viewEquivalent normPowerMapView) + , examples = level Medium $ concat $ negExp3 ++ normPower3' ++ normPower4 + } + +-- Ready checks + +isSimplePower :: Expr -> Bool +isSimplePower (Sym s [Var _, y]) + | isPowerSymbol s = y `belongsTo` rationalView +isSimplePower _ = False + +isPower :: View Expr a -> Expr -> Bool +isPower v expr = + let xs = snd (from productView expr) + f (Nat 1 :/: a) = g a + f a = g a + g (Sym s [Var _, a]) | isPowerSymbol s = a `belongsTo` v + g (Sym s [x, Nat _]) | isRootSymbol s = isPower v x + g (Sqrt x) = g x + g (Var _) = True + g a = a `belongsTo` rationalView + in distinct (concatMap vars xs) && all f xs + +isPowerAdd :: Expr -> Bool +isPowerAdd expr = + let xs = from sumView expr in all (isPower rationalView) xs && not (applicable calcPowerPlus expr) diff --git a/src/Domain/Math/Power/NormViews.hs b/src/Domain/Math/Power/NormViews.hs --- a/src/Domain/Math/Power/NormViews.hs +++ b/src/Domain/Math/Power/NormViews.hs @@ -1,147 +1,146 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.NormViews - ( -- * Normalising views - normPowerView, normPowerMapView, normPowerNonNegRatio - , normPowerNonNegDouble - ) where - -import Prelude hiding ((^), recip) -import qualified Prelude -import Control.Monad -import Common.View -import Data.List -import qualified Data.Map as M -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Power.Utils - -type PowerMap = (M.Map String Rational, Rational) - - -normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational) -normPowerNonNegRatio = makeView (liftM swap . f) (g . swap) - where - f expr = - case expr of - Sym s [a,b] - | isPowerSymbol s -> do - (r, m) <- f a - if r==1 - then do - r2 <- match rationalView b - return (1, M.map (*r2) m) - else do - n <- match integerView b - if n >=0 - then return (r Prelude.^ n, M.map (*fromIntegral n) m) - else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m) - | isRootSymbol s -> - f (Sym powerSymbol [a, 1/b]) - Sqrt a -> - f (Sym rootSymbol [a,2]) - a :*: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - return (r1*r2, M.unionWith (+) m1 m2) - a :/: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - guard (r2 /= 0) - return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) - Var s -> return (1, M.singleton s 1) - Nat n -> return (toRational n, M.empty) - Negate x -> do - (r, m) <- f x - return (negate r, m) - _ -> do - r <- match rationalView expr - return (fromRational r, M.empty) - g (r, m) = - let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ] - in build productView (False, fromRational r : xs) - --- | AG: todo: change double to norm view for rationals -normPowerNonNegDouble :: View Expr (Double, M.Map String Rational) -normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g - where - roundof n (x, m) = (fromInteger (round (x * 10.0 ** n)) / 10.0 ** n, m) - f expr = - case expr of - Sym s [a,b] - | isPowerSymbol s -> do - (x, m) <- f a - y <- match rationalView b - return (x ** fromRational y, M.map (*y) m) - | isRootSymbol s -> f (Sym powerSymbol [a, 1/b]) - Sqrt a -> f (Sym rootSymbol [a,2]) - a :*: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - return (r1*r2, M.unionWith (+) m1 m2) - a :/: b -> do - (r1, m1) <- f a - (r2, m2) <- f b - guard (r2 /= 0) - return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) - Var s -> return (1, M.singleton s 1) - Negate x -> do - (r, m) <- f x - return (negate r, m) - _ -> do - d <- match doubleView expr - return (d, M.empty) - g (r, m) = - let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ] - in build productView (False, fromDouble r : xs) - -normPowerMapView :: View Expr [PowerMap] -normPowerMapView = makeView (liftM h . f) g - where - f = (mapM (match normPowerNonNegRatio) =<<) . match sumView - g = build sumView . map (build normPowerNonNegRatio) - h :: [PowerMap] -> [PowerMap] - h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy (\x y -> fst x == fst y) . sort - -normPowerView :: View Expr (String, Rational) -normPowerView = makeView f g - where - f expr = - case expr of - Sym s [x,y] - | isPowerSymbol s -> do - (s2, r) <- f x - r2 <- match rationalView y - return (s2, r*r2) - | isRootSymbol s -> - f (x^(1/y)) - Sqrt x -> - f (Sym rootSymbol [x, 2]) - Var s -> return (s, 1) - x :*: y -> do - (s1, r1) <- f x - (s2, r2) <- f y - guard (s1==s2) - return (s1, r1+r2) - Nat 1 :/: y -> do - (s, r) <- f y - return (s, -r) - x :/: y -> do - (s1, r1) <- f x - (s2, r2) <- f y - guard (s1==s2) - return (s1, r1-r2) - _ -> Nothing - +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.NormViews + ( -- * Normalising views + normPowerView, normPowerMapView, normPowerNonNegRatio + , normPowerNonNegDouble + ) where + +import Common.View +import Control.Monad +import Data.Function +import Data.List +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Utils +import Prelude hiding ((^), recip) +import qualified Data.Map as M +import qualified Prelude + +type PowerMap = (M.Map String Rational, Rational) + +normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational) +normPowerNonNegRatio = makeView (liftM swap . f) (g . swap) + where + f expr = + case expr of + Sym s [a,b] + | isPowerSymbol s -> do + (r, m) <- f a + if r==1 + then do + r2 <- match rationalView b + return (1, M.map (*r2) m) + else do + n <- match integerView b + if n >=0 + then return (r Prelude.^ n, M.map (*fromIntegral n) m) + else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m) + | isRootSymbol s -> + f (Sym powerSymbol [a, 1/b]) + Sqrt a -> + f (Sym rootSymbol [a,2]) + a :*: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + return (r1*r2, M.unionWith (+) m1 m2) + a :/: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + guard (r2 /= 0) + return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) + Var s -> return (1, M.singleton s 1) + Nat n -> return (toRational n, M.empty) + Negate x -> do + (r, m) <- f x + return (negate r, m) + _ -> do + r <- match rationalView expr + return (fromRational r, M.empty) + g (r, m) = + let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ] + in build productView (False, fromRational r : xs) + +-- | AG: todo: change double to norm view for rationals +normPowerNonNegDouble :: View Expr (Double, M.Map String Rational) +normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g + where + roundof n (x, m) = (fromInteger (round (x * 10.0 ** n)) / 10.0 ** n, m) + f expr = + case expr of + Sym s [a,b] + | isPowerSymbol s -> do + (x, m) <- f a + y <- match rationalView b + return (x ** fromRational y, M.map (*y) m) + | isRootSymbol s -> f (Sym powerSymbol [a, 1/b]) + Sqrt a -> f (Sym rootSymbol [a,2]) + a :*: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + return (r1*r2, M.unionWith (+) m1 m2) + a :/: b -> do + (r1, m1) <- f a + (r2, m2) <- f b + guard (r2 /= 0) + return (r1/r2, M.unionWith (+) m1 (M.map negate m2)) + Var s -> return (1, M.singleton s 1) + Negate x -> do + (r, m) <- f x + return (negate r, m) + _ -> do + d <- match doubleView expr + return (d, M.empty) + g (r, m) = + let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ] + in build productView (False, fromDouble r : xs) + +normPowerMapView :: View Expr [PowerMap] +normPowerMapView = makeView (liftM h . f) g + where + f = (mapM (match normPowerNonNegRatio) =<<) . match sumView + g = build sumView . map (build normPowerNonNegRatio) + h :: [PowerMap] -> [PowerMap] + h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy ((==) `on` fst) . sort + +normPowerView :: View Expr (String, Rational) +normPowerView = makeView f g + where + f expr = + case expr of + Sym s [x,y] + | isPowerSymbol s -> do + (s2, r) <- f x + r2 <- match rationalView y + return (s2, r*r2) + | isRootSymbol s -> + f (x^(1/y)) + Sqrt x -> + f (Sym rootSymbol [x, 2]) + Var s -> return (s, 1) + x :*: y -> do + (s1, r1) <- f x + (s2, r2) <- f y + guard (s1==s2) + return (s1, r1+r2) + Nat 1 :/: y -> do + (s, r) <- f y + return (s, -r) + x :/: y -> do + (s1, r1) <- f x + (s2, r2) <- f y + guard (s1==s2) + return (s1, r1-r2) + _ -> Nothing + g (s, r) = Var s .^. fromRational r - diff --git a/src/Domain/Math/Power/OldViews.hs b/src/Domain/Math/Power/OldViews.hs --- a/src/Domain/Math/Power/OldViews.hs +++ b/src/Domain/Math/Power/OldViews.hs @@ -1,55 +1,57 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.OldViews where - -import Common.Rewriting -import Common.View -import Control.Monad -import Domain.Math.Expr hiding ( (^) ) - -powerFactorView :: View Expr (String, Expr, Int) -powerFactorView = powerFactorViewWith identity - -powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int) -powerFactorViewWith v = makeView f g - where - f expr = do - pv <- selectVar expr - (e, n) <- match (powerFactorViewForWith pv v) expr - return (pv, e, n) - g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n) - -powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int) -powerFactorViewForWith pv v = makeView f g - where - f expr = - case expr of - Var s | pv == s -> Just (1, 1) - Negate e -> do - (a, b) <- f e - return (negate a, b) - e1 :*: e2 -> do - (a1, b1) <- f e1 - (a2, b2) <- f e2 - return (a1*a2, b1+b2) - Sym s [e1, Nat n] - | isPowerSymbol s -> do - (a1, b1) <- f e1 - a <- match v (build v a1 ^ toInteger n) - return (a, b1 * fromInteger n) - _ -> do - guard (withoutVar pv expr) - a <- match v expr - return (a, 0) - +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.OldViews + ( powerFactorView, powerFactorViewForWith, powerFactorViewWith + ) where + +import Common.Rewriting +import Common.View +import Control.Monad +import Domain.Math.Expr hiding ( (^) ) + +powerFactorView :: View Expr (String, Expr, Int) +powerFactorView = powerFactorViewWith identity + +powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int) +powerFactorViewWith v = makeView f g + where + f expr = do + pv <- selectVar expr + (e, n) <- match (powerFactorViewForWith pv v) expr + return (pv, e, n) + g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n) + +powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int) +powerFactorViewForWith pv v = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just (1, 1) + Negate e -> do + (a, b) <- f e + return (negate a, b) + e1 :*: e2 -> do + (a1, b1) <- f e1 + (a2, b2) <- f e2 + return (a1*a2, b1+b2) + Sym s [e1, Nat n] + | isPowerSymbol s -> do + (a1, b1) <- f e1 + a <- match v (build v a1 ^ toInteger n) + return (a, b1 * fromInteger n) + _ -> do + guard (withoutVar pv expr) + a <- match v expr + return (a, 0) + g (a, b) = build v a .*. (Var pv .^. fromIntegral b) 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 @@ -1,320 +1,310 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Rules - ( -- * Power rules - calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents - , subExponents, distributePower, distributePowerDiv, reciprocal - , reciprocalInv, reciprocalFrac, calcPowerRatio, calcRoot, simplifyPower - , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar - , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents - -- * Root rules - , power2root, root2power - -- * Log rules - , logarithm - -- * Common rules - , myFractionTimes, pushNegOut - ) where - -import Prelude hiding ( (^) ) -import qualified Prelude - -import Common.Classes -import Control.Arrow ( (>>^) ) -import Common.Id -import Common.Transformation -import Common.View -import Control.Monad -import Data.List -import Data.Maybe -import qualified Domain.Math.Data.PrimeFactors as PF -import Domain.Math.Data.OrList -import Domain.Math.Data.Relation -import Domain.Math.Expr -import Domain.Math.Numeric.Views -import Domain.Math.Power.Utils -import Domain.Math.Power.Views - - --- | Identifier prefixes ------------------------------------------------------ - -power, logarithmic :: String -power = "algebra.manipulation.exponents" -logarithmic = "algebra.manipulation.logarithmic" - - --- | Power rules -------------------------------------------------------------- - --- n => a^e (with e /= 1) -factorAsPower :: Rule Expr -factorAsPower = makeSimpleRuleList (power, "factor-as-power") $ \ expr -> do - n <- matchM myIntegerView expr - (a, x) <- PF.allPowers $ toInteger n - if n > 0 - then return $ fromInteger a .^. fromInteger x - else if odd x - then return $ fromInteger (negate a) .^. fromInteger x - else fail "Could not factorise number." - -calcPower :: Rule Expr -calcPower = makeSimpleRule "arithmetic.operation.rational.power" $ \ expr -> do - (a, x) <- match (powerViewWith rationalView plainNatView) expr - return $ fromRational $ a Prelude.^ x - --- | a^(x/y) => (a^x)^(1/y) -calcPowerRatio :: Rule Expr -calcPowerRatio = makeSimpleRule (power, "power-ratio") $ \ expr -> do - let v = powerView >>> second (rationalView >>> plainRationalView) - (a, (x, y)) <- match v expr - guard $ x /= 1 && y /= 1 - return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y) - --- -- | root n x -calcPlainRoot :: Rule Expr -calcPlainRoot = makeSimpleRule (power, "root") $ \ expr -> do - (n, x) <- match (rootView >>> (integerView *** integerView)) expr - y <- takeRoot n x - return $ fromInteger y - --- | [root n x, ... ] -calcRoot :: Rule (OrList Expr) -calcRoot = makeSimpleRuleList (power, "root") $ \ ors -> - fromMaybe [] (disjunctions ors) >>= maybeToList . f - where - f expr = do - (n, x) <- match (rootView >>> (integerView *** integerView)) expr - y <- liftM fromInteger $ lookup n $ map swap $ PF.allPowers (abs x) - let ys | x > 0 && even n = [y, negate y] - | x > 0 && odd n = [y] - | x < 0 && odd n = [negate y] - | otherwise = [] - roots <- toMaybe (not. null) ys - return $ orList roots - -calcPowerPlus :: Rule Expr -calcPowerPlus = - makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus - -calcPowerMinus :: Rule Expr -calcPowerMinus = - makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus - -addExponents :: Rule Expr -addExponents = makeSimpleRuleList (power, "add-exponents") $ \ expr -> do - (sign, fs) <- matchM (powerFactorView isPow) expr - ((x, y), fill) <- twoNonAdjacentHoles fs - prod <- applyM addExponentsT $ x * y - return $ build productView (sign, fill prod) - -isPow :: Expr -> Expr -> Bool -isPow x y = x `belongsTo` myIntegerView && - (y `belongsTo` varView || y `belongsTo` powerView) - --- | a*x^y * b*x^q = a*b * x^(y+q) -addExponentsT :: Transformation Expr -addExponentsT = makeTrans $ \ expr -> do - (e1, e2) <- match timesView expr - (a, (x, y)) <- match unitPowerView e1 - (b, (x', q)) <- match unitPowerView e2 - guard $ x == x' - return $ build unitPowerView (a .*. b, (x, y .+. q)) - -simpleAddExponents :: Rule Expr -simpleAddExponents = makeRule (power, "simple-add-exponents") addExponentsT - --- | a*x^y / b*x^q = a/b * x^(y-q) -subExponents :: Rule Expr -subExponents = makeSimpleRule (power, "sub-exponents") $ \ expr -> do - (e1, e2) <- match divView expr - (a, (x, y)) <- match unitPowerView e1 - (b, (x', q)) <- match unitPowerView e2 - guard $ x == x' - return $ build unitPowerView (a ./. b, (x, y .-. q)) - --- | (a^x)^y = a^(x*y) -mulExponents :: Rule Expr -mulExponents = makeSimpleRule (power, "mul-exponents") $ \ expr -> do - ((a, x), y) <- match (strictPowerView >>> first powerView) expr - return $ build powerView (a, x .*. y) - --- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x -distributePower :: Rule Expr -distributePower = makeSimpleRule (power, "distr-power") $ \ expr -> do - ((sign, as), x) <- match (powerViewWith productView identity) expr - guard $ length as > 1 - let y = build productView (False, map (\a -> build powerView (a, x)) as) - return $ - maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x - --- | (a/b)^y = (a^y / b^y) -distributePowerDiv :: Rule Expr -distributePowerDiv = makeSimpleRule (power, "distr-power-div") $ \ expr -> do - ((a, b), y) <- match (powerViewWith divView identity) expr - return $ build divView (build powerView (a, y), build powerView (b, y)) - --- | a^0 = 1 -zeroPower :: Rule Expr -zeroPower = makeSimpleRule (power, "power-zero") $ \ expr -> do - (_, x) <- match powerView expr - guard $ x == 0 - return 1 - --- a ^ 1 = a -onePower :: Rule Expr -onePower = makeSimpleRule (power, "power-one") $ \ expr -> do - (a, x) <- match powerView expr - guard $ x == 1 - return a - --- 1 ^ x = 1 -powerOne :: Rule Expr -powerOne = makeSimpleRule (power, "one-power") $ \ expr -> do - (a, _) <- match powerView expr - guard $ a == 1 - return a - --- 0 ^ x = 0 with x > 0 -powerZero :: Rule Expr -powerZero = makeSimpleRule (power, "one-power") $ \ expr -> do - (a, x) <- match (powerViewWith identity integerView) expr - guard $ x > 0 && a == 0 - return 0 - --- | all of the above simplification rules -simplifyPower :: Rule Expr -simplifyPower = makeSimpleRuleList (power, "simplify") $ \ expr -> - mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero] - --- | e/a = e*a^(-1) where a is an variable -reciprocalVar :: Rule Expr -reciprocalVar = makeSimpleRule (power, "reciprocal-var") $ \ expr -> do - (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr - return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c - --- | c/a^x = c*a^x^(-1) -reciprocalPower :: Rule Expr -reciprocalPower = makeSimpleRule (power, "reciprocal-power") $ \ expr -> do - (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr - return $ (e .*. build consPowerView (1, (a, neg x))) ./. c - --- | Use with care, will match any fraction! -reciprocal :: Rule Expr -reciprocal = makeSimpleRule (power, "reciprocal") $ - apply (reciprocalForT identity) - --- | a/b = a*b^(-1) -reciprocalForT :: View Expr a -> Transformation Expr -reciprocalForT v = makeTrans $ \ expr -> do - (a, b) <- match divView expr - guard $ b `belongsTo` v - return $ a .*. build powerView (b, -1) - --- | a^x = 1/a^(-x) -reciprocalInv :: Rule Expr -reciprocalInv = makeSimpleRule (power, "reciprocal-inverse") $ \ expr -> do - guard $ hasNegExp expr - (a, x) <- match strictPowerView expr - return $ 1 ./. build strictPowerView (a, neg x) - --- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r... -reciprocalFrac :: Rule Expr -reciprocalFrac = makeSimpleRule (power, "reciprocal-frac") $ \ expr -> do - (e1, e2) <- match divView expr - (s, xs) <- match productView e2 - let (ys, zs) = partition hasNegExp xs - guard (not $ null ys) - return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs) - where - f e = case match consPowerView e of - Just (c, (a, x)) -> build consPowerView (c, (a, neg x)) - Nothing -> e - --- | a^x / b^x = (a/b)^x -divBase :: Rule Expr -divBase = describe "divide base of root" $ - makeSimpleRule (power, "divide-base") $ \ expr -> do - (e1, e2) <- match divView expr - (c1, (a, x)) <- match consPowerView e1 - (c2, (b, x')) <- match consPowerView e2 - guard $ x == x' && b /= 0 - return $ build consPowerView (c1 .*. c2, (a ./. b, x)) - --- | (-a)^x = -(a^x) -pushNegOut :: Rule Expr -pushNegOut = makeSimpleRule (power, "push-negation-out") $ \ expr -> do - (a, x) <- match (powerViewWith identity integerView) expr - a' <- isNegate a - return $ (if odd x then neg else id) $ build powerView (a', fromInteger x) - - --- | Root rules ---------------------------------------------------------------- - --- | a^(p/q) = root (a^p) q -power2root :: Rule Expr -power2root = makeSimpleRule (power, "write-as-root") $ \ expr -> do - (a, (p, q)) <- match (strictPowerView >>> second divView) expr - guard $ q /= 1 - return $ root (a .^. p) q - --- | root a q = a^(1/q) -root2power :: Rule Expr -root2power = makeSimpleRule (power, "write-as-power") $ \ expr -> do - (a, q) <- match strictRootView expr - return $ a .^. (1 ./. q) - - --- | Logarithmic relation rules ----------------------------------------------- - -logarithm :: Rule (Equation Expr) -logarithm = makeSimpleRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do - (b, x) <- match logView lhs - return $ x :==: build powerView (b, rhs) - - --- | Common rules -------------------------------------------------------------- - --- | a/b * c/d = a*c / b*d (b or else d may be one) -myFractionTimes :: Rule Expr -myFractionTimes = smartRule $ makeSimpleRule (power, "fraction-times") $ \ expr -> do - (e1, e2) <- match timesView expr - guard $ e1 `belongsTo` divView || e2 `belongsTo` divView - (a, b) <- match (divView <&> (identity >>^ \e -> (e,1))) e1 - (c, d) <- match (divView <&> (identity >>^ \e -> (e,1))) e2 - return $ build divView (a .*. c, b .*. d) - - --- | Help functions ----------------------------------------------------------- - -calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr -calcBinPowerRule opName op m = - makeSimpleRule (power, "calc-power", opName) $ \e -> do - (e1, e2) <- m e - (c1, (a, x)) <- match unitPowerViewVar e1 - (c2, (b, y)) <- match unitPowerViewVar e2 - guard $ a == b && x == y - return $ build unitPowerViewVar (op c1 c2, (a, x)) - --- use twoNonAdHoles instead of split ??? -makeCommutative :: View Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr -makeCommutative view op r = - makeSimpleRuleList (getId r) $ \ expr -> - case match view expr of - Just factors -> do - (e, es) <- split op factors - case apply r e of - Just e' -> return $ build view (e' : es) - Nothing -> [] - Nothing -> [] - -hasNegExp :: Expr -> Bool -hasNegExp expr = fromMaybe False $ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Rules + ( -- * Power rules + calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents + , subExponents, distributePower, distributePowerDiv, reciprocal + , reciprocalInv, reciprocalFrac, calcPowerRatio, simplifyPower + , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar + , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents + -- * Root rules + , power2root, root2power + -- * Log rules + , logarithm + -- * Common rules + , myFractionTimes, pushNegOut + ) where + +import Common.Library hiding (root) +import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Power.Utils +import Domain.Math.Power.Views +import Prelude hiding ( (^) ) +import qualified Domain.Math.Data.PrimeFactors as PF +import qualified Prelude + +-- Identifier prefixes ------------------------------------------------------ + +power, logarithmic :: String +power = "algebra.manipulation.exponents" +logarithmic = "algebra.manipulation.logarithmic" + +-- Power rules -------------------------------------------------------------- + +-- | n => a^e (with e /= 1) +factorAsPower :: Rule Expr +factorAsPower = makeSimpleRuleList (power, "factor-as-power") $ \ expr -> do + n <- matchM myIntegerView expr + (a, x) <- PF.allPowers $ toInteger n + if n > 0 + then return $ fromInteger a .^. fromInteger x + else if odd x + then return $ fromInteger (negate a) .^. fromInteger x + else fail "Could not factorise number." + +-- | Calculate power, e.g., 2^2 => 4 +calcPower :: Rule Expr +calcPower = makeSimpleRule "arithmetic.operation.rational.power" $ \ expr -> do + (a, x) <- match (powerViewWith rationalView plainNatView) expr + return $ fromRational $ a Prelude.^ x + +-- | a^(x/y) => (a^x)^(1/y) +calcPowerRatio :: Rule Expr +calcPowerRatio = makeSimpleRule (power, "power-ratio") $ \ expr -> do + let v = powerView >>> second (rationalView >>> plainRationalView) + (a, (x, y)) <- match v expr + guard $ x /= 1 && y /= 1 + return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y) + +-- | root n x +calcPlainRoot :: Rule Expr +calcPlainRoot = makeSimpleRule (power, "root") $ \expr -> do + (n, x) <- matchM (rootView >>> (integerView *** integerView)) expr + fmap fromInteger (takeRoot n x) + +-- | [root n x, ... ] +-- BHR: not used. Better to turn this into OrList (Relation Expr) +{- +calcRoot :: Rule (OrList Expr) +calcRoot = makeSimpleRule (power, "root") $ + oneDisjunct $ \expr -> do + (n, x) <- match (rootView >>> (integerView *** integerView)) expr + y <- liftM fromInteger $ lookup n $ map swap $ PF.allPowers (abs x) + let ys | x > 0 && even n = [y, negate y] + | x > 0 && odd n = [y] + | x < 0 && odd n = [negate y] + | otherwise = [] + roots <- toMaybe (not. null) ys + return $ toOrList roots +-} + +calcPowerPlus :: Rule Expr +calcPowerPlus = + makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus + +calcPowerMinus :: Rule Expr +calcPowerMinus = + makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus + +addExponents :: Rule Expr +addExponents = makeSimpleRuleList (power, "add-exponents") $ \ expr -> do + (sign, fs) <- matchM (powerFactorView isPow) expr + ((x, y), fill) <- twoNonAdjacentHoles fs + prod <- applyM addExponentsT $ x * y + return $ build productView (sign, fill prod) + +isPow :: Expr -> Expr -> Bool +isPow x y = x `belongsTo` myIntegerView && + (y `belongsTo` variableView || y `belongsTo` powerView) + +-- | a*x^y * b*x^q = a*b * x^(y+q) +addExponentsT :: Transformation Expr +addExponentsT = makeTrans $ \ expr -> do + (e1, e2) <- match timesView expr + (a, (x, y)) <- match unitPowerView e1 + (b, (x', q)) <- match unitPowerView e2 + guard $ x == x' + return $ build unitPowerView (a .*. b, (x, y .+. q)) + +simpleAddExponents :: Rule Expr +simpleAddExponents = makeRule (power, "simple-add-exponents") addExponentsT + +-- | a*x^y / b*x^q = a/b * x^(y-q) +subExponents :: Rule Expr +subExponents = makeSimpleRule (power, "sub-exponents") $ \ expr -> do + (e1, e2) <- match divView expr + (a, (x, y)) <- match unitPowerView e1 + (b, (x', q)) <- match unitPowerView e2 + guard $ x == x' + return $ build unitPowerView (a ./. b, (x, y .-. q)) + +-- | (a^x)^y = a^(x*y) +mulExponents :: Rule Expr +mulExponents = makeSimpleRule (power, "mul-exponents") $ \ expr -> do + ((a, x), y) <- match (strictPowerView >>> first powerView) expr + return $ build powerView (a, x .*. y) + +-- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x +distributePower :: Rule Expr +distributePower = makeSimpleRule (power, "distr-power") $ \ expr -> do + ((sign, as), x) <- match (powerViewWith (toView productView) identity) expr + guard $ length as > 1 + let y = build productView (False, map (\a -> build powerView (a, x)) as) + return $ + maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x + +-- | (a/b)^y = (a^y / b^y) +distributePowerDiv :: Rule Expr +distributePowerDiv = makeSimpleRule (power, "distr-power-div") $ \ expr -> do + ((a, b), y) <- match (powerViewWith divView identity) expr + return $ build divView (build powerView (a, y), build powerView (b, y)) + +-- | a^0 = 1 +zeroPower :: Rule Expr +zeroPower = makeSimpleRule (power, "power-zero") $ \ expr -> do + (_, x) <- match powerView expr + guard $ x == 0 + return 1 + +-- a ^ 1 = a +onePower :: Rule Expr +onePower = makeSimpleRule (power, "power-one") $ \ expr -> do + (a, x) <- match powerView expr + guard $ x == 1 + return a + +-- 1 ^ x = 1 +powerOne :: Rule Expr +powerOne = makeSimpleRule (power, "one-power") $ \ expr -> do + (a, _) <- match powerView expr + guard $ a == 1 + return a + +-- 0 ^ x = 0 with x > 0 +powerZero :: Rule Expr +powerZero = makeSimpleRule (power, "one-power") $ \ expr -> do + (a, x) <- match (powerViewWith identity integerView) expr + guard $ x > 0 && a == 0 + return 0 + +-- | all of the above simplification rules +simplifyPower :: Rule Expr +simplifyPower = makeSimpleRuleList (power, "simplify") $ \ expr -> + mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero] + +-- | e/a = e*a^(-1) where a is an variable +reciprocalVar :: Rule Expr +reciprocalVar = makeSimpleRule (power, "reciprocal-var") $ \ expr -> do + (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr + return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c + +-- | c/a^x = c*a^x^(-1) +reciprocalPower :: Rule Expr +reciprocalPower = makeSimpleRule (power, "reciprocal-power") $ \ expr -> do + (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr + return $ (e .*. build consPowerView (1, (a, neg x))) ./. c + +-- | Use with care, will match any fraction! +reciprocal :: Rule Expr +reciprocal = makeSimpleRule (power, "reciprocal") $ + apply (reciprocalForT identity) + +-- | a/b = a*b^(-1) +reciprocalForT :: View Expr a -> Transformation Expr +reciprocalForT v = makeTrans $ \ expr -> do + (a, b) <- match divView expr + guard $ b `belongsTo` v + return $ a .*. build powerView (b, -1) + +-- | a^x = 1/a^(-x) +reciprocalInv :: Rule Expr +reciprocalInv = makeSimpleRule (power, "reciprocal-inverse") $ \ expr -> do + guard $ hasNegExp expr + (a, x) <- match strictPowerView expr + return $ 1 ./. build strictPowerView (a, neg x) + +-- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r... +reciprocalFrac :: Rule Expr +reciprocalFrac = makeSimpleRule (power, "reciprocal-frac") $ \ expr -> do + (e1, e2) <- match divView expr + (s, xs) <- match productView e2 + let (ys, zs) = partition hasNegExp xs + guard (not $ null ys) + return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs) + where + f e = case match consPowerView e of + Just (c, (a, x)) -> build consPowerView (c, (a, neg x)) + Nothing -> e + +-- | a^x / b^x = (a/b)^x +divBase :: Rule Expr +divBase = describe "divide base of root" $ + makeSimpleRule (power, "divide-base") $ \ expr -> do + (e1, e2) <- match divView expr + (c1, (a, x)) <- match consPowerView e1 + (c2, (b, x')) <- match consPowerView e2 + guard $ x == x' && b /= 0 + return $ build consPowerView (c1 .*. c2, (a ./. b, x)) + +-- | (-a)^x = -(a^x) +pushNegOut :: Rule Expr +pushNegOut = makeSimpleRule (power, "push-negation-out") $ \ expr -> do + (a, x) <- match (powerViewWith identity integerView) expr + a' <- isNegate a + return $ (if odd x then neg else id) $ build powerView (a', fromInteger x) + +-- | Root rules ---------------------------------------------------------------- + +-- | a^(p/q) = root (a^p) q +power2root :: Rule Expr +power2root = makeSimpleRule (power, "write-as-root") $ \ expr -> do + (a, (p, q)) <- match (strictPowerView >>> second divView) expr + guard $ q /= 1 + return $ root (a .^. p) q + +-- | root a q = a^(1/q) +root2power :: Rule Expr +root2power = makeSimpleRule (power, "write-as-power") $ \ expr -> do + (a, q) <- match strictRootView expr + return $ a .^. (1 ./. q) + +-- | Logarithmic relation rules ----------------------------------------------- + +logarithm :: Rule (Equation Expr) +logarithm = makeSimpleRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do + (b, x) <- match logView lhs + return $ x :==: build powerView (b, rhs) + +-- | Common rules -------------------------------------------------------------- + +-- | a/b * c/d = a*c / b*d (b or d may be one) +myFractionTimes :: Rule Expr +myFractionTimes = smartRule $ makeSimpleRule (power, "fraction-times") $ \ expr -> do + (e1, e2) <- match timesView expr + guard $ e1 `belongsTo` divView || e2 `belongsTo` divView + let f e = fromMaybe (e, 1) (match divView e) + (a, b) = f e1 + (c, d) = f e2 + return $ build divView (a .*. c, b .*. d) + +-- | Help functions ----------------------------------------------------------- + +calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr +calcBinPowerRule opName op m = + makeSimpleRule (power, "calc-power", opName) $ \e -> do + (e1, e2) <- m e + (c1, (a, x)) <- match unitPowerViewVar e1 + (c2, (b, y)) <- match unitPowerViewVar e2 + guard $ a == b && x == y + return $ build unitPowerViewVar (op c1 c2, (a, x)) + +-- use twoNonAdHoles instead of split ??? +makeCommutative :: IsView f => f Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr +makeCommutative view op r = + makeSimpleRuleList (getId r) $ \ expr -> + case match view expr of + Just factors -> do + (e, es) <- split op factors + case apply r e of + Just e' -> return $ build view (e' : es) + Nothing -> [] + Nothing -> [] + +hasNegExp :: Expr -> Bool +hasNegExp expr = fromMaybe False $ fmap ((< 0) . snd . snd) (match consPowerView expr) 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 @@ -1,85 +1,71 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Strategies - ( -- * Power strategies - simplifyPowerStrategy - , powerOfStrategy - , calcPowerStrategy - , nonNegBrokenExpStrategy - ) where - -import Prelude hiding (repeat, not) - -import Common.Classes -import Common.Context -import Common.Id -import Common.Navigator -import Common.Strategy -import Common.Transformation -import Domain.Math.Expr -import Domain.Math.Numeric.Rules (divisionNumerator, divisionDenominator) -import Domain.Math.Power.Rules -import Domain.Math.Power.Utils -import Domain.Math.Simplification - - --- | Strategies --------------------------------------------------------------- - -simplifyPowerStrategy :: LabeledStrategy (Context Expr) -simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules - -powerOfStrategy :: LabeledStrategy (Context Expr) -powerOfStrategy = cleanUpStrategyRules "Write as power of" powerRules - -nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr) -nonNegBrokenExpStrategy = cleanUpStrategy (change cleanup . applyTop cleanup) strategy - where - rs = [ addExponents, subExponents, mulExponents, reciprocalInv - , distributePower, distributePowerDiv, power2root, zeroPower - , calcPowerPlus, calcPowerMinus - ] - strategy = label "Write with non-negative exponent" $ exhaustiveStrategy rs - cleanup = applyD divisionNumerator - . applyD myFractionTimes - . mergeConstants - . simplifyWith simplifyConfig {withMergeAlike = False} - -calcPowerStrategy :: LabeledStrategy (Context Expr) -calcPowerStrategy = cleanUpStrategy cleanup strategy - where - strategy = label "Calculate power" $ exhaustiveStrategy rules - rules = calcPower : divisionDenominator : reciprocalInv : divBase : rationalRules - cleanup = applyTop (applyD myFractionTimes) - . applyD (exhaustiveStrategy $ myFractionTimes : naturalRules) - - --- | Rule collections --------------------------------------------------------- - -powerRules :: [Rule Expr] -powerRules = - [ addExponents, subExponents, mulExponents, distributePower, zeroPower - , reciprocalVar, root2power, calcPower, calcPowerPlus, calcPowerMinus - , pushNegOut - ] - - --- | Help functions ----------------------------------------------------------- - -cleanUpStrategyRules :: IsId n => n -> [Rule Expr] -> LabeledStrategy (Context Expr) -cleanUpStrategyRules l = - cleanUpStrategy (change cleanUp. applyTop cleanUp) . label l . exhaustiveStrategy - -cleanUp :: Expr -> Expr -cleanUp = mergeConstants +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Strategies + ( -- * Power strategies + simplifyPowerStrategy + , calcPowerStrategy + , nonNegBrokenExpStrategy + ) where + +import Common.Library hiding (simplifyWith) +import Domain.Math.Expr +import Domain.Math.Numeric.Rules (divisionNumerator, divisionDenominator) +import Domain.Math.Power.Rules +import Domain.Math.Power.Utils +import Domain.Math.Simplification + +-- Strategies --------------------------------------------------------------- + +-- | Simplify an expression containing powers as far as possible +simplifyPowerStrategy :: LabeledStrategy (Context Expr) +simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules + +nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr) +nonNegBrokenExpStrategy = cleanUpStrategy (change cleanup . applyTop cleanup) $ + label "Write with non-negative exponent" $ exhaustiveStrategy rs + where + rs = [ addExponents, subExponents, mulExponents, reciprocalInv + , distributePower, distributePowerDiv, power2root, zeroPower + , calcPowerPlus, calcPowerMinus + ] + cleanup = applyD divisionNumerator + . applyD myFractionTimes + . mergeConstants + . simplifyWith simplifyConfig {withMergeAlike = False} + +calcPowerStrategy :: LabeledStrategy (Context Expr) +calcPowerStrategy = cleanUpStrategy cleanup $ + label "Calculate power" $ exhaustiveStrategy rules + where + rules = calcPower : divisionDenominator : reciprocalInv : divBase : rationalRules + cleanup = applyTop (applyD myFractionTimes) + . applyD (exhaustiveStrategy $ myFractionTimes : naturalRules) + +-- Rule collections --------------------------------------------------------- + +powerRules :: [Rule Expr] +powerRules = + [ addExponents, subExponents, mulExponents, distributePower, zeroPower + , reciprocalVar, root2power, calcPower, calcPowerPlus, calcPowerMinus + , pushNegOut + ] + +-- | Help functions ----------------------------------------------------------- + +cleanUpStrategyRules :: IsId n => n -> [Rule Expr] -> LabeledStrategy (Context Expr) +cleanUpStrategyRules l = + cleanUpStrategy (change cleanUp. applyTop cleanUp) . label l . exhaustiveStrategy + +cleanUp :: Expr -> Expr +cleanUp = mergeConstants . simplifyWith simplifyConfig {withMergeAlike = False} - diff --git a/src/Domain/Math/Power/Utils.hs b/src/Domain/Math/Power/Utils.hs --- a/src/Domain/Math/Power/Utils.hs +++ b/src/Domain/Math/Power/Utils.hs @@ -1,185 +1,227 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- some of these help functions may have a broader scope and could be --- moved to other parts of the framework (eg. Common) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Utils where - -import Prelude hiding (repeat, replicate) - -import Common.Context -import Common.Rewriting -import Common.Strategy hiding (not) -import Common.Transformation -import Common.View -import Control.Monad -import Data.List hiding (repeat, replicate) -import Data.Ratio -import qualified Domain.Math.Data.PrimeFactors as PF -import Domain.Math.Data.Relation -import Domain.Math.Expr -import Domain.Math.Numeric.Rules -import Domain.Math.Numeric.Views - - --- | Strategy functions ------------------------------------------------------- - -exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a) -exhaustiveStrategy = exhaustiveSomewhere . map liftToContext - -exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b) -exhaustiveUse = exhaustiveSomewhere . map use - -exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a) -exhaustiveSomewhere = repeat . somewhere . alternatives - --- | Rule functions ----------------------------------------------------------- - -smartRule :: Rule Expr -> Rule Expr -smartRule = doAfter f - where - f (a :*: b) = a .*. b - f (a :/: b) = a ./. b - f (Negate a) = neg a - f (a :+: b) = a .+. b - f (a :-: b) = a .-. b - f e = e - -mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr -mergeConstantsWith p = simplifyWith f productView - where - f (sign, xs) = - let (cs, ys) = partition p xs - c = simplify rationalView $ build productView (False, cs) - in if maybe False (> 1) (match rationalView c) - then (sign, c:ys) - else (sign, xs) - -mergeConstants :: Expr -> Expr -mergeConstants = mergeConstantsWith (`belongsTo` rationalView) - --- | View functions ----------------------------------------------------------- - -(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b -v <&> w = makeView (\x -> match v x `mplus` match w x) (build v) - -infixl 1 <&> - -plainNatView :: View Expr Integer -plainNatView = makeView f Nat - where - f (Nat n) = Just n - f _ = Nothing - -myIntegerView :: View Expr Integer -myIntegerView = makeView f fromInteger - where - f (Nat n) = Just n - f (Negate (Nat n)) = Just $ negate n - f _ = Nothing - -plainRationalView :: View Rational (Integer, Integer) -plainRationalView = - makeView (\x -> return (numerator x, denominator x)) (uncurry (%)) - -eqView :: View a b -> View (Equation a) (b, b) -eqView v = eqv >>> v *** v - where - eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:)) - - --- | Rule collections --------------------------------------------------------- - -naturalRules :: [Rule Expr] -naturalRules = - [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView - , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView - , doubleNegate, negateZero , plusNegateLeft, plusNegateRight --- , minusNegateLeft - , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft - , divisionNegateRight - ] - -rationalRules :: [Rule Expr] -rationalRules = - [ calcPlusWith "rational" rationalRelaxedForm - , calcMinusWith "rational" rationalRelaxedForm - , calcTimesWith "rational" rationalRelaxedForm - , calcDivisionWith "integer" integerNormalForm - , doubleNegate, negateZero, divisionDenominator, divisionNumerator - , simplerFraction - ] - -fractionRules :: [Rule Expr] -fractionRules = - [ fractionPlus, fractionPlusScale, fractionTimes - , calcPlusWith "integer" integerNormalForm - , calcMinusWith "integer" integerNormalForm - , calcTimesWith "integer" integerNormalForm -- not needed? - , calcDivisionWith "integer" integerNormalForm - , doubleNegate, negateZero, smartRule divisionDenominator - , smartRule divisionNumerator, simplerFraction - ] - - --- | Common functions --------------------------------------------------------- - -takeRoot :: Integer -> Integer -> Maybe Integer -takeRoot n x = do - y <- if (abs n == 1) - then Just 1 - else lookup x $ map swap $ PF.allPowers (abs n) - guard $ n > 0 || (n < 0 && odd x) - return $ if n > 0 then y else negate y - -swap :: (a, b) -> (b, a) -swap (a, b) = (b, a) - -split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])] -split op xs = f xs - where - f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys - | otherwise = [] - f [] = [] - -toMaybe :: (a -> Bool) -> a -> Maybe a -toMaybe p x = if p x then Just x else Nothing - -joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]] -joinBy _ [] = [] -joinBy eq xs = ys : joinBy eq (xs \\ ys) - where - ys = dropUntil eq xs - -dropUntil :: (a -> a -> Bool) -> [a] -> [a] -dropUntil _ [] = [] -dropUntil _ [x] = [x] -dropUntil p (x:y:ys) | p x y = x : dropUntil p (y:ys) - | otherwise = [x] - -holes :: [a] -> [(a, [a], a -> [a])] -holes xs = map f [0 .. length xs - 1] - where - f i = let (ys, z:zs) = splitAt i xs - in (z, ys ++ zs, \x -> ys ++ x:zs) - -twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])] -twoNonAdjacentHoles xs = concatMap g pairs - where - pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]] - g (x, y) = let (ys, z:zs) = splitAt x xs - (ps, q:qs) = splitAt (y - x - 1) zs - in if null ps - then [ ((z, q), \a -> ys ++ a:ps ++ qs) ] - else [ ((z, q), \a -> ys ++ a:ps ++ qs) +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- some of these help functions may have a broader scope and could be +-- moved to other parts of the framework (eg. Common) +-- +----------------------------------------------------------------------------- +module Domain.Math.Power.Utils where + +import Common.Library +import Common.Utils.Uniplate +import Data.Foldable (toList) +import Data.Function (on) +import Data.List +import Data.Ratio +import Domain.Math.CleanUp +import Domain.Math.Data.OrList +import Domain.Math.Data.Relation +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Expr +import Domain.Math.Numeric.Rules +import Domain.Math.Numeric.Views + +-- | Strategy functions ------------------------------------------------------- + +exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a) +exhaustiveStrategy = exhaustiveSomewhere . map liftToContext + +exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b) +exhaustiveUse = exhaustiveSomewhere . map use + +exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a) +exhaustiveSomewhere = repeatS . somewhere . alternatives + +-- | Rule functions ----------------------------------------------------------- + +smartRule :: Rule Expr -> Rule Expr +smartRule = doAfter f + where + f (a :*: b) = a .*. b + f (a :/: b) = a ./. b + f (Negate a) = neg a + f (a :+: b) = a .+. b + f (a :-: b) = a .-. b + f e = e + +mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr +mergeConstantsWith p = simplifyWith f productView + where + f (sign, xs) = + let (cs, ys) = partition p xs + c = simplify rationalView $ build productView (False, cs) + in if maybe False (> 1) (match rationalView c) + then (sign, c:ys) + else (sign, xs) + +mergeConstants :: Expr -> Expr +mergeConstants = mergeConstantsWith (`belongsTo` rationalView) + +-- | View functions ----------------------------------------------------------- + +plainNatView :: View Expr Integer +plainNatView = makeView f Nat + where + f (Nat n) = Just n + f _ = Nothing + +myIntegerView :: View Expr Integer +myIntegerView = makeView f fromInteger + where + f (Nat n) = Just n + f (Negate (Nat n)) = Just $ negate n + f _ = Nothing + +plainRationalView :: View Rational (Integer, Integer) +plainRationalView = + makeView (\x -> return (numerator x, denominator x)) (uncurry (%)) + +eqView :: View a b -> View (Equation a) (b, b) +eqView v = eqv >>> v *** v + where + eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:)) + +relationView :: View (Equation a) (Relation a) +relationView = makeView f g + where + f (x :==: y) = return $ x .==. y + g r | relationType r == EqualTo = leftHandSide r :==: rightHandSide r + | otherwise = error "Not an equality" + +-- | Rule collections --------------------------------------------------------- + +naturalRules :: [Rule Expr] +naturalRules = + [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView + , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView + , doubleNegate, negateZero , plusNegateLeft, plusNegateRight +-- , minusNegateLeft + , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft + , divisionNegateRight + ] + +rationalRules :: [Rule Expr] +rationalRules = + [ calcPlusWith "rational" rationalRelaxedForm + , calcMinusWith "rational" rationalRelaxedForm + , calcTimesWith "rational" rationalRelaxedForm + , calcDivisionWith "integer" integerNF + , doubleNegate, negateZero, divisionDenominator, divisionNumerator + , simplerFraction + ] + +coverUpRulesX :: [Rule (Equation Expr)] +coverUpRulesX = map (\r -> r cfg) + [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith, coverUpNegateWith + , coverUpTimesWith, coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith + ] + where + cfg = configCoverUp { predicateCovered = elem "x" . vars + , predicateCombined = notElem "x" . vars + , coverLHS = False} + +-- | Common functions --------------------------------------------------------- + +sortExpr :: Expr -> Expr +sortExpr = transform $ simplifyWith (sort . map sortProd) sumView + where sortProd = simplifyWith (fmap sort) productView + +sortEquation :: Equation Expr -> Equation Expr +sortEquation (x :==: y) = if x < y then eq else flipSides eq + where eq = sortExpr x :==: sortExpr y + +sortOrList :: OrList (Equation Expr) -> OrList (Equation Expr) +sortOrList = toOrList . sort . map sortEquation . toList + +-- Semantic equivalence +class SemEq a where + (===), (=/=) :: a -> a -> Bool + x =/= y = not (x === y) +-- x === y = not (x =/= y) + +infix 4 ===, =/= + +instance SemEq a => SemEq (Equation a) where + (a :==: b) === (c :==: d) = a === c && b === d || a === d && b === c + +instance SemEq Expr where + (===) = on (==) cleanUpExpr + +instance SemEq a => SemEq (OrList a) where + a === b = let as = toList a ; bs = toList b + in length (intersectBy (===) as bs) == length as + +-- y = root n x +takeRoot :: Integer -> Integer -> Maybe Integer +takeRoot n x + | n >= 0 && x >0 && a Prelude.^ x == n = Just a + | otherwise = Nothing + where + a = round (fromInteger n ** (1/fromInteger x) :: Double) +{- +| n == 0 = [0] + | n == 1 = if x > 0 && odd x then [1] else [1, -1] + | n == (-1) = [-1 | x > 0 && odd x] + | x == 1 = [n] + | x > 0 = maybe [] roots $ lookup x $ map swap $ PF.allPowers (abs n) + | otherwise = [] + where + roots r | n > 0 && even x = [r, negate r] + | n > 0 && odd x = [r] + | n < 0 && odd x = [negate r] + | otherwise = [] -} + +-- prop_takeRoot n = traceShow n f +-- where +-- f n x | x > 0 = n `elem` (takeRoot (n Prelude.^ x) x) +-- | otherwise = True + +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) + +split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])] +split op xs = f xs + where + f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys + | otherwise = [] + f [] = [] + +toMaybe :: (a -> Bool) -> a -> Maybe a +toMaybe p x = if p x then Just x else Nothing + +joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]] +joinBy _ [] = [] +joinBy eq xs = ys : joinBy eq (xs \\ ys) + where + ys = dropUntil eq xs + +dropUntil :: (a -> a -> Bool) -> [a] -> [a] +dropUntil _ [] = [] +dropUntil _ [x] = [x] +dropUntil p (x:y:ys) | p x y = x : dropUntil p (y:ys) + | otherwise = [x] + +holes :: [a] -> [(a, [a], a -> [a])] +holes xs = map f [0 .. length xs - 1] + where + f i = let (ys, z:zs) = splitAt i xs + in (z, ys ++ zs, \x -> ys ++ x:zs) + +twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])] +twoNonAdjacentHoles xs = concatMap g pairs + where + pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]] + g (x, y) = let (ys, z:zs) = splitAt x xs + (ps, q:qs) = splitAt (y - x - 1) zs + in if null ps + then [ ((z, q), \a -> ys ++ a:ps ++ qs) ] + else [ ((z, q), \a -> ys ++ a:ps ++ qs) , ((z, q), \a -> ys ++ ps ++ a:qs) ] diff --git a/src/Domain/Math/Power/Views.hs b/src/Domain/Math/Power/Views.hs --- a/src/Domain/Math/Power/Views.hs +++ b/src/Domain/Math/Power/Views.hs @@ -1,160 +1,132 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : alex.gerdes@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Domain.Math.Power.Views - ( -- * Power views - powerView, powerViewWith, powerViewForWith, powerViewFor, powerFactorView - , consPowerView, consPowerViewForWith, consPowerViewFor,consPowerViewForVar - , unitPowerViewForVar, unitPowerViewVar, unitPowerView, strictPowerView - , rootView, strictRootView - -- * Log view - , logView - -- * Other views - , plainNatView, plainRationalView, varView - ) where - -import Control.Arrow ( (>>^) ) -import Control.Monad -import Common.Rewriting -import Common.View -import Domain.Math.Expr -import Domain.Math.Power.Utils - - --- | Power views with constant factor ----------------------------------------- - -consPowerView :: View Expr (Expr, (Expr, Expr)) -consPowerView = addNegativeView $ addUnitTimesView powerView - -consPowerViewForWith :: Num a => View Expr a -> View Expr b -> a -> View Expr (Expr, b) -consPowerViewForWith va vb a = - addNegativeView $ addUnitTimesView (powerViewForWith va vb a) - -consPowerViewFor :: Expr -> View Expr (Expr, Expr) -consPowerViewFor = consPowerViewForWith identity identity - -consPowerViewForVar :: String -> View Expr (Expr, Expr) -consPowerViewForVar = consPowerViewFor . Var - -unitPowerViewForVar :: String -> View Expr (Expr, Expr) -unitPowerViewForVar s = makeView f g - where - f expr = do - (c, (s', x)) <- match unitPowerViewVar expr - guard $ s == s' - return (c, x) - g (c, x) = build unitPowerViewVar (c , (s, x)) - -unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr)) -unitPowerViewWith v = addNegativeView $ addUnitTimesView $ - powerViewWith v identity <&> (unitTimes v >>^ swap) - -unitPowerViewVar :: View Expr (Expr, (String, Expr)) -unitPowerViewVar = unitPowerViewWith varView - --- | Careful! This view will match anything, so use it wise and with care. -unitPowerView :: View Expr (Expr, (Expr, Expr)) -unitPowerView = unitPowerViewWith identity - --- | A root view -rootView :: View Expr (Expr, Expr) -rootView = makeView f (uncurry root) - where - f expr = do - (a, (x, y)) <- match (powerView >>> second divView) expr - guard (x == 1 || x == -1) - return $ if x == 1 then (a, y) else (a, negate y) - --- | only matches sqrt and root -strictRootView :: View Expr (Expr, Expr) -strictRootView = makeView f g - where - f expr = - case expr of - Sym s [a, b] | isRootSymbol s -> return (a, b) - Sqrt e -> return (e, 2) - _ -> Nothing - - g (a, b) = if b == 2 then Sqrt a else root a b - - --- | Power views -------------------------------------------------------------- - -strictPowerView :: View Expr (Expr, Expr) -strictPowerView = makeView f (uncurry (.^.)) - where - f expr = - case expr of - Sym s [a, b] | isPowerSymbol s -> return (a, b) - _ -> Nothing - -powerView :: View Expr (Expr, Expr) -powerView = makeView f g - where - f = match ((strictRootView >>^ h) <&> strictPowerView) - h (a, b) = (a, 1 ./. b) - g (a, b) = - case b of - (Nat 1 :/: b') -> build strictRootView (a, b') - _ -> build strictPowerView (a, b) - -powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b) -powerViewWith va vb = powerView >>> first va >>> second vb - -powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b -powerViewForWith va vb a = makeView f ((build va a .^.) . build vb) - where - f expr = do - (a', b) <- match (powerViewWith va vb) expr - guard $ a == a' - return b - -powerViewFor :: Expr -> View Expr Expr -powerViewFor = powerViewForWith identity identity - -powerFactorView :: (Expr -> Expr -> Bool) -> View Expr (Bool, [Expr]) -powerFactorView p = productView >>> second (makeView f id) - where - f = Just . map (build productView . (,) False) . joinBy p - --- | Log views ---------------------------------------------------------------- - -logView :: View Expr (Expr, Expr) -logView = makeView f (uncurry logBase) - where - f expr = case expr of - Sym s [a, b] | isLogSymbol s -> return (a, b) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Domain.Math.Power.Views + ( -- * Power views + -- ** Simple power views + powerView, powerViewWith, powerViewFor, powerFactorView + -- ** Views for power expressions with a constant factor + , consPowerView + -- ** Power views that allow constants + , unitPowerView, unitPowerViewVar, strictPowerView + -- Root views + , rootView, strictRootView + -- * Log view + , logView + -- * Other views + , plainNatView, plainRationalView + ) where + +import Common.Library hiding (root) +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Power.Utils + +-- Power views with constant factor ----------------------------------------- + +consPowerView :: View Expr (Expr, (Expr, Expr)) +consPowerView = makeView f g + where + f (Negate a) = fmap (first Negate) (f a) + f (a :*: b) = fmap ((,) a) (match powerView b) + f expr = f (1 :*: expr) + g = build (timesView >>> second powerView) + +unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr)) +unitPowerViewWith v = makeView f g + where + mv = powerViewWith v identity + f (Negate a) = fmap (first Negate) (f a) + f (a :*: b) = do + x <- match mv b + return (a, x) + `mplus` do + x <- match v b + return (a, (x, 1)) + f expr = f (1 :*: expr) + g = build (timesView >>> second mv) + +unitPowerViewVar :: View Expr (Expr, (String, Expr)) +unitPowerViewVar = unitPowerViewWith variableView + +-- | Careful! This view will match anything, so use it wise and with care. +unitPowerView :: View Expr (Expr, (Expr, Expr)) +unitPowerView = unitPowerViewWith identity + +-- | A root view +rootView :: View Expr (Expr, Expr) +rootView = makeView f (uncurry root) + where + f expr = do + (a, (x, y)) <- match (powerView >>> second divView) expr + guard (x `elem` [1, -1]) + return $ if x == 1 then (a, y) else (a, negate y) + +-- | only matches sqrt and root +strictRootView :: View Expr (Expr, Expr) +strictRootView = makeView f g + where + f expr = + case expr of + Sym s [a, b] | isRootSymbol s -> return (a, b) + Sqrt e -> return (e, 2) + _ -> Nothing + + g (a, b) = if b == 2 then Sqrt a else root a b + +-- Power views -------------------------------------------------------------- + +strictPowerView :: View Expr (Expr, Expr) +strictPowerView = makeView f (uncurry (.^.)) + where + f expr = + case expr of + Sym s [a, b] | isPowerSymbol s -> return (a, b) + _ -> Nothing + +powerView :: View Expr (Expr, Expr) +powerView = matcherView f g + where + f = matcher (strictRootView >>> second (arr (1 ./.))) + <+> matcher strictPowerView + g (a, b) = + case b of + (Nat 1 :/: b') -> build strictRootView (a, b') + _ -> build strictPowerView (a, b) + +powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b) +powerViewWith va vb = powerView >>> (va *** vb) + +powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b +powerViewForWith va vb a = makeView f ((build va a .^.) . build vb) + where + f expr = do + (a', b) <- match (powerViewWith va vb) expr + guard $ a == a' + return b + +powerViewFor :: Expr -> View Expr Expr +powerViewFor = powerViewForWith identity identity + +powerFactorView :: (Expr -> Expr -> Bool) -> Isomorphism Expr (Bool, [Expr]) +powerFactorView p = productView >>> second (f <-> id) + where + f = map (build productView . (,) False) . joinBy p + +-- Log views ---------------------------------------------------------------- + +logView :: View Expr (Expr, Expr) +logView = makeView f (uncurry logBase) + where + f expr = case expr of + Sym s [a, b] | isLogSymbol s -> return (a, b) _ -> Nothing - - --- | Help (non-power) views --------------------------------------------------- - -unitTimes :: Num t => View a b -> View a (t, b) -unitTimes = (>>^ (,) 1) - -addTimesView :: View Expr a -> View Expr (Expr, a) -addTimesView v = timesView >>> second v - -addUnitTimesView :: View Expr a -> View Expr (Expr, a) -addUnitTimesView v = addTimesView v <&> unitTimes v - -negateView :: (Num a, WithFunctions a) => View a a -negateView = makeView isNegate negate - -addNegativeView :: View Expr a -> View Expr a -addNegativeView v = v <&> (negateView >>> v) - -varView :: View Expr String -varView = makeView f Var - where - f (Var s) = Just s - f _ = Nothing diff --git a/src/Domain/Math/Safe.hs b/src/Domain/Math/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Safe.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Safe + ( -- * Safe division + SafeDiv(..), safeDivFractional + , -- * Safe power and root + SafePower(..) + ) where + +import Data.Ratio + +------------------------------------------------------------------- +-- Safe division + +class Num a => SafeDiv a where + safeDiv :: a -> a -> Maybe a + safeRecip :: a -> Maybe a + -- default definitions + safeRecip = safeDiv 1 + +instance SafeDiv Integer where + safeDiv x y + | y /= 0 && m == 0 = Just d + | otherwise = Nothing + where (d, m) = x `divMod` y + +instance SafeDiv Double where + safeDiv = safeDivFractional + +instance Integral a => SafeDiv (Ratio a) where + safeDiv = safeDivFractional + +safeDivFractional :: Fractional a => a -> a -> Maybe a +safeDivFractional x y + | y /= 0 = Just (x / y) + | otherwise = Nothing + +------------------------------------------------------------------- +-- Safe power and root + +class Num a => SafePower a where + safePower :: a -> a -> Maybe a + safeSqrt :: a -> Maybe a + safeRoot :: a -> a -> Maybe a + -- default definitions + safeSqrt = (`safeRoot` 2) + +instance SafePower Integer where + safeRoot _ _ = Nothing + safePower x y + | y >= 0 = Just (x ^ y) + | otherwise = Nothing + +instance Integral a => SafePower (Ratio a) where + safeRoot _ _ = Nothing + safePower x y + | denominator y /= 1 = Nothing + | numerator y >= 0 = Just a + | otherwise = Just (1/a) + where + a = x ^ abs (numerator y) + +instance SafePower Double where + safePower x y + | x==0 && y<0 = Nothing + | otherwise = Just (x**y) + safeRoot x y + | x >= 0 && y >= 1 = Just (x ** (1/y)) + | otherwise = Nothing diff --git a/src/Domain/Math/Simplification.hs b/src/Domain/Math/Simplification.hs --- a/src/Domain/Math/Simplification.hs +++ b/src/Domain/Math/Simplification.hs @@ -1,230 +1,209 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.Simplification - ( Simplify(..), SimplifyConfig(..), smartConstructors - , simplifyConfig - , Simplified, simplified, liftS, liftS2 - , simplifyRule - , mergeAlike, distribution, constantFolding - , mergeAlikeSum, mergeAlikeProduct - ) where - -import Common.Context -import Common.Navigator -import Common.Transformation -import Common.Uniplate -import Common.View hiding (simplify, simplifyWith) -import Control.Monad -import Data.List -import Data.Maybe -import Domain.Math.Data.Relation -import Domain.Math.Expr hiding (recip) -import Domain.Math.Numeric.Views -import Domain.Math.SquareRoot.Views -import Test.QuickCheck -import qualified Common.View as View - - -data SimplifyConfig = SimplifyConfig - { withSmartConstructors :: Bool - , withMergeAlike :: Bool - , withDistribution :: Bool - , withSimplifySquareRoot :: Bool - , withConstantFolding :: Bool - } - -class Simplify a where - simplifyWith :: SimplifyConfig -> a -> a - simplify :: a -> a - simplify = simplifyWith simplifyConfig - -simplifyConfig :: SimplifyConfig -simplifyConfig = SimplifyConfig True True True True True - -instance Simplify a => Simplify (Context a) where - simplifyWith cfg = change $ simplifyWith cfg - -instance Simplify a => Simplify (Equation a) where - simplifyWith cfg = fmap $ simplifyWith cfg - -instance Simplify a => Simplify (Relation a) where - simplifyWith cfg = fmap $ simplifyWith cfg - -instance Simplify a => Simplify [a] where - simplifyWith cfg = fmap $ simplifyWith cfg - -instance Simplify Expr where - simplifyWith cfg = let optional p f = if p then f else id in - optional (withSmartConstructors cfg) smartConstructors - . optional (withMergeAlike cfg) mergeAlike - . optional (withDistribution cfg) distribution - . optional (withSimplifySquareRoot cfg) (View.simplify - (squareRootViewWith rationalView)) - . optional (withConstantFolding cfg) constantFolding - -instance Simplify a => Simplify (Rule a) where - simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards - -data Simplified a = S a deriving (Eq, Ord) - -instance Show a => Show (Simplified a) where - show (S x) = show x - -instance (Num a, Simplify a) => Num (Simplified a) where - (+) = liftS2 (+) - (*) = liftS2 (*) - (-) = liftS2 (-) - negate = liftS negate - abs = liftS abs - signum = liftS signum - fromInteger = simplified . fromInteger - -instance (Fractional a, Simplify a) => Fractional (Simplified a) where - (/) = liftS2 (/) - recip = liftS recip - fromRational = simplified . fromRational - -instance (Floating a, Simplify a) => Floating (Simplified a) where - pi = simplified pi - sqrt = liftS sqrt - (**) = liftS2 (**) - logBase = liftS2 logBase - exp = liftS exp - log = liftS log - sin = liftS sin - tan = liftS tan - cos = liftS cos - asin = liftS asin - atan = liftS atan - acos = liftS acos - sinh = liftS sinh - tanh = liftS tanh - cosh = liftS cosh - asinh = liftS asinh - atanh = liftS atanh - acosh = liftS acosh - -instance Simplify (Simplified a) where - simplifyWith _ = id - -instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where - toTerm (S x) = toTerm x - fromTerm = liftM simplified . fromTerm - -instance (Arbitrary a, Simplify a) => Arbitrary (Simplified a) where - arbitrary = liftM simplified arbitrary -instance (CoArbitrary a, Simplify a) => CoArbitrary (Simplified a) where - coarbitrary (S x) = coarbitrary x - -simplified :: Simplify a => a -> Simplified a -simplified = S . simplify - -liftS :: Simplify a => (a -> a) -> Simplified a -> Simplified a -liftS f (S x) = simplified (f x) - -liftS2 :: Simplify a => (a -> a -> a) -> Simplified a -> Simplified a -> Simplified a -liftS2 f (S x) (S y) = simplified (f x y) - -simplifyRule :: Simplify a => Rule a -simplifyRule = simplify idRule - ------------------------------------------------------------- --- Simplification with the smart constructors - -smartConstructors :: Expr -> Expr -smartConstructors = transform $ \expr -> - case expr of - a :+: b -> a .+. b - a :-: b -> a .-. b - Negate a -> neg a - a :*: b -> a .*. b - a :/: b -> a ./. b - Sym s [a, b] | isPowerSymbol s -> - a .^. b - _ -> expr - -------------------------------------------------------------- --- Distribution of constants - -distribution :: Expr -> Expr -distribution = descend distribution . f - where - f expr = - fromMaybe expr $ - case expr of - a :*: b -> do - (x, y) <- match plusView a - r <- match rationalView b - return $ (fromRational r .*. x) .+. (fromRational r .*. y) - `mplus` do - r <- match rationalView a - (x, y) <- match plusView b - return $ (fromRational r .*. x) .+. (fromRational r .*. y) - a :/: b -> do - xs <- match sumView a - guard (length xs > 1) - return $ build sumView $ map (./. b) xs - _ -> Nothing - -------------------------------------------------------------- --- Constant folding - --- Not an efficient implementation: could be improved if necessary -constantFolding :: Expr -> Expr -constantFolding expr = - case match rationalView expr of - Just r -> fromRational r - Nothing -> descend constantFolding expr - ----------------------------------------------------------------------- --- merge alike for sums and products - -mergeAlike :: Expr -> Expr -mergeAlike a = - case (match sumView a, match productView a) of - (Just xs, _) | length xs > 1 -> - build sumView (sort $ mergeAlikeSum $ map mergeAlike xs) - (_, Just (b, ys)) | length (filter (/= 1) ys) > 1 -> - build productView (b, sort $ mergeAlikeProduct $ map mergeAlike ys) - _ -> a - -mergeAlikeProduct :: [Expr] -> [Expr] -mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ] - where - f [] = [] - f ((Nothing , e):xs) = e:f xs - f ((Just r , _):xs) = - let cs = r : [ c | (Just c, _) <- xs ] - rest = [ x | (Nothing, x) <- xs ] - in build rationalView (product cs):rest - -mergeAlikeSum :: [Expr] -> [Expr] -mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ] - where - pm :: Rational -> Expr -> (Rational, Expr) - pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of - (Just r1, _) -> pm (r*r1) e2 - (_, Just r1) -> pm (r*r1) e1 - _ -> (r, e1 .*. e2) - pm r (Negate e) = pm (negate r) e - pm r e = case match rationalView e of - Just r1 -> (r*r1, Nat 1) - Nothing -> (r, e) - - rec [] = [] - rec ((Nothing, e):ys) = e:rec ys - rec ((Just (r, a), e):ys) = new:rec rest - where - (js, rest) = partition (maybe False ((==a) . snd) . fst) ys - rs = r:map fst (mapMaybe fst js) - new | null js = e +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Simplification + ( Simplify(..), SimplifyConfig(..) + , simplifyConfig + , Simplified, simplified, liftS, liftS2 + , simplifyRule + , collectLikeTerms, mergeAlike, distribution, constantFolding + , mergeAlikeSum, mergeAlikeProduct + ) where + +import Common.Library hiding (simplify, simplifyWith) +import Common.Utils.Uniplate +import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.CleanUp (smart) +import Domain.Math.Data.Relation +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.SquareRoot.Views +import qualified Common.View as View + +data SimplifyConfig = SimplifyConfig + { withSmartConstructors :: Bool + , withMergeAlike :: Bool + , withDistribution :: Bool + , withSimplifySquareRoot :: Bool + , withConstantFolding :: Bool + } + +class Simplify a where + simplifyWith :: SimplifyConfig -> a -> a + simplify :: a -> a + simplify = simplifyWith simplifyConfig + +simplifyConfig :: SimplifyConfig +simplifyConfig = SimplifyConfig True True True True True + +instance Simplify a => Simplify (Context a) where + simplifyWith cfg = change $ simplifyWith cfg + +instance Simplify a => Simplify (Equation a) where + simplifyWith cfg = fmap $ simplifyWith cfg + +instance Simplify a => Simplify (Relation a) where + simplifyWith cfg = fmap $ simplifyWith cfg + +instance Simplify a => Simplify [a] where + simplifyWith cfg = fmap $ simplifyWith cfg + +instance Simplify Expr where + simplifyWith cfg = let optional p f = if p then f else id in + optional (withSmartConstructors cfg) (transform smart) + . optional (withMergeAlike cfg) mergeAlike + . optional (withDistribution cfg) distribution + . optional (withSimplifySquareRoot cfg) (View.simplify + (squareRootViewWith rationalView)) + . optional (withConstantFolding cfg) constantFolding + +instance Simplify a => Simplify (Rule a) where + simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards + +data Simplified a = S a deriving (Eq, Ord) + +instance Show a => Show (Simplified a) where + show (S x) = show x + +instance (Num a, Simplify a) => Num (Simplified a) where + (+) = liftS2 (+) + (*) = liftS2 (*) + (-) = liftS2 (-) + negate = liftS negate + abs = liftS abs + signum = liftS signum + fromInteger = simplified . fromInteger + +instance (Fractional a, Simplify a) => Fractional (Simplified a) where + (/) = liftS2 (/) + recip = liftS recip + fromRational = simplified . fromRational + +instance (Floating a, Simplify a) => Floating (Simplified a) where + pi = simplified pi + sqrt = liftS sqrt + (**) = liftS2 (**) + logBase = liftS2 logBase + exp = liftS exp + log = liftS log + sin = liftS sin + tan = liftS tan + cos = liftS cos + asin = liftS asin + atan = liftS atan + acos = liftS acos + sinh = liftS sinh + tanh = liftS tanh + cosh = liftS cosh + asinh = liftS asinh + atanh = liftS atanh + acosh = liftS acosh + +instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where + toTerm (S x) = toTerm x + fromTerm = liftM simplified . fromTerm + +simplified :: Simplify a => a -> Simplified a +simplified = S . simplify + +liftS :: Simplify a => (a -> a) -> Simplified a -> Simplified a +liftS f (S x) = simplified (f x) + +liftS2 :: Simplify a => (a -> a -> a) -> Simplified a -> Simplified a -> Simplified a +liftS2 f (S x) (S y) = simplified (f x y) + +simplifyRule :: Simplify a => Rule a +simplifyRule = simplify idRule + +------------------------------------------------------------- +-- Distribution of constants + +distribution :: Expr -> Expr +distribution = descend distribution . f + where + f expr = + fromMaybe expr $ + case expr of + a :*: b -> do + (x, y) <- match plusView a + r <- match rationalView b + return $ (fromRational r .*. x) .+. (fromRational r .*. y) + `mplus` do + r <- match rationalView a + (x, y) <- match plusView b + return $ (fromRational r .*. x) .+. (fromRational r .*. y) + a :/: b -> do + xs <- match sumView a + guard (length xs > 1) + return $ build sumView $ map (./. b) xs + _ -> Nothing + +------------------------------------------------------------- +-- Constant folding + +-- Not an efficient implementation: could be improved if necessary +constantFolding :: Expr -> Expr +constantFolding expr = + case match rationalView expr of + Just r -> fromRational r + Nothing -> descend constantFolding expr + +---------------------------------------------------------------------- +-- merge alike for sums and products + +-- Todo: combine with mergeAlike (subtle differences) +collectLikeTerms :: Expr -> Expr +collectLikeTerms = View.simplifyWith f sumView + where + f = mergeAlikeSum . map (View.simplifyWith (second mergeAlikeProduct) productView) + +mergeAlike :: Expr -> Expr +mergeAlike a = + case (match sumView a, match productView a) of + (Just xs, _) | length xs > 1 -> + build sumView (sort $ mergeAlikeSum $ map mergeAlike xs) + (_, Just (b, ys)) | length (filter (/= 1) ys) > 1 -> + build productView (b, sort $ mergeAlikeProduct $ map mergeAlike ys) + _ -> a + +mergeAlikeProduct :: [Expr] -> [Expr] +mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ] + where + f [] = [] + f ((Nothing , e):xs) = e:f xs + f ((Just r , _):xs) = + let cs = r : [ c | (Just c, _) <- xs ] + rest = [ x | (Nothing, x) <- xs ] + in build rationalView (product cs):rest + +mergeAlikeSum :: [Expr] -> [Expr] +mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ] + where + pm :: Rational -> Expr -> (Rational, Expr) + pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of + (Just r1, _) -> pm (r*r1) e2 + (_, Just r1) -> pm (r*r1) e1 + _ -> (r, e1 .*. e2) + pm r (Negate e) = pm (negate r) e + pm r e = case match rationalView e of + Just r1 -> (r*r1, Nat 1) + Nothing -> (r, e) + + rec [] = [] + rec ((Nothing, e):ys) = e:rec ys + rec ((Just (r, a), e):ys) = new:rec rest + where + (js, rest) = partition (maybe False ((==a) . snd) . fst) ys + rs = r:map fst (mapMaybe fst js) + new | null js = e | otherwise = build rationalView (sum rs) .*. a 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 @@ -1,33 +1,29 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.SquareRoot.Tests (tests) where - -import Control.Monad -import Test.QuickCheck -import Domain.Math.Data.SquareRoot -import Domain.Math.Numeric.Laws -import Common.TestSuite - -------------------------------------------------------------------- --- Testing - -tests :: TestSuite -tests = - testNumLaws "square roots" squareRootGen - -- testFracLaws "square roots" squareRootGen - -squareRootGen :: Gen (SquareRoot Rational) -squareRootGen = do - n <- choose (0, 10) - let f r1 r2 = fromRational r1 * sqrtRational (abs r2) - ps <- replicateM n $ liftM2 f arbitrary arbitrary - return (sum ps) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.SquareRoot.Tests (tests) where + +import Common.Algebra.Field +import Common.Algebra.Group +import Common.Algebra.Law +import Common.Utils.TestSuite +import Domain.Math.Data.SquareRoot + +------------------------------------------------------------------- +-- Testing + +tests :: TestSuite +tests = mapM_ f $ commutativeRingLaws ++ + distributiveSubtractionLaws ++ + map fromAdditiveLaw appendInverseLaws + where + f :: Law (SafeNum (SquareRoot Rational)) -> TestSuite + f p = addProperty (show p) p diff --git a/src/Domain/Math/SquareRoot/Views.hs b/src/Domain/Math/SquareRoot/Views.hs --- a/src/Domain/Math/SquareRoot/Views.hs +++ b/src/Domain/Math/SquareRoot/Views.hs @@ -1,45 +1,50 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Domain.Math.SquareRoot.Views - ( squareRootView, squareRootViewWith - ) where - -import Control.Monad -import Common.View -import Domain.Math.Numeric.Views -import Domain.Math.Expr hiding ((^)) -import Domain.Math.Data.SquareRoot - -squareRootView :: View Expr (SquareRoot Expr) -squareRootView = squareRootViewWith identity - -squareRootViewWith :: Fractional a => View Expr a -> View Expr (SquareRoot a) -squareRootViewWith v = makeView f g - where - f expr = - case expr of - Nat a -> Just (fromIntegral a) - a :+: b -> liftM2 (+) (f a) (f b) - a :-: b -> liftM2 (-) (f a) (f b) - Negate a -> fmap negate (f a) - a :*: b -> liftM2 (*) (f a) (f b) - a :/: b -> join $ liftM2 fracDiv (f a) (f b) - Sqrt a -> fmap sqrtRational (match rationalView a) - Sym s [a, b] | isPowerSymbol s -> - liftM2 (^) (f a) (match integerView b) - _ -> fmap con (match v expr) - - g = build sumView . map h . toList - h (a, n) - | n == 0 = 0 - | n == 1 = build v a +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.SquareRoot.Views + ( squareRootView, squareRootViewWith + ) where + +import Common.View +import Control.Monad +import Domain.Math.Data.SquareRoot +import Domain.Math.Expr hiding ((^)) +import Domain.Math.Numeric.Views +import Domain.Math.Safe + +squareRootView :: View Expr (SquareRoot Expr) +squareRootView = squareRootViewWith identity + +squareRootViewWith :: Fractional a => View Expr a -> View Expr (SquareRoot a) +squareRootViewWith v = makeView f g + where + f expr = + case expr of + Nat a -> Just (fromIntegral a) + a :+: b -> liftM2 (+) (f a) (f b) + a :-: b -> liftM2 (-) (f a) (f b) + Negate a -> fmap negate (f a) + a :*: b -> liftM2 (*) (f a) (f b) + a :/: b -> join $ liftM2 safeDiv (f a) (f b) + Sqrt a -> fmap sqrtRational (match rationalView a) + Sym s [a, b] | isPowerSymbol s -> + liftM2 power (f a) (match integerView b) + _ -> fmap con (match v expr) + + power a n + | n >= 0 = a ^ n + | otherwise = 1 / (a ^ abs n) + + g = to sumView . map h . toList + h (a, n) + | n == 0 = 0 + | n == 1 = build v a | otherwise = build v a .*. Sqrt (fromIntegral n) diff --git a/src/Domain/RelationAlgebra.hs b/src/Domain/RelationAlgebra.hs --- a/src/Domain/RelationAlgebra.hs +++ b/src/Domain/RelationAlgebra.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,30 +9,23 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Domain.RelationAlgebra - ( module Domain.RelationAlgebra.Formula - , module Domain.RelationAlgebra.Rules - , module Domain.RelationAlgebra.Exercises - , module Domain.RelationAlgebra.Strategies - , module Domain.RelationAlgebra.Generator - , module Domain.RelationAlgebra.Parser - ) where - -import Domain.RelationAlgebra.Formula -import Domain.RelationAlgebra.Rules -import Domain.RelationAlgebra.Exercises -import Domain.RelationAlgebra.Strategies -import Domain.RelationAlgebra.Generator -import Domain.RelationAlgebra.Parser +module Domain.RelationAlgebra (module Export) where + +import Domain.RelationAlgebra.Exercises as Export +import Domain.RelationAlgebra.Formula as Export +import Domain.RelationAlgebra.Generator as Export +import Domain.RelationAlgebra.Parser as Export +import Domain.RelationAlgebra.Rules as Export +import Domain.RelationAlgebra.Strategies as Export -- import Domain.RelationAlgebra.Equivalence {- -import Test.QuickCheck -import System.Random -import Data.List import Common.Classes -import Common.Context +import Common.Context import Control.Monad +import Data.List +import System.Random +import Test.QuickCheck nrpairs = 2000 -- 20000 @@ -41,9 +34,9 @@ pairs :: [(RelAlg, RelAlg)] pairs = take nrpairs $ generate 100 (mkStdGen 280578) (repeatM arbitrary) - + precision :: IO () -precision = do +precision = do let f (x, y) = probablyEqualWithG (mkStdGen 28) x y ms = map f pairs freq = map g $ group $ sort ms @@ -51,14 +44,14 @@ g xs@(x:_) = (x, length xs) h n = let score = sum [ i | (Just m, i) <- freq, m <= n ] in putStrLn $ show n ++ ": " ++ showPerc (nrpairs - score - dif) - troubles = [ (norm p, norm q) | (Nothing, (p, q)) <- zip ms pairs ] + troubles = [ (norm p, norm q) | (Nothing, (p, q)) <- zip ms pairs ] len = length unknown dif = length troubles - len - unknown = -- map (\(a,b) -> (a, b, isEquivalent a b)) $ + unknown = -- map (\(a,b) -> (a, b, isEquivalent a b)) $ filter (\(a,b) -> a /= b) troubles putStrLn $ map (maybe '!' (const '.')) ms mapM_ h is - + putStrLn $ unlines $ map show unknown putStrLn $ "(" ++ show len ++ " unknown)" diff --git a/src/Domain/RelationAlgebra/Exercises.hs b/src/Domain/RelationAlgebra/Exercises.hs --- a/src/Domain/RelationAlgebra/Exercises.hs +++ b/src/Domain/RelationAlgebra/Exercises.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,43 +11,36 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Exercises (cnfExercise) where -import Prelude hiding (repeat) +import Common.Library +import Data.Maybe import Domain.RelationAlgebra.Formula import Domain.RelationAlgebra.Generator -import Domain.RelationAlgebra.Strategies -import Domain.RelationAlgebra.Rules import Domain.RelationAlgebra.Parser -import Common.Classes -import Common.Exercise -import Common.Context -import Data.Maybe -import Common.Derivation -import Common.Rewriting (differenceMode) -import Common.Strategy hiding (not) -import Common.Transformation -import Common.Navigator +import Domain.RelationAlgebra.Rules +import Domain.RelationAlgebra.Strategies +import Prelude hiding (repeat) +import Test.QuickCheck cnfExercise :: Exercise RelAlg -cnfExercise = testableExercise +cnfExercise = makeExercise { exerciseId = describe "To conjunctive normal form" $ newId "relationalgebra.cnf" , status = Alpha , parser = parseRelAlg , prettyPrinter = ppRelAlg - , equivalence = probablyEqual -- isEquivalent + , equivalence = withoutContext probablyEqual -- isEquivalent , extraRules = map liftToContext (relAlgRules ++ buggyRelAlgRules) , strategy = toCNF , navigation = navigator - , difference = differenceMode probablyEqual - , ordering = compare - , isReady = ready cnfExercise + , ready = predicate (myReady cnfExercise) , randomExercise = let ok p = let n = fromMaybe maxBound (stepsRemaining 4 p) in n >= 2 && n <= 4 in useGenerator ok (\_ -> templateGenerator 1) + , testGenerator = Just arbitrary } stepsRemaining :: Int -> RelAlg -> Maybe Int -stepsRemaining i = +stepsRemaining i = lengthMax i . derivationTree toCNF . inContext cnfExercise {- cnfExerciseSimple :: Exercise RelAlg @@ -56,7 +49,7 @@ , description = description cnfExercise ++ " (simple)" , strategy = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise } -} - -ready :: Exercise a -> a -> Bool -ready ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex)) + +myReady :: Exercise a -> a -> Bool +myReady ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex)) . inContext ex diff --git a/src/Domain/RelationAlgebra/Formula.hs b/src/Domain/RelationAlgebra/Formula.hs --- a/src/Domain/RelationAlgebra/Formula.hs +++ b/src/Domain/RelationAlgebra/Formula.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,19 +11,19 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Formula where -import Common.Uniplate (Uniplate(..)) import Common.Rewriting import Common.Utils +import Common.Utils.Uniplate import Control.Monad import Data.List -import qualified Data.Set as S import System.Random (StdGen, mkStdGen, split, randomR) import Test.QuickCheck import Test.QuickCheck.Gen +import qualified Data.Set as S infixr 2 :.: -infixr 3 :+: -infixr 4 :||: +infixr 3 :+: +infixr 4 :||: infixr 5 :&&: -- | The data type RelAlg is the abstract syntax for the domain @@ -47,7 +47,7 @@ ------------------------------------- isAtom :: RelAlg -> Bool -isAtom r = +isAtom r = case r of Var _ -> True Not I -> True @@ -58,20 +58,20 @@ V -> True I -> True _ -> False - + isMolecule :: RelAlg -> Bool isMolecule (r :.: s) = isMolecule r && isMolecule s isMolecule (r :+: s) = isMolecule r && isMolecule s isMolecule r = isAtom r - + isDisj :: RelAlg -> Bool isDisj (r :||: s) = isDisj r && isDisj s isDisj r = isMolecule r - + isCNF :: RelAlg -> Bool isCNF (r :&&: s) = isCNF r && isCNF s isCNF r = isDisj r - + -- | The type RelAlgAlgebra is the algebra for the data type RelAlg -- | Used in the fold for RelAlg. type RelAlgAlgebra a = (String -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a -> a, a, a) @@ -89,20 +89,20 @@ p :||: q -> rec p `disj` rec q Not p -> neg (rec p) Inv p -> inv (rec p) - V -> univ + V -> univ I -> ident type Relation a = S.Set (a, a) evalRelAlg :: Ord a => (String -> Relation a) -> [a] -> RelAlg -> Relation a -evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) +evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) where pairs = cartesian as as - + comp p q = let f (a1, a2) c = (a1, c) `S.member` p && (c, a2) `S.member` q - in S.fromAscList [ x | x <- pairs, any (f x) as ] + in S.fromAscList [ x | x <- pairs, any (f x) as ] add p q = let f (a1, a2) c = (a1, c) `S.member` p || (c, a2) `S.member` q - in S.fromAscList [ x | x <- pairs, all (f x) as ] + in S.fromAscList [ x | x <- pairs, all (f x) as ] conj = S.intersection disj = S.union neg p = S.fromAscList [ x | x <- pairs, x `S.notMember` p ] @@ -125,7 +125,7 @@ makeRngs n g | n == 0 = [] | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2 - eval g = + eval g = let MkGen f = arbRelations as (size, a) = randomR (0, 100) g in evalRelAlg (f a size) as @@ -136,20 +136,20 @@ -- Suitable for small domains (e.g., with just 2 elements) arbRelation :: Eq a => [a] -> Gen (Relation a) arbRelation as = do - let f _ = oneof $ map return [True, False] + let f _ = elements [True, False] xs <- filterM f (cartesian as as) return (S.fromAscList xs) -- Alternative relation generator, which works best for slightly -- larger domains (for instance, with 4 elements or more) arbRelationAlt:: Eq a => [a] -> Gen (Relation a) -arbRelationAlt as = do +arbRelationAlt as = do n <- choose (0, 100) let f x = do m <- choose (1::Int, 100) return [ x | n < m ] xs <- mapM f $ cartesian as as - return $ S.fromAscList $ concat xs + return $ S.fromAscList $ concat xs -- Test on a limited domain whether two relation algebra terms are equivalent (===) :: RelAlg -> RelAlg -> Property @@ -157,31 +157,31 @@ -- | Function varsRelAlg returns the variables that appear in a RelAlg expression. varsRelAlg :: RelAlg -> [String] -varsRelAlg = foldRelAlg (return, union, union, union, union, id, id, [], []) +varsRelAlg = foldRelAlg (return, union, union, union, union, id, id, [], []) instance Uniplate RelAlg where uniplate term = - case term of - s :.: t -> ([s, t], \[a, b] -> a :.: b) - s :+: t -> ([s, t], \[a, b] -> a :+: b) - s :&&: t -> ([s, t], \[a, b] -> a :&&: b) - s :||: t -> ([s, t], \[a, b] -> a :||: b) - Not s -> ([s], \[a] -> Not a) - Inv s -> ([s], \[a] -> Inv a) - _ -> ([], \[] -> term) - + case term of + s :.: t -> plate (:.:) |* s |* t + s :+: t -> plate (:+:) |* s |* t + s :&&: t -> plate (:&&:) |* s |* t + s :||: t -> plate (:||:) |* s |* t + Not s -> plate Not |* s + Inv s -> plate Inv |* s + _ -> plate term + instance Different RelAlg where different = (V, I) - --(var, comp, add, conj, disj, not, inverse, universe, ident) + instance IsTerm RelAlg where - toTerm = foldRelAlg + toTerm = foldRelAlg ( variable, binary compSymbol, binary addSymbol , binary conjSymbol , binary disjSymbol, unary notSymbol, unary invSymbol , symbol universeSymbol, symbol identSymbol ) - fromTerm a = + fromTerm a = fromTermWith f a `mplus` liftM Var (getVariable a) where f s [] @@ -196,7 +196,7 @@ | s == conjSymbol = return (x :&&: y) | s == disjSymbol = return (x :||: y) f _ _ = fail "fromTerm" - + compSymbol, addSymbol, conjSymbol, disjSymbol, notSymbol, invSymbol, universeSymbol, identSymbol :: Symbol compSymbol = relalgSymbol "comp" diff --git a/src/Domain/RelationAlgebra/Generator.hs b/src/Domain/RelationAlgebra/Generator.hs --- a/src/Domain/RelationAlgebra/Generator.hs +++ b/src/Domain/RelationAlgebra/Generator.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,45 +11,30 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Generator (templateGenerator) where -import Domain.RelationAlgebra.Formula -import Common.Rewriting import Control.Monad +import Domain.RelationAlgebra.Formula import Test.QuickCheck -instance Rewrite RelAlg - instance Arbitrary RelAlg where arbitrary = sized (arbRelAlg . min 8) -instance CoArbitrary RelAlg where - coarbitrary term = - case term of - Var x -> variant (0 :: Int) . coarbitrary x - p :.: q -> variant (1 :: Int) . coarbitrary p . coarbitrary q - p :+: q -> variant (2 :: Int) . coarbitrary p . coarbitrary q - p :&&: q -> variant (3 :: Int) . coarbitrary p . coarbitrary q - p :||: q -> variant (4 :: Int) . coarbitrary p . coarbitrary q - Not p -> variant (5 :: Int) . coarbitrary p - Inv p -> variant (6 :: Int) . coarbitrary p - V -> variant (7 :: Int) - I -> variant (8 :: Int) - + arbRelAlg :: Int -> Gen RelAlg -arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)] +arbRelAlg 0 = frequency [(8, liftM Var (elements relAlgVars)), (1, return V), (1, return empty), (1, return I)] arbRelAlg n = oneof [ arbRelAlg 0, binop (:.:), binop (:+:), binop (:&&:), binop (:||:) - , unop Not, unop Inv + , unop Not, unop Inv ] where binop op = liftM2 op rec rec unop op = liftM op rec - rec = arbRelAlg (n `div` 2) + rec = arbRelAlg (n `div` 2) relAlgVars :: [String] relAlgVars = ["q", "r", "s"] - + ------------------------------------------------------------------- -- Templates -template1, template2, template3, template4, template7, template8 :: +template1, template2, template3, template4, template7, template8 :: RelAlg -> RelAlg -> RelAlg -> RelAlg template5 :: RelAlg -> RelAlg -> RelAlg -> RelAlg -> RelAlg @@ -59,11 +44,11 @@ template2 x y z = Not(x :&&: (y :||: z)) template3 x y z = Inv(x :||: (y :&&: z)) template4 x y z = Inv (Not(x :&&: (y :||: z))) -template5 x y z v = Inv (Not((x :||: v) :&&: (y :||: z))) +template5 x y z v = Inv (Not((x :||: v) :&&: (y :||: z))) template6 mp a b mq = f1 (f2 (a :&&: b)) where f1 x = maybe x (:.: x) mp - f2 x = maybe x (x :.:) mq -template7 x y z = x :.: (y :||:z) + f2 x = maybe x (x :.:) mq +template7 x y z = x :.: (y :||:z) template8 x y z = x :||: Not (Inv (y :.: z) :&&: Not (Inv y :.: Inv z)) ------------------------------------------------------------------- @@ -85,7 +70,7 @@ use3 :: (a -> b -> c -> d) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> t -> Gen d use3 temp f g h n = liftM3 temp (f n) (g n) (h n) - + use4 :: (a -> b -> c -> d -> e) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> (t -> Gen d) -> t -> Gen e use4 temp f g h k n = liftM4 temp (f n) (g n) (h n) (k n) @@ -96,7 +81,7 @@ hulpgen2 n = liftM3 template7 (arbInvNotMol 1) (arbRelAlg n) (arbRelAlg n) arbInvNotMol :: Int -> Gen RelAlg -arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)] +arbInvNotMol 0 = frequency [(10, liftM Var (elements relAlgVars)), (1, return V), (1, return empty), (1, return I)] arbInvNotMol n = frequency [ (10, arbInvNotMol 0), (4, binop (:.:)), (4, binop (:+:)), (2, unop Not), (2, unop Inv) ] where binop op = liftM2 op rec rec @@ -107,4 +92,4 @@ arbMaybeInvNotMol n = frequency [(3, liftM Just (arbInvNotMol n)), (1, return Nothing)] arbVar :: Gen RelAlg -arbVar = liftM Var (oneof $ map return relAlgVars) +arbVar = liftM Var (elements relAlgVars) diff --git a/src/Domain/RelationAlgebra/Parser.hs b/src/Domain/RelationAlgebra/Parser.hs --- a/src/Domain/RelationAlgebra/Parser.hs +++ b/src/Domain/RelationAlgebra/Parser.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -13,79 +13,70 @@ import Domain.RelationAlgebra.Formula import Text.Parsing - -myScanner :: Scanner -myScanner = defaultScanner - { keywords = ["V", "E", "I"] - , keywordOperators = invSym : notSym : concatMap (map fst . snd) operatorTable - , specialCharacters = "-~" ++ specialCharacters defaultScanner - } - -operatorTable :: OperatorTable RelAlg -operatorTable = - [ (RightAssociative, [(orSym, (:||:))]) - , (RightAssociative, [(andSym, (:&&:))]) - , (NoMix, [(compSym, (:.:)), (addSym, (:+:))]) - ] +import qualified Text.ParserCombinators.Parsec.Token as P -andSym, orSym, addSym, compSym, notSym, invSym :: String -andSym = "/\\" -orSym = "\\/" -addSym = "!" -compSym = ";" -notSym = "-" -invSym = "~" - ----------------------------------------------------------- --- Parser parseRelAlg :: String -> Either String RelAlg -parseRelAlg = analyseAndParse pRelAlg . scanWith myScanner +parseRelAlg = parseSimple relalg + where + relalg = buildExpressionParser table term -pRelAlg :: Parser Token RelAlg -pRelAlg = pOperators operatorTable pTerm + term = foldl (flip ($)) <$> atom <*> many pUn --- Two postfix operators -pTerm :: Parser Token RelAlg -pTerm = foldl (flip ($)) <$> pAtom <*> pList pUnOp - where - pUnOp = Inv <$ pKey invSym - <|> Not <$ pKey notSym + pUn = choice + [ Inv <$ reservedOp "~" + , Not <$ reservedOp "-" + ] -pAtom :: Parser Token RelAlg -pAtom = Var <$> pVarid - <|> pParens pRelAlg - <|> const V <$> pKey "V" - <|> const empty <$> pKey "E" - <|> const I <$> pKey "I" + atom = choice + [ V <$ P.reserved lexer "V" + , empty <$ P.reserved lexer "E" + , I <$ P.reserved lexer "I" + , Var <$> P.identifier lexer + , P.parens lexer relalg + ] + table = + [ [ Infix ((:.:) <$ reservedOp ";") AssocRight -- or none-associative? + , Infix ((:+:) <$ reservedOp "!") AssocRight -- or none-associative? + ] + , [ Infix ((:&&:) <$ reservedOp "/\\") AssocRight ] + , [ Infix ((:||:) <$ reservedOp "\\/") AssocRight ] + ] + ----------------------------------------------------------- ---- Helper-function for parentheses analyses +--- Lexer -analyseAndParse :: Parser Token a -> [Token] -> Either String a -analyseAndParse p ts = - case checkParentheses ts of - Just err -> Left (show err) - Nothing -> either (Left . f) Right (parse p ts) - where - f (Just t) = show (tokenPosition t) ++ ": Unexpected " ++ show t - f Nothing = "Syntax error" - +lexer :: P.TokenParser a +lexer = P.makeTokenParser $ emptyDef + { reservedNames = ["V", "E", "I"] + , reservedOpNames = ["~", "-", ";", "!", "\\/", "/\\"] + , identStart = letter + , identLetter = letter + , opStart = fail "" + , opLetter = fail "" + } + +reservedOp :: String -> Parser () +reservedOp = P.reservedOp lexer + ----------------------------------------------------------- --- Pretty-Printer ppRelAlg :: RelAlg -> String ppRelAlg = ppRelAlgPrio (0, "") -ppRelAlgPrio :: (Int, String) -> RelAlg -> String +ppRelAlgPrio :: (Int, String) -> RelAlg -> String ppRelAlgPrio = (\f n -> f n "") . flip (foldRelAlg alg) where alg = (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/" , nott, inv, var "V", var "I" - ) - binop prio op p q (n, parent) = + ) + binop prio op p q (n, parent) = parIf (n > prio || (prio==4 && n==4 && op/=parent)) (p (prio+1, op) . ((" "++op++" ")++) . q (prio, op)) var = const . (++) - nott p _ = p (6, "") . ("-"++) + nott p _ = p (6, "") . ("-"++) inv p _ = p (6, "") . ("~"++) parIf b f = if b then ("("++) . f . (")"++) else f diff --git a/src/Domain/RelationAlgebra/Rules.hs b/src/Domain/RelationAlgebra/Rules.hs --- a/src/Domain/RelationAlgebra/Rules.hs +++ b/src/Domain/RelationAlgebra/Rules.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,11 +11,11 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Rules where -import Domain.RelationAlgebra.Formula -import Domain.RelationAlgebra.Generator() import Common.Id -import Common.Transformation (Rule, addRuleToGroup, buggyRule) import Common.Rewriting +import Common.Transformation (Rule, buggyRule) +import Domain.RelationAlgebra.Formula +import Domain.RelationAlgebra.Generator() import qualified Common.Transformation as Rule invRules :: [Rule RelAlg] @@ -24,16 +24,16 @@ ] compAddRules :: [Rule RelAlg] compAddRules = [ ruleCompOverUnion {- , ruleCompOverIntersec -} - , {- ruleAddOverUnion,-} ruleAddOverIntersec + , {- ruleAddOverUnion,-} ruleAddOverIntersec ] relAlgRules :: [Rule RelAlg] -relAlgRules = invRules ++ compAddRules ++ +relAlgRules = invRules ++ compAddRules ++ [ ruleUnionOverIntersec, ruleDeMorganOr, ruleDeMorganAnd, ruleIdempOr, ruleIdempAnd , ruleRemCompl, ruleDoubleNegation, ruleAbsorpCompl , ruleAbsorp, ruleRemRedunExprs, ruleNotOverComp , ruleNotOverAdd ] - + buggyRelAlgRules ::[Rule RelAlg] buggyRelAlgRules = [buggyRuleIdemComp, buggyRuleIdemAdd, buggyRuleDeMorgan , buggyRuleNotOverAdd, buggyRuleNotOverComp, buggyRuleParenth @@ -42,161 +42,132 @@ ] relalg :: IsId a => a -> Id -relalg = (#) "relationalgebra" +relalg = ( # ) "relationalgebra" -rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a +rule :: RuleBuilder f a => String -> f -> Rule a rule = Rule.rule . relalg -ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a +ruleList :: RuleBuilder f a => String -> [f] -> Rule a ruleList = Rule.ruleList . relalg - --- | 1. Alle ~ operatoren naar binnen verplaatsen -conversionGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a -conversionGroup s = - addRuleToGroup (relalg "Conversion") . rule s +-- | 1. Alle ~ operatoren naar binnen verplaatsen ruleInvOverUnion :: Rule RelAlg -ruleInvOverUnion = conversionGroup "InvOverUnion" $ +ruleInvOverUnion = rule "InvOverUnion" $ \r s -> Inv (r :||: s) :~> Inv r :||: Inv s ruleInvOverIntersec :: Rule RelAlg -ruleInvOverIntersec = conversionGroup "InvOverIntersect" $ +ruleInvOverIntersec = rule "InvOverIntersect" $ \r s -> Inv (r :&&: s) :~> Inv r :&&: Inv s --- !!!!!!! ALLEEN VOOR FUNCTIES ruleInvOverComp :: Rule RelAlg -ruleInvOverComp = conversionGroup "InvOverComp" $ +ruleInvOverComp = rule "InvOverComp" $ \r s -> Inv (r :.: s) :~> Inv s :.: Inv r ruleInvOverAdd :: Rule RelAlg -ruleInvOverAdd = conversionGroup "InvOverAdd" $ +ruleInvOverAdd = rule "InvOverAdd" $ \r s -> Inv (r :+: s) :~> Inv s :+: Inv r ruleInvOverNot :: Rule RelAlg -ruleInvOverNot = conversionGroup "InvOverNot" $ +ruleInvOverNot = rule "InvOverNot" $ \r -> Inv (Not r) :~> Not (Inv r) - + ruleDoubleInv :: Rule RelAlg -ruleDoubleInv = conversionGroup "DoubleInv" $ +ruleDoubleInv = rule "DoubleInv" $ \r -> Inv (Inv r) :~> r - - - --- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen -distributionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a -distributionGroup s = - addRuleToGroup (relalg "Distribution") . ruleList s +-- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen ruleCompOverUnion :: Rule RelAlg -ruleCompOverUnion = distributionGroup "CompOverUnion" - [ \q r s -> q :.: (r :||: s) :~> (q :.: r) :||: (q :.: s) - , \q r s -> (q :||: r) :.: s :~> (q :.: s) :||: (r :.: s) +ruleCompOverUnion = ruleList "CompOverUnion" + [ \q r s -> q :.: (r :||: s) :~> (q :.: r) :||: (q :.: s) + , \q r s -> (q :||: r) :.: s :~> (q :.: s) :||: (r :.: s) ] ruleCompOverIntersec :: Rule RelAlg -ruleCompOverIntersec = distributionGroup "CompOverIntersec" +ruleCompOverIntersec = ruleList "CompOverIntersec" [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s) --alleen toegestaan als q een functie is! , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s) --idem ] ruleAddOverUnion :: Rule RelAlg -ruleAddOverUnion = distributionGroup "AddOverUnion" +ruleAddOverUnion = ruleList "AddOverUnion" [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is! , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem ] ruleAddOverIntersec :: Rule RelAlg -ruleAddOverIntersec = distributionGroup "AddOverIntersec" - [ \q r s -> q :+: (r :&&: s) :~> (q :+: r) :&&: (q :+: s) - , \q r s -> (q :&&: r) :+: s :~> (q :+: s) :&&: (r :+: s) +ruleAddOverIntersec = ruleList "AddOverIntersec" + [ \q r s -> q :+: (r :&&: s) :~> (q :+: r) :&&: (q :+: s) + , \q r s -> (q :&&: r) :+: s :~> (q :+: s) :&&: (r :+: s) ] -- | 3. Distribute union over intersection - + ruleUnionOverIntersec :: Rule RelAlg -ruleUnionOverIntersec = distributionGroup "UnionOverIntersec" - [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: (q :||: s) - , \q r s -> (q :&&: r) :||: s :~> (q :||: s) :&&: (r :||: s) +ruleUnionOverIntersec = ruleList "UnionOverIntersec" + [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: (q :||: s) + , \q r s -> (q :&&: r) :||: s :~> (q :||: s) :&&: (r :||: s) ] -- | 4. De Morgan rules -deMorganGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a -deMorganGroup s = - addRuleToGroup (relalg "DeMorgan") . rule s - ruleDeMorganOr :: Rule RelAlg -ruleDeMorganOr = deMorganGroup "DeMorganOr" $ +ruleDeMorganOr = rule "DeMorganOr" $ \r s -> Not (r :||: s) :~> Not r :&&: Not s - + ruleDeMorganAnd :: Rule RelAlg -ruleDeMorganAnd = deMorganGroup "DeMorganAnd" $ +ruleDeMorganAnd = rule "DeMorganAnd" $ \r s -> Not (r :&&: s) :~> Not r :||: Not s -- | 5. Idempotency -idempotencyGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a -idempotencyGroup s = - addRuleToGroup (relalg "Idempotency") . rule s - ruleIdempOr :: Rule RelAlg -ruleIdempOr = idempotencyGroup "IdempotencyOr" $ +ruleIdempOr = rule "IdempotencyOr" $ \r -> r :||: r :~> r - + ruleIdempAnd :: Rule RelAlg -ruleIdempAnd = idempotencyGroup "IdempotencyAnd" $ +ruleIdempAnd = rule "IdempotencyAnd" $ \r -> r :&&: r :~> r -- | 6. Complement -complementGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a -complementGroup s = - addRuleToGroup (relalg "Complement") . ruleList s - ruleDoubleNegation :: Rule RelAlg -ruleDoubleNegation = complementGroup "DoubleNegation" - [ \r -> Not (Not r) :~> r - ] +ruleDoubleNegation = rule "DoubleNegation" $ + \r -> Not (Not r) :~> r ruleRemCompl :: Rule RelAlg -ruleRemCompl = complementGroup "RemCompl" +ruleRemCompl = ruleList "RemCompl" [ \r -> r :||: Not r :~> V , \r -> Not r :||: r :~> V , \r -> r :&&: Not r :~> empty , \r -> Not r :&&: r :~> empty - ] + ] -- Distribute Not over . and + ruleNotOverComp :: Rule RelAlg -ruleNotOverComp = complementGroup "NotOverComp" - [ \r s -> Not (r :.: s) :~> Not r :+: Not s - ] - +ruleNotOverComp = rule "NotOverComp" $ + \r s -> Not (r :.: s) :~> Not r :+: Not s + ruleNotOverAdd :: Rule RelAlg -ruleNotOverAdd = complementGroup "NotOverAdd" - [ \r s -> Not (r :+: s) :~> Not r :.: Not s - ] - --- | 7. Absorption complement +ruleNotOverAdd = rule "NotOverAdd" $ + \r s -> Not (r :+: s) :~> Not r :.: Not s -absorptionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a -absorptionGroup s = - addRuleToGroup (relalg "Absorption") . ruleList s +-- | 7. Absorption complement ruleAbsorpCompl :: Rule RelAlg -ruleAbsorpCompl = absorptionGroup "AbsorpCompl" +ruleAbsorpCompl = ruleList "AbsorpCompl" [ \r s -> r :&&: (Not r :||: s) :~> r :&&: s - , \r s -> r :&&: (s :||: Not r) :~> r :&&: s + , \r s -> r :&&: (s :||: Not r) :~> r :&&: s , \r s -> (Not r :||: s) :&&: r :~> r :&&: s , \r s -> (s :||: Not r) :&&: r :~> r :&&: s - , \r s -> r :||: (Not r :&&: s) :~> r :||: s + , \r s -> r :||: (Not r :&&: s) :~> r :||: s , \r s -> r :||: (s :&&: Not r) :~> r :||: s , \r s -> (Not r :&&: s) :||: r :~> r :||: s , \r s -> (s :&&: Not r) :||: r :~> r :||: s ] - + ruleAbsorp :: Rule RelAlg -ruleAbsorp = absorptionGroup "Absorp" +ruleAbsorp = ruleList "Absorp" [ \r s -> r :&&: (r :||: s) :~> r , \r s -> r :&&: (s :||: r) :~> r , \r s -> (r :||: s) :&&: r :~> r @@ -209,28 +180,24 @@ -- | 8. Remove redundant expressions -simplificationGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a -simplificationGroup s = - addRuleToGroup (relalg "Simplification") . ruleList s - ruleRemRedunExprs :: Rule RelAlg -ruleRemRedunExprs = simplificationGroup "RemRedunExprs" +ruleRemRedunExprs = ruleList "RemRedunExprs" [ \r -> r :||: V :~> V - , \r -> V :||: r :~> V + , \r -> V :||: r :~> V , \r -> r :&&: V :~> r - , \r -> V :&&: r :~> r + , \r -> V :&&: r :~> r -- , (r :.: U) :~> r -- , (U :.: r) :~> r , \_ -> V :.: V :~> V , \r -> r :+: V :~> V , \r -> V :+: r :~> V -- , (r :+: E) :~> r --- , (E :+: r) :~> r +-- , (E :+: r) :~> r , \_ -> Inv V :~> V -- rules involving the empty relation , \_ -> Inv empty :~> empty , \r -> r :||: empty :~> r - , \r -> empty :||: r :~> r + , \r -> empty :||: r :~> r , \r -> r :&&: empty :~> empty , \r -> empty :&&: r :~> empty , \r -> r :.: empty :~> empty @@ -241,78 +208,78 @@ , \r -> I :.: r :~> r , \r -> r :.: I :~> r ] - + -- Buggy rules: -buggyGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a -buggyGroup s = addRuleToGroup (relalg "Buggy") . buggyRule - . Rule.ruleList ("relationalgebra.buggy." ++ s) - +buggyGroup :: RuleBuilder f a => String -> [f] -> Rule a +buggyGroup s = + buggyRule . Rule.ruleList ("relationalgebra.buggy." ++ s) + buggyRuleIdemComp :: Rule RelAlg -buggyRuleIdemComp = buggyGroup "IdemComp" - [ \q -> q :.: q :~> q +buggyRuleIdemComp = buggyGroup "IdemComp" + [ \q -> q :.: q :~> q ] - + buggyRuleIdemAdd :: Rule RelAlg buggyRuleIdemAdd = buggyGroup "IdemAdd" [ \q -> q :+: q :~> q ] buggyRuleDeMorgan :: Rule RelAlg -buggyRuleDeMorgan = buggyGroup "DeMorgan" +buggyRuleDeMorgan = buggyGroup "DeMorgan" [ \q r -> Not (q :&&: r) :~> Not q :||: r , \q r -> Not (q :&&: r) :~> q :||: Not r , \q r -> Not (q :&&: r) :~> Not (Not q :||: Not r) , \q r -> Not (q :||: r) :~> Not q :&&: r , \q r -> Not (q :||: r) :~> q :&&: Not r - , \q r -> Not (q :||: r) :~> Not (Not q :&&: Not r) --note the firstNot in both formulas! + , \q r -> Not (q :||: r) :~> Not (Not q :&&: Not r) --note the firstNot in both formulas! ] - + buggyRuleNotOverAdd :: Rule RelAlg -buggyRuleNotOverAdd = buggyGroup "NotOverAdd" +buggyRuleNotOverAdd = buggyGroup "NotOverAdd" [ \q r -> Not (q :+: r) :~> Not q :+: Not r , \q r -> Not (q :+: r) :~> Not q :.: r , \q r -> Not (q :+: r) :~> Not q :+: r - , \q r -> Not (q :+: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas! + , \q r -> Not (q :+: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas! ] - + buggyRuleNotOverComp :: Rule RelAlg -buggyRuleNotOverComp = buggyGroup "NotOverComp" +buggyRuleNotOverComp = buggyGroup "NotOverComp" [ \q r -> Not (q :.: r) :~> Not q :.: Not r , \q r -> Not (q :.: r) :~> Not q :.: r , \q r -> Not (q :.: r) :~> Not q :+: r - , \q r -> Not (q :.: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas! + , \q r -> Not (q :.: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas! ] - + buggyRuleParenth :: Rule RelAlg -buggyRuleParenth = buggyGroup "Parenth" +buggyRuleParenth = buggyGroup "Parenth" [ \q r -> Not (q :&&: r) :~> Not q :&&: r , \q r -> Not (q :||: r) :~> Not q :||: r - , \q r -> Not (Not q :&&: r) :~> q :&&: r + , \q r -> Not (Not q :&&: r) :~> q :&&: r , \q r -> Not (Not q :||: r) :~> q :||: r , \q r -> Not (Not q :.: r) :~> q :.: r , \q r -> Not (Not q :+: r) :~> q :+: r , \q r -> Inv (q :&&: r) :~> Inv q :&&: r , \q r -> Inv (q :||: r) :~> Inv q :||: r - , \q r -> Inv (Inv q :&&: r) :~> q :&&: r + , \q r -> Inv (Inv q :&&: r) :~> q :&&: r , \q r -> Inv (Inv q :||: r) :~> q :||: r , \q r -> Inv (Inv q :.: r) :~> q :.: r , \q r -> Inv (Inv q :+: r) :~> q :+: r ] - + buggyRuleAssoc :: Rule RelAlg -buggyRuleAssoc = buggyGroup "Assoc" +buggyRuleAssoc = buggyGroup "Assoc" [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: s , \q r s -> (q :||: r) :&&: s :~> q :||: (r :&&: s) , \q r s -> (q :&&: r) :||: s :~> q :&&: (r :||: s) , \q r s -> q :&&: (r :||: s) :~> (q :&&: r) :||: s - , \q r s -> q :.: (r :||: s) :~> (q :.: r) :||: s - , \q r s -> (q :||: r) :.: s :~> q :||: (r :.: s) - , \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: s - , \q r s -> (q :&&: r) :.: s :~> q :&&: (r :.: s) - , \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: s - , \q r s -> (q :||: r) :+: s :~> q :||: (r :+: s) - , \q r s -> q :+: (r :&&: s) :~> (q :+: r) :&&: s + , \q r s -> q :.: (r :||: s) :~> (q :.: r) :||: s + , \q r s -> (q :||: r) :.: s :~> q :||: (r :.: s) + , \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: s + , \q r s -> (q :&&: r) :.: s :~> q :&&: (r :.: s) + , \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: s + , \q r s -> (q :||: r) :+: s :~> q :||: (r :+: s) + , \q r s -> q :+: (r :&&: s) :~> (q :+: r) :&&: s , \q r s -> (q :&&: r) :+: s :~> q :&&: (r :+: s) ] @@ -325,20 +292,20 @@ buggyRuleInvOverAdd = buggyGroup "InvOverAdd" [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s ] - + buggyRuleCompOverIntersec :: Rule RelAlg -buggyRuleCompOverIntersec = buggyGroup "CompOverIntersec" +buggyRuleCompOverIntersec = buggyGroup "CompOverIntersec" [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s) --alleen toegestaan als q een functie is! , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s) --idem ] buggyRuleAddOverUnion :: Rule RelAlg -buggyRuleAddOverUnion = buggyGroup "AddOverUnion" +buggyRuleAddOverUnion = buggyGroup "AddOverUnion" [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is! , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem ] - + buggyRuleRemCompl :: Rule RelAlg -buggyRuleRemCompl = buggyGroup "RemCompl" +buggyRuleRemCompl = buggyGroup "RemCompl" [ \r -> r :&&: Not r :~> V , \r -> Not r :&&: r :~> V , \r -> r :||: Not r :~> empty diff --git a/src/Domain/RelationAlgebra/Strategies.hs b/src/Domain/RelationAlgebra/Strategies.hs --- a/src/Domain/RelationAlgebra/Strategies.hs +++ b/src/Domain/RelationAlgebra/Strategies.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -11,15 +11,15 @@ ----------------------------------------------------------------------------- module Domain.RelationAlgebra.Strategies (toCNF) where -import Domain.RelationAlgebra.Rules -import Domain.RelationAlgebra.Formula import Common.Context import Common.Strategy import Common.Transformation +import Domain.RelationAlgebra.Formula +import Domain.RelationAlgebra.Rules import Prelude hiding (repeat) toCNF :: LabeledStrategy (Context RelAlg) -toCNF = label "To CNF" $ +toCNF = label "To CNF" $ repeat $ label "step1" step1 |> label "step2" step2 |> label "step3" step3 @@ -28,18 +28,13 @@ [ ruleRemCompl, ruleRemRedunExprs, ruleDoubleNegation , ruleIdempOr, ruleIdempAnd, ruleAbsorp, ruleAbsorpCompl ] ++ invRules - step2 = topDown $ useRules + step2 = topDown $ useRules [ ruleCompOverUnion, ruleAddOverIntersec, ruleDeMorganOr, ruleDeMorganAnd , ruleNotOverComp, ruleNotOverAdd ] - step3 = somewhere $ liftToContext + step3 = somewhere $ liftToContext ruleUnionOverIntersec -- local helper-function useRules :: [Rule RelAlg] -> Strategy (Context RelAlg) -useRules = alternatives . map liftToContext - - - - - +useRules = alternatives . map liftToContext diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -15,7 +15,6 @@ import Common.Utils (useFixedStdGen) import Control.Monad -import Control.Monad.Trans import Data.IORef import Data.Time import Documentation.Make @@ -23,8 +22,9 @@ import Main.LoggingDatabase import Main.Options import Network.CGI +import Service.FeedbackScript.Analysis import Service.ModeJSON (processJSON) -import Service.ModeXML (processXML) +import Service.ModeXML (processXML) import Service.Request main :: IO () @@ -32,44 +32,50 @@ startTime <- getCurrentTime flags <- serviceOptions logRef <- newIORef (return ()) - - case withInputFile flags of + + case withInputFile flags of -- from file - Just file -> do - when (FixRNG `elem` flags) + Just file -> do + when (FixRNG `elem` flags) useFixedStdGen -- use a predictable "random" number generator input <- readFile file (req, txt, _) <- process input - when (Logging True `elem` flags) $ + when (Logging True `elem` flags) $ writeIORef logRef $ -- save logging action for later logMessage req input txt "local" startTime putStrLn txt -- documentation mode - _ | documentationMode flags -> - useIDEAS $ + _ | documentationMode flags -> + useIDEAS $ let f = makeDocumentation (docDir flags) (testDir flags) in mapM_ f (docItems flags) + -- feedback script options + | scriptMode flags -> useIDEAS $ + withScripts (Just (scriptDir flags)) + [ a | MakeScriptFor a <- flags ] + [ a | AnalyzeScript a <- flags ] + -- cgi binary Nothing -> runCGI $ do - addr <- remoteAddr -- the IP address of the remote host making the request + addr <- remoteAddr -- the IP address of the remote host making the request raw <- getInput "input" -- read input input <- case raw of Nothing -> fail "Invalid request: environment variable \"input\" is empty" Just s -> return s - (req, txt, ctp) <- lift $ process input - lift $ writeIORef logRef $ -- save logging action for later + (req, txt, ctp) <- liftIO $ process input + liftIO $ writeIORef logRef $ -- save logging action for later logMessage req input txt addr startTime setHeader "Content-type" ctp output txt - + -- log request to database when (withLogging flags) $ join (readIORef logRef) - + process :: String -> IO (Request, String, String) -process input = useIDEAS $ +process input = useIDEAS $ case discoverDataFormat input of Just XML -> processXML input Just JSON -> processJSON input diff --git a/src/Main/IDEAS.hs b/src/Main/IDEAS.hs --- a/src/Main/IDEAS.hs +++ b/src/Main/IDEAS.hs @@ -1,130 +1,106 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Main.IDEAS (useIDEAS) where - -import Common.Rewriting -import Common.Utils (Some(..), fromShowString) -import Main.Options -import Service.DomainReasoner -import Service.ExercisePackage -import Service.ServiceList -import qualified Domain.LinearAlgebra as LA -import qualified Domain.LinearAlgebra.Checks as LA -import qualified Domain.Logic as Logic -import qualified Domain.Logic.FeedbackText as Logic -import qualified Domain.Math.Expr as Math -import qualified Domain.Math.Data.Interval as MathInterval -import qualified Domain.Math.Derivative.Exercises as Math -import qualified Domain.Math.Equation.CoverUpExercise as Math -import qualified Domain.Math.Numeric.Exercises as Math -import qualified Domain.Math.Numeric.Tests as MathNum -import qualified Domain.Math.Polynomial.Exercises as Math -import qualified Domain.Math.Polynomial.IneqExercises as Math -import qualified Domain.Math.Polynomial.RationalExercises as Math -import qualified Domain.Math.Polynomial.Tests as MathPoly -import qualified Domain.Math.Power.Exercises as Math -import qualified Domain.Math.Power.Equation.Exercises as Math -import qualified Domain.Math.SquareRoot.Tests as MathSqrt -import qualified Domain.Math.Polynomial.LeastCommonMultiple as MathLCM --- import qualified Domain.RegularExpr.Exercises as RE -import qualified Domain.RelationAlgebra as RA - -useIDEAS :: DomainReasoner a -> IO a -useIDEAS action = runDomainReasoner $ do - -- version information - setVersion shortVersion - setFullVersion fullVersion - -- exercise packages - addPackages packages - -- services - addServices serviceList - addPkgService exerciselistS - -- domain checks - addTestSuite $ do - MathNum.main - MathPoly.tests - MathSqrt.tests - MathInterval.testMe - MathLCM.testLCM - LA.checks - -- do the rest - action - -packages :: [Some ExercisePackage] -packages = - [ -- logic and relation-algebra - Some (package Logic.dnfExercise) - { withOpenMath = True - , toOpenMath = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString) - , fromOpenMath = (>>= fromTerm) . omobjToTerm - , getExerciseText = Just logicText - } - , Some (package Logic.dnfUnicodeExercise) - { withOpenMath = True - , toOpenMath = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString) - , fromOpenMath = (>>= fromTerm) . omobjToTerm - , getExerciseText = Just logicText - } - -- , somePackage Logic.proofExercise - , somePackage RA.cnfExercise - -- basic math - -- , someTermPackage Math.naturalExercise - -- , someTermPackage Math.integerExercise - -- , someTermPackage Math.rationalExercise - , someTermPackage Math.fractionExercise - , someTermPackage Math.coverUpExercise - , someTermPackage Math.linearExercise - , someTermPackage Math.linearMixedExercise - , someTermPackage Math.quadraticExercise - , someTermPackage Math.higherDegreeExercise - , someTermPackage Math.findFactorsExercise - , someTermPackage Math.ineqLinearExercise - , someTermPackage Math.ineqQuadraticExercise - , someTermPackage Math.ineqHigherDegreeExercise - , someTermPackage Math.rationalEquationExercise - , someTermPackage Math.simplifyRationalExercise - -- , someTermPackage Math.divisionBrokenExercise - , someTermPackage Math.quadraticNoABCExercise - , someTermPackage Math.quadraticWithApproximation - , someTermPackage Math.derivativeExercise - , someTermPackage Math.derivativePolyExercise - , someTermPackage Math.derivativeProductExercise - , someTermPackage Math.derivativeQuotientExercise - -- , someTermPackage Math.derivativePowerExercise - , someTermPackage Math.simplifyPowerExercise - , someTermPackage Math.powerOfExercise - , someTermPackage Math.nonNegBrokenExpExercise - , someTermPackage Math.calcPowerExercise - , someTermPackage Math.powerEqExercise - , someTermPackage Math.expEqExercise - , someTermPackage Math.logEqExercise - -- linear algebra - , someTermPackage LA.gramSchmidtExercise - , someTermPackage LA.linearSystemExercise - , someTermPackage LA.gaussianElimExercise - , someTermPackage LA.systemWithMatrixExercise - -- regular expressions - -- , somePackage RE.regexpExercise - ] - -logicText :: ExerciseText Logic.SLogic -logicText = ExerciseText - { ruleText = Logic.ruleText - , appliedRule = Logic.appliedRule - , feedbackSyntaxError = Logic.feedbackSyntaxError - , feedbackSame = Logic.feedbackSame - , feedbackBuggy = Logic.feedbackBuggy - , feedbackNotEquivalent = Logic.feedbackNotEquivalent - , feedbackOk = Logic.feedbackOk - , feedbackDetour = Logic.feedbackDetour - , feedbackUnknown = Logic.feedbackUnknown - } +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Main.IDEAS (useIDEAS) where + +import Common.Exercise +import Common.Id +import Common.Utils (Some(..)) +import Control.Arrow +import Main.Options +import Service.DomainReasoner +import Service.ServiceList +import qualified Domain.LinearAlgebra as LA +import qualified Domain.LinearAlgebra.Checks as LA +import qualified Domain.Logic as Logic +import qualified Domain.Math.ExerciseList as Math +import qualified Domain.RelationAlgebra as RA + +useIDEAS :: DomainReasoner a -> IO a +useIDEAS action = runDomainReasoner $ do + -- version information + setVersion shortVersion + setFullVersion fullVersion + -- exercises + addExercises exercises + addAliases aliases + -- services + addServices serviceList + addExerciseService exerciselistS + -- views + addViews Math.viewList + -- feedback scripts + flags <- liftIO serviceOptions + setScriptDir (scriptDir flags) + addScripts scripts + -- domain checks + addTestSuite $ do + sequence_ Math.testSuiteList + LA.checks + -- do the rest + action + +exercises :: [Some Exercise] +exercises = + [ -- logic and relation-algebra + Some Logic.dnfExercise + , Some Logic.dnfUnicodeExercise + -- , Some Logic.proofExercise + , Some RA.cnfExercise + -- linear algebra + , Some LA.gramSchmidtExercise + , Some LA.linearSystemExercise + , Some LA.gaussianElimExercise + , Some LA.systemWithMatrixExercise + -- regular expressions + -- , some RE.regexpExercise + ] ++ Math.exerciseList + +aliases :: [(Id, Id)] +aliases = map (newId *** newId) + [ ("math.coverup", "algebra.equations.coverup") + , ("math.lineq", "algebra.equations.linear") + , ("math.lineq-mixed", "algebra.equations.linear.mixed") + , ("math.quadreq", "algebra.equations.quadratic") + , ("math.quadreq-no-abc", "algebra.equations.quadratic.no-abc") + , ("math.quadreq-with-approx", "algebra.equations.quadratic.approximate") + , ("math.higherdegree", "algebra.equations.polynomial") + , ("math.rationaleq", "algebra.equations.rational") + , ("math.linineq", "algebra.inequalities.linear") + , ("math.quadrineq", "algebra.inequalities.quadratic") + , ("math.ineqhigherdegree", "algebra.inequalities.polynomial") + , ("math.factor", "algebra.manipulation.polynomial.factor") + , ("math.simplifyrational", "algebra.manipulation.rational.simplify") + , ("math.simplifypower", "algebra.manipulation.exponents.simplify") + , ("math.nonnegexp", "algebra.manipulation.exponents.nonnegative") + , ("math.powerof", "algebra.manipulation.exponents.powerof") + , ("math.derivative", "calculus.differentiation") + , ("math.fraction", "arithmetic.fractions") + , ("math.calcpower", "arithmetic.exponents") + , ("linalg.gaussianelim", "linearalgebra.gaussianelim") + , ("linalg.gramschmidt", "linearalgebra.gramschmidt") + , ("linalg.linsystem", "linearalgebra.linsystem") + , ("linalg.systemwithmatrix", "linearalgebra.systemwithmatrix") + , ("logic.dnf", "logic.propositional.dnf") + , ("logic.dnf-unicode", "logic.propositional.dnf.unicode") + , ("relationalg.cnf", "relationalgebra.cnf") + -- MathDox compatibility + , ("gaussianelimination" , "linearalgebra.gaussianelim") + , ("gramschmidt" , "linearalgebra.gramschmidt") + , ("solvelinearsystem" , "linearalgebra.linsystem") + , ("solvelinearsystemwithmatrix", "linearalgebra.systemwithmatrix") + ] + +scripts :: [(Id, FilePath)] +scripts = + [ (getId Logic.dnfExercise, "logic.txt") + , (getId Logic.dnfUnicodeExercise, "logic.txt") + ] ++ Math.scriptList diff --git a/src/Main/LoggingDatabase.hs b/src/Main/LoggingDatabase.hs --- a/src/Main/LoggingDatabase.hs +++ b/src/Main/LoggingDatabase.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -36,10 +36,10 @@ -- calculate duration end <- getCurrentTime - let diff = diffUTCTime end begin + let diff = diffUTCTime end begin -- insert data into database - run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" + run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" [ toSql $ service req , toSql $ maybe "unknown" show (exerciseId req) , toSql $ fromMaybe "unknown" (source req) @@ -76,5 +76,4 @@ logEnabled :: Bool logEnabled = False -#endif - +#endif diff --git a/src/Main/Options.hs b/src/Main/Options.hs --- a/src/Main/Options.hs +++ b/src/Main/Options.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -20,25 +20,27 @@ import System.Environment import System.Exit -data Flag = Version | Help | Logging Bool | InputFile String - | FixRNG | DocItem DocItem | DocDir String | TestDir String +data Flag = Version | Help | Logging Bool | InputFile String + | FixRNG | DocItem DocItem + | DocDir String | TestDir String | ScriptDir String + | MakeScriptFor String | AnalyzeScript String deriving Eq header :: String -header = +header = "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ - "Copyright 2010, Open Universiteit Nederland\n" ++ + "Copyright 2011, Open Universiteit Nederland\n" ++ versionText ++ "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ "\nOptions:" versionText :: String -versionText = +versionText = "version " ++ version ++ ", revision " ++ show revision ++ ", logging " ++ (if logEnabled then "enabled" else "disabled") fullVersion :: String -fullVersion = "version " ++ version ++ " (revision " +fullVersion = "version " ++ version ++ " (revision " ++ show revision ++ ", " ++ lastChanged ++ ")" shortVersion :: String @@ -46,17 +48,20 @@ options :: [OptDescr Flag] options = - [ Option [] ["version"] (NoArg Version) "show version number" - , Option "?" ["help"] (NoArg Help) "show options" - , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" - , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" - , Option "f" ["file"] (ReqArg InputFile "FILE") "use input FILE as request" - , Option "" ["fixed-rng"] (NoArg FixRNG) "use a fixed random-number generator" - , Option "" ["make-pages"] (NoArg $ DocItem Pages) "generate pages for exercises and services" - , Option "" ["self-check"] (NoArg $ DocItem SelfCheck) "perform a self-check" - , Option "" ["test"] (OptArg testArg "DIR") "run tests on directory (default: 'test')" - , Option "" ["docs-dir"] (ReqArg DocDir "DIR") "directory for documentation (default: 'docs')" - , Option "" ["test-dir"] (ReqArg TestDir "DIR") "directory with tests (default: 'test')" + [ Option [] ["version"] (NoArg Version) "show version number" + , Option "?" ["help"] (NoArg Help) "show options" + , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" + , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" + , Option "f" ["file"] (ReqArg InputFile "FILE") "use input FILE as request" + , Option "" ["fixed-rng"] (NoArg FixRNG) "use a fixed random-number generator" + , Option "" ["make-pages"] (NoArg $ DocItem Pages) "generate pages for exercises and services" + , Option "" ["self-check"] (NoArg $ DocItem SelfCheck) "perform a self-check" + , Option "" ["test"] (OptArg testArg "DIR") "run tests on directory (default: 'test')" + , Option "" ["docs-dir"] (ReqArg DocDir "DIR") "directory for documentation (default: 'docs')" + , Option "" ["test-dir"] (ReqArg TestDir "DIR") "directory with tests (default: 'test')" + , Option "" ["script-dir"] (ReqArg ScriptDir "DIR") "directory with feedback scripts (default: 'scripts')" + , Option "" ["make-script"] (ReqArg MakeScriptFor "ID") "generate feedback script for exercise" + , Option "" ["analyze-script"] (ReqArg AnalyzeScript "FILE") "analyze feedback script and report errors" ] testArg :: Maybe String -> Flag @@ -67,14 +72,14 @@ args <- getArgs case getOpt Permute options args of (flags, [], []) - | flags == [Version] -> do + | flags == [Version] -> do putStrLn ("IDEAS, " ++ versionText) exitSuccess | all (`notElem` flags) [Version, Help] -> return flags (_, _, errs) -> do putStrLn (concat errs ++ usageInfo header options) - exitFailure + exitFailure docItems :: [Flag] -> [DocItem] docItems flags = [ x | DocItem x <- flags ] @@ -86,17 +91,27 @@ testDir :: [Flag] -> String testDir flags = case [ d | TestDir d <- flags ] of - d:_ -> d - _ -> "test" + d:_ -> d + _ -> "test" +scriptDir :: [Flag] -> String +scriptDir flags = case [ d | ScriptDir d <- flags ] of + d:_ -> d + _ -> "scripts" + documentationMode :: [Flag] -> Bool documentationMode = not . null . docItems +scriptMode :: [Flag] -> Bool +scriptMode flags = not $ null $ + [ () | MakeScriptFor _ <- flags ] ++ + [ () | AnalyzeScript _ <- flags ] + withLogging :: [Flag] -> Bool withLogging flags = and [ b | Logging b <- flags ] - + withInputFile :: [Flag] -> Maybe String -withInputFile flags = +withInputFile flags = case [ file | InputFile file <- flags ] of [hd] -> Just hd _ -> Nothing diff --git a/src/Main/Revision.hs b/src/Main/Revision.hs --- a/src/Main/Revision.hs +++ b/src/Main/Revision.hs @@ -1,8 +1,8 @@ -- Automatically generated by Makefile. Do not change. module Main.Revision where version :: String -version = "0.7" +version = "1.0" revision :: Int -revision = 3724 +revision = 4677 lastChanged :: String -lastChanged = "do, 23 dec 2010" +lastChanged = "Thu, 01 Sep 2011" diff --git a/src/Service/BasicServices.hs b/src/Service/BasicServices.hs --- a/src/Service/BasicServices.hs +++ b/src/Service/BasicServices.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,145 +9,150 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Service.BasicServices +module Service.BasicServices ( -- * Basic Services stepsremaining, findbuggyrules, ready, allfirsts, derivation - , onefirst, applicable, allapplications, apply, generate, generateWith + , onefirst, applicable, allapplications, apply, generate ) where -import Common.Library hiding (derivation, applicable, apply) -import Common.Utils (safeHead) +import Common.Library hiding (derivation, applicable, apply, ready) +import Common.Utils (fst3, safeHead) import Data.List import Data.Maybe -import System.Random (StdGen, newStdGen) -import Control.Monad -import Service.ExercisePackage import Service.State +import System.Random (StdGen) import qualified Common.Classes as Apply - --- result must be in the IO monad to access a standard random number generator -generate :: ExercisePackage a -> Int -> IO (State a) -generate pkg level = do - stdgen <- newStdGen - return (generateWith stdgen pkg level) -generateWith :: StdGen -> ExercisePackage a -> Int -> State a -generateWith rng pkg level = - emptyState pkg (randomTermWith rng level (exercise pkg)) +generate :: StdGen -> Exercise a -> Difficulty -> State a +generate rng ex dif = + emptyState ex (randomTermWith rng dif ex) -derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)] +-- TODO: add a location to each step +derivation :: Maybe StrategyConfiguration -> State a -> Either String (Derivation (Rule (Context a), ArgValues) (Context a)) derivation mcfg state = - case (statePrefix state, mcfg) of - (Nothing, _) -> fail "Prefix is required" - -- configuration is only allowed beforehand: hence, the prefix + mapSecond (biMap (\(r, _, as) -> (r, as)) stateContext) $ + case (statePrefix state, mcfg) of + (Nothing, _) -> Left "Prefix is required" + -- configuration is only allowed beforehand: hence, the prefix -- should be empty (or else, the configuration is ignored). This -- restriction should probably be relaxed later on. - (Just p, Just cfg) | null (prefixToSteps p) -> + (Just p, Just cfg) | null (prefixToSteps p) -> let newStrategy = configure cfg (strategy ex) newExercise = ex {strategy = newStrategy} - newPackage = pkg {exercise = newExercise} - in rec timeout [] (empyStateContext newPackage (stateContext state)) - _ -> rec timeout [] state + in rec timeout d0 (empyStateContext newExercise (stateContext state)) + _ -> rec timeout d0 state where - pkg = exercisePkg state - ex = exercise pkg + d0 = emptyDerivation state + ex = exercise state timeout = 50 :: Int - - rec i acc st = + + rec i acc st = case onefirst st of - Nothing -> return (reverse acc) - Just (r, _, next) - | i <= 0 -> fail msg - | otherwise -> rec (i-1) ((r, stateContext next) : acc) next + Left _ -> Right acc + Right (r, l, as, next) + | i <= 0 -> Left msg + | otherwise -> rec (i-1) (acc `extend` ((r, l, as), next)) next where - msg = "Time out after " ++ show timeout ++ " steps. " ++ - concatMap f (reverse acc) - f (r, c) = let s = maybe "???" (prettyPrinter ex) (fromContext c) - in "[" ++ show r ++ "] " ++ s ++ "; " + msg = "Time out after " ++ show timeout ++ " steps. " ++ + show (biMap fst3 (prettyPrinterContext ex . stateContext) acc) -- Note that we have to inspect the last step of the prefix afterwards, because -- the remaining part of the derivation could consist of minor rules only. -allfirsts :: Monad m => State a -> m [(Rule (Context a), Location, State a)] -allfirsts state = +allfirsts :: State a -> Either String [(Rule (Context a), Location, ArgValues, State a)] +allfirsts state = case statePrefix state of - Nothing -> - fail "Prefix is required" + Nothing -> + Left "Prefix is required" Just p0 -> let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (stateContext state)) - f (r1, _, _) (r2, _, _) = - ruleOrdering (exercise (exercisePkg state)) r1 r2 - in return (sortBy f (mapMaybe make (derivations tree))) + f (r1, _, _, _) (r2, _, _, _) = + ruleOrdering (exercise state) r1 r2 + in Right $ noDuplicates $ sortBy f $ mapMaybe make $ derivations tree where stop (Just (RuleStep r)) = isMajorRule r stop _ = False - + make d = do - prefixEnd <- safeHead (reverse (steps d)) - termEnd <- safeHead (reverse (terms d)) + prefixEnd <- lastStep d + let ca = lastTerm (withoutLast d) case lastStepInPrefix prefixEnd of Just (RuleStep r) | isMajorRule r -> return ( r - , location termEnd - , makeState (exercisePkg state) (Just prefixEnd) termEnd + , location (lastTerm d) + , fromMaybe [] (expectedArguments r ca) + , makeState (exercise state) (Just prefixEnd) (lastTerm d) ) _ -> Nothing -onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a) -onefirst state = do - xs <- allfirsts state - case xs of - hd:_ -> return hd - [] -> fail "No step possible" + noDuplicates [] = [] + noDuplicates (x:xs) = x : noDuplicates (filter (not . eq x) xs) + eq (r1, l1, a1, s1) (r2, l2, a2, s2) = + r1==r2 && l1==l2 && a1==a2 && exercise s1 == exercise s2 + && similarity (exercise s1) (stateContext s1) (stateContext s2) + +onefirst :: State a -> Either String (Rule (Context a), Location, ArgValues, State a) +onefirst state = + case allfirsts state of + Right [] -> Left "No step possible" + Right (hd:_) -> Right hd + Left msg -> Left msg + applicable :: Location -> State a -> [Rule (Context a)] applicable loc state = let p r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (stateContext state)) - in filter p (ruleset (exercise (exercisePkg state))) + in filter p (ruleset (exercise state)) allapplications :: State a -> [(Rule (Context a), Location, State a)] -allapplications state = xs ++ ys +allapplications state = sortBy cmp (xs ++ ys) where - pkg = exercisePkg state - ex = exercise pkg - xs = concat (allfirsts state) - ps = [ (r, loc) | (r, loc, _) <- xs ] - ys = maybe [] f (top (stateContext state)) - + ex = exercise state + xs = either (const []) (map (\(r, l, _, s) -> (r, l, s))) (allfirsts state) + ps = [ (r, loc) | (r, loc, _) <- xs ] + ys = maybe [] f (top (stateContext state)) + f c = g c ++ concatMap f (allDowns c) - g c = [ (r, location new, makeState pkg Nothing new) + g c = [ (r, location new, makeState ex Nothing new) | r <- ruleset ex , (r, location c) `notElem` ps , new <- applyAll r c ] + cmp (r1, loc1, _) (r2, loc2, _) = + case ruleOrdering ex r1 r2 of + EQ -> loc1 `compare` loc2 + this -> this + -- local helper -setLocation :: Location -> Context a -> Context a +setLocation :: Location -> Context a -> Context a setLocation loc c0 = fromMaybe c0 (navigateTo loc c0) --- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the +-- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the -- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied -- to the current term at the given location, in which case the request is invalid. -apply :: Monad m => Rule (Context a) -> Location -> State a -> m (State a) +apply :: Rule (Context a) -> Location -> State a -> Either String (State a) apply r loc state = maybe applyOff applyOn (statePrefix state) where applyOn _ = -- scenario 1: on-strategy - maybe applyOff return $ safeHead - [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, showId r == showId r1, loc==loc1 ] - + maybe applyOff Right $ safeHead + [ s1 | Right xs <- [allfirsts state], (r1, loc1, _, s1) <- xs, r==r1, loc==loc1 ] + applyOff = -- scenario 2: off-strategy case Apply.apply r (setLocation loc (stateContext state)) of - Just new -> return (makeState (exercisePkg state) Nothing new) - Nothing -> fail ("Cannot apply " ++ show r) - + Just new -> Right (makeState (exercise state) Nothing new) + Nothing -> Left ("Cannot apply " ++ show r) + ready :: State a -> Bool -ready state = isReady (exercise (exercisePkg state)) (stateTerm state) +ready state = isReady (exercise state) (stateTerm state) -stepsremaining :: Monad m => State a -> m Int -stepsremaining = liftM length . derivation Nothing +stepsremaining :: State a -> Either String Int +stepsremaining = mapSecond derivationLength . derivation Nothing -findbuggyrules :: State a -> a -> [Rule (Context a)] +findbuggyrules :: State a -> a -> [(Rule (Context a), Location, ArgValues)] findbuggyrules state a = - let ex = exercise (exercisePkg state) - buggies = filter isBuggyRule (ruleset ex) - p r = ruleIsRecognized ex r (stateContext state) (inContext ex a) - in filter p buggies + [ (r, loc, as) + | r <- filter isBuggyRule (ruleset ex) + , (loc, as) <- recognizeRule ex r (stateContext state) (inContext ex a) + ] + where + ex = exercise state diff --git a/src/Service/Diagnose.hs b/src/Service/Diagnose.hs --- a/src/Service/Diagnose.hs +++ b/src/Service/Diagnose.hs @@ -1,143 +1,196 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Diagnose a term submitted by a student --- ------------------------------------------------------------------------------ -module Service.Diagnose - ( Diagnosis(..), diagnose, restartIfNeeded - , diagnosisType, diagnosisTypeSynonym - ) where - -import Common.Library -import Common.Utils (safeHead) -import Data.List (sortBy) -import Data.Maybe -import Service.ExercisePackage -import Service.State -import Service.BasicServices -import Service.Types - ----------------------------------------------------------------- --- Result types for diagnose service - -data Diagnosis a - = Buggy (Rule (Context a)) - | NotEquivalent - | Similar Bool (State a) - | Expected Bool (State a) (Rule (Context a)) - | Detour Bool (State a) (Rule (Context a)) - | Correct Bool (State a) - -instance Show (Diagnosis a) where - show diagnosis = - case diagnosis of - Buggy r -> "Buggy rule " ++ show (show r) - NotEquivalent -> "Unknown mistake" - Similar _ _ -> "Very similar" - Expected _ _ r -> "Rule " ++ show (show r) ++ ", expected by strategy" - Detour _ _ r -> "Rule " ++ show (show r) ++ ", not following strategy" - Correct _ _ -> "Unknown step" - ----------------------------------------------------------------- --- The diagnose service - -diagnose :: State a -> a -> Diagnosis a -diagnose state new - -- Is the submitted term equivalent? - | not (equivalenceContext ex (stateContext state) newc) = - -- Is the rule used discoverable by trying all known buggy rules? - case discovered True of - Just r -> -- report the buggy rule - Buggy r - Nothing -> -- unknown mistake - NotEquivalent - - -- Is the submitted term (very) similar to the previous one? - | similarity ex (stateTerm state) new = - -- If yes, report this - Similar (ready state) state - - -- Was the submitted term expected by the strategy? - | isJust expected = - -- If yes, return new state and rule - let (r, _, ns) = fromJust expected - in Expected (ready ns) ns r - - -- Is the rule used discoverable by trying all known rules? - | otherwise = - let ns = restartIfNeeded (makeState pkg Nothing newc) - in case discovered False of - Just r -> -- If yes, report the found rule as a detour - Detour (ready ns) ns r - Nothing -> -- If not, we give up - Correct (ready ns) ns - where - pkg = exercisePkg state - ex = exercise pkg - newc = inContext ex new - - expected = do - xs <- allfirsts (restartIfNeeded state) - let p (_, _, ns) = similarity ex new (stateTerm ns) - safeHead (filter p xs) - - discovered searchForBuggy = safeHead - [ r - | r <- sortBy (ruleOrdering ex) (ruleset ex) - , isBuggyRule r == searchForBuggy - , ruleIsRecognized ex r sub1 sub2 - ] - where - (sub1, sub2) = - case difference ex (not searchForBuggy) (stateTerm state) new of - Just (a, b) -> (inContext ex a, inContext ex b) - Nothing -> (stateContext state, newc) - ----------------------------------------------------------------- --- Helpers - --- If possible (and if needed), restart the strategy --- Make sure that the new state has a prefix --- When resetting the prefix, also make sure that the context is refreshed -restartIfNeeded :: State a -> State a -restartIfNeeded state - | isNothing (statePrefix state) && canBeRestarted (exercise pkg) = - emptyState pkg (stateTerm state) - | otherwise = state - where - pkg = exercisePkg state - -diagnosisType :: Type a (Diagnosis a) -diagnosisType = useSynonym diagnosisTypeSynonym - -diagnosisTypeSynonym :: TypeSynonym a (Diagnosis a) -diagnosisTypeSynonym = typeSynonym "Diagnosis" to from tp - where - to (Left r) = Buggy r - to (Right (Left ())) = NotEquivalent - to (Right (Right (Left (b, s)))) = Similar b s - to (Right (Right (Right (Left (b, s, r))))) = Expected b s r - to (Right (Right (Right (Right (Left (b, s, r)))))) = Detour b s r - to (Right (Right (Right (Right (Right (b, s)))))) = Correct b s - - from (Buggy r) = Left r - from (NotEquivalent) = Right (Left ()) - from (Similar b s) = Right (Right (Left (b, s))) - from (Expected b s r) = Right (Right (Right (Left (b, s, r)))) - from (Detour b s r) = Right (Right (Right (Right (Left (b, s, r))))) - from (Correct b s) = Right (Right (Right (Right (Right (b, s))))) - - tp = Rule - :|: Unit - :|: Pair Bool stateTp - :|: tuple3 Bool stateTp Rule - :|: tuple3 Bool stateTp Rule - :|: Pair Bool stateTp +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Diagnose a term submitted by a student +-- +----------------------------------------------------------------------------- +module Service.Diagnose + ( Diagnosis(..), diagnose, restartIfNeeded + , newState + , diagnosisType + ) where + +import Common.Library hiding (ready) +import Common.Utils (safeHead) +import Data.List (sortBy) +import Data.Maybe +import Service.BasicServices hiding (apply) +import Service.State +import Service.Types + +---------------------------------------------------------------- +-- Result types for diagnose service + +data Diagnosis a + = Buggy ArgValues (Rule (Context a)) +-- | Missing +-- | IncorrectPart [a] + | NotEquivalent + | Similar Bool (State a) + | Expected Bool (State a) (Rule (Context a)) + | Detour Bool (State a) ArgValues (Rule (Context a)) + | Correct Bool (State a) + +instance Show (Diagnosis a) where + show diagnosis = + case diagnosis of + Buggy _ r -> "Buggy rule " ++ show (show r) +-- Missing -> "Missing solutions" +-- IncorrectPart xs -> "Incorrect parts (" ++ show (length xs) ++ " items)" + NotEquivalent -> "Unknown mistake" + Similar _ _ -> "Very similar" + Expected _ _ r -> "Rule " ++ show (show r) ++ ", expected by strategy" + Detour _ _ _ r -> "Rule " ++ show (show r) ++ ", not following strategy" + Correct _ _ -> "Unknown step" + +newState :: Diagnosis a -> Maybe (State a) +newState diagnosis = + case diagnosis of + Buggy _ _ -> Nothing + NotEquivalent -> Nothing + Similar _ s -> Just s + Expected _ s _ -> Just s + Detour _ s _ _ -> Just s + Correct _ s -> Just s + +---------------------------------------------------------------- +-- The diagnose service + +diagnose :: State a -> a -> Diagnosis a +diagnose state new + -- Is the submitted term equivalent? + | not (equivalence ex (stateContext state) newc) = + -- Is the rule used discoverable by trying all known buggy rules? + case discovered True of + Just (r, as) -> Buggy as r -- report the buggy rule + Nothing -> NotEquivalent -- compareParts state new + + -- Is the submitted term (very) similar to the previous one? + | similar && not (isReady ex new) = + -- If yes, report this + Similar (ready state) state + + -- Was the submitted term expected by the strategy? + | isJust expected = + -- If yes, return new state and rule + let (r, _, _, ns) = fromJust expected + in Expected (ready ns) ns r + + | similar = Similar (ready state) state + + -- Is the rule used discoverable by trying all known rules? + | otherwise = + case discovered False of + Just (r, as) -> -- If yes, report the found rule as a detour + Detour (ready restarted) restarted as r + Nothing -> -- If not, we give up + Correct (ready restarted) restarted + where + ex = exercise state + newc = inContext ex new + restarted = restartIfNeeded (makeState ex Nothing newc) + similar = similarity ex (stateContext state) newc + + expected = do + let xs = either (const []) id $ allfirsts (restartIfNeeded state) + p (_, _, _, ns) = similarity ex newc (stateContext ns) + safeHead (filter p xs) + + discovered searchForBuggy = safeHead + [ (r, as) + | r <- sortBy (ruleOrdering ex) (ruleset ex) + , isBuggyRule r == searchForBuggy, not (isFinalRule r) + , (_, as) <- recognizeRule ex r sub1 sub2 + ] + where + diff = if searchForBuggy then difference else differenceEqual + (sub1, sub2) = + case diff ex (stateTerm state) new of + Just (a, b) -> (inContext ex a, inContext ex b) + Nothing -> (stateContext state, newc) + +---------------------------------------------------------------- +-- Helpers + +-- If possible (and if needed), restart the strategy +-- Make sure that the new state has a prefix +-- When resetting the prefix, also make sure that the context is refreshed +restartIfNeeded :: State a -> State a +restartIfNeeded state + | isNothing (statePrefix state) && canBeRestarted ex = + emptyState ex (stateTerm state) + | otherwise = state + where + ex = exercise state + +diagnosisType :: Type a (Diagnosis a) +diagnosisType = Iso (f <-> g) tp + where + f (Left (Left (as, r))) = Buggy as r +-- f (Left (Right (Left ()))) = Missing +-- f (Left (Right (Right (Left xs)))) = IncorrectPart xs + f (Left (Right ())) = NotEquivalent + f (Right (Left (b, s))) = Similar b s + f (Right (Right (Left (b, s, r)))) = Expected b s r + f (Right (Right (Right (Left (b, s, as, r))))) = Detour b s as r + f (Right (Right (Right (Right (b, s))))) = Correct b s + + g (Buggy as r) = Left (Left (as, r)) +-- g Missing = Left (Right (Left ())) +-- g (IncorrectPart xs) = Left (Right (Right (Left xs))) + g NotEquivalent = Left (Right ()) + g (Similar b s) = Right (Left (b, s)) + g (Expected b s r) = Right (Right (Left (b, s, r))) + g (Detour b s as r) = Right (Right (Right (Left (b, s, as, r)))) + g (Correct b s) = Right (Right (Right (Right (b, s)))) + + tp = + ( Tag "buggy" (Pair (List ArgValueTp) Rule) +-- :|: Tag "missing" Unit +-- :|: Tag "incorrectpart" (List Term) + :|: Tag "notequiv" Unit + ) + :|: + ( Tag "similar" (Pair readyBool stateType) + :|: Tag "expected" (tuple3 readyBool stateType Rule) + :|: Tag "detour" (tuple4 readyBool stateType (List ArgValueTp) Rule) + :|: Tag "correct" (Pair readyBool stateType) + ) + + readyBool = Tag "ready" Bool + +---------------------------------------------------------------- +-- Compare answer sets (and search for missing parts/incorrect parts) +{- splitParts :: a -> [a] +compareParts :: State a -> a -> Diagnosis a +compareParts state = answerList eq split solve (stateTerm state) + where + ex = exercise (exercise state) + eq = equivalence ex + split = splitParts ex + solve = \a -> fromMaybe a $ + apply (strategy ex) (inContext ex a) >>= fromContext + +answerList :: (a -> a -> Bool) -> (a -> [a]) -> (a -> a) -> a -> a -> Diagnosis a +answerList eq split solve a b + | noSplit = NotEquivalent + | present && null wrong = NotEquivalent -- error situation + | null wrong = Missing + | partly = IncorrectPart wrong + | otherwise = NotEquivalent + where + as = split (solve a) -- expected + ps = [ (x, split (solve x)) | x <- split b ] -- student (keep original parts) + bs = concatMap snd ps -- student answer, but then fully solved + wrong = [ x | (x, xs) <- ps, any notInAs xs ] -- is a (student) part incorrect? + present = all (flip any bs . eq) as -- are all expected answers present + notInAs = not . flip any as . eq + partly = length wrong < length ps + noSplit = length as < 2 && length bs < 2 -} diff --git a/src/Service/DomainReasoner.hs b/src/Service/DomainReasoner.hs --- a/src/Service/DomainReasoner.hs +++ b/src/Service/DomainReasoner.hs @@ -1,192 +1,189 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.DomainReasoner - ( -- * Domain Reasoner data type - DomainReasoner, runDomainReasoner, runWithCurrent - , liftEither, MonadIO(..), catchError - -- * Update functions - , addPackages, addPackage, addPkgService - , addServices, addService, addTestSuite - , setVersion, setFullVersion - -- * Accessor functions - , getPackages, getExercises, getServices - , getVersion, getFullVersion, getTestSuite - , findPackage, findService - ) where - -import Common.Library -import Common.TestSuite -import Common.Utils (Some(..)) -import Control.Monad.Error -import Control.Monad.State -import Data.Maybe -import Service.Types -import Service.ExercisePackage - ------------------------------------------------------------------------ --- Domain Reasoner data type - -newtype DomainReasoner a = DR { unDR :: ErrorT String (StateT Content IO) a } - -data Content = Content - { packages :: [Some ExercisePackage] - , services :: [Some ExercisePackage] -> [Service] - , testSuite :: TestSuite - , version :: String - , fullVersion :: Maybe String - } - -noContent :: Content -noContent = Content [] (const []) (return ()) [] Nothing - -runDomainReasoner :: DomainReasoner a -> IO a -runDomainReasoner m = do - result <- evalStateT (runErrorT (unDR m)) noContent - case result of - Left msg -> fail msg - Right a -> return a - --- | Returns a run function, based on the current state, inside the monad -runWithCurrent :: DomainReasoner (DomainReasoner a -> IO a) -runWithCurrent = - get >>= \st -> return (runDomainReasoner . (put st >>)) - -liftEither :: Either String a -> DomainReasoner a -liftEither = either fail return - ------------------------------------------------------------------------ --- Instance declarations - -instance Monad DomainReasoner where - return a = DR (return a) - DR m >>= f = DR (m >>= unDR . f) - fail s = DR (fail s) - -instance MonadError String DomainReasoner where - throwError = fail - catchError m f = DR (unDR m `catchError` (unDR . f)) - -instance MonadPlus DomainReasoner where - mzero = DR mzero - a `mplus` b = DR (unDR a `mplus` unDR b) - -instance MonadState Content DomainReasoner where - get = DR get - put s = DR (put s) - -instance MonadIO DomainReasoner where - liftIO m = DR (liftIO m) - ------------------------------------------------------------------------ --- Update functions - -addPackages :: [Some ExercisePackage] -> DomainReasoner () -addPackages xs = modify $ \c -> c { packages = xs ++ packages c } - -addPackage :: Some ExercisePackage -> DomainReasoner () -addPackage pkg = addPackages [pkg] - -addPkgService :: ([Some ExercisePackage] -> Service) -> DomainReasoner () -addPkgService f = modify $ \c -> - c { services = \xs -> f xs : services c xs } - -addServices :: [Service] -> DomainReasoner () -addServices = mapM_ (addPkgService . const) - -addService :: Service -> DomainReasoner () -addService s = addServices [s] - -addTestSuite :: TestSuite -> DomainReasoner () -addTestSuite m = modify $ \c -> c { testSuite = testSuite c >> m } - -setVersion :: String -> DomainReasoner () -setVersion s = modify $ \c -> c { version = s } - -setFullVersion :: String -> DomainReasoner () -setFullVersion s = modify $ \c -> c { fullVersion = Just s } - ------------------------------------------------------------------------ --- Accessor functions - -getPackages :: DomainReasoner [Some ExercisePackage] -getPackages = gets packages - -getExercises :: DomainReasoner [Some Exercise] -getExercises = gets (map (\(Some pkg) -> Some (exercise pkg)) . packages) - -getServices :: DomainReasoner [Service] -getServices = gets (\c -> services c (packages c)) - -getVersion :: DomainReasoner String -getVersion = gets version - -getFullVersion :: DomainReasoner String -getFullVersion = gets fullVersion >>= maybe getVersion return - -getTestSuite :: DomainReasoner TestSuite -getTestSuite = gets testSuite - -findPackage :: Id -> DomainReasoner (Some ExercisePackage) -findPackage i = do - pkgs <- getPackages - case [ a | a@(Some pkg) <- pkgs, getId pkg == resolveId i ] of - [this] -> return this - _ -> fail $ "Package " ++ show i ++ " not found" - -findService :: String -> DomainReasoner Service -findService txt = do - srvs <- getServices - case filter ((==txt) . showId) srvs of - [hd] -> return hd - [] -> fail $ "No service " ++ txt - _ -> fail $ "Ambiguous service " ++ txt - ------------------------------------------------------------------------ --- Identifier aliases (temporary) - -resolveId :: Id -> Id -resolveId i = fromMaybe i (lookup i table) - where - table = map (newId *** newId) - [ ("math.coverup", "algebra.equations.coverup") - , ("math.lineq", "algebra.equations.linear") - , ("math.lineq-mixed", "algebra.equations.linear.mixed") - , ("math.quadreq", "algebra.equations.quadratic") - , ("math.quadreq-no-abc", "algebra.equations.quadratic.no-abc") - , ("math.quadreq-with-approx", "algebra.equations.quadratic.approximate") - , ("math.higherdegree", "algebra.equations.polynomial") - , ("math.rationaleq", "algebra.equations.rational") - , ("math.linineq", "algebra.inequalities.linear") - , ("math.quadrineq", "algebra.inequalities.quadratic") - , ("math.ineqhigherdegree", "algebra.inequalities.polynomial") - , ("math.factor", "algebra.manipulation.polynomial.factor") - , ("math.simplifyrational", "algebra.manipulation.rational.simplify") - , ("math.simplifypower", "algebra.manipulation.exponents.simplify") - , ("math.nonnegexp", "algebra.manipulation.exponents.nonnegative") - , ("math.powerof", "algebra.manipulation.exponents.powerof") - , ("math.derivative", "calculus.differentiation") - , ("math.fraction", "arithmetic.fractions") - , ("math.calcpower", "arithmetic.exponents") - , ("linalg.gaussianelim", "linearalgebra.gaussianelim") - , ("linalg.gramschmidt", "linearalgebra.gramschmidt") - , ("linalg.linsystem", "linearalgebra.linsystem") - , ("linalg.systemwithmatrix", "linearalgebra.systemwithmatrix") - , ("logic.dnf", "logic.propositional.dnf") - , ("logic.dnf-unicode", "logic.propositional.dnf.unicode") - , ("relationalg.cnf", "relationalgebra.cnf") - -- MathDox compatibility - , ("gaussianelimination" , "linearalgebra.gaussianelim") - , ("gramschmidt" , "linearalgebra.gramschmidt") - , ("solvelinearsystem" , "linearalgebra.linsystem") - , ("solvelinearsystemwithmatrix", "linearalgebra.systemwithmatrix") - ] +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.DomainReasoner + ( -- * Domain Reasoner data type + DomainReasoner, runDomainReasoner, runWithCurrent + , liftEither, MonadIO(..), catchError + -- * Update functions + , addExercises, addExercise, addExerciseService + , addServices, addService, addViews, addView + , addTestSuite + , addAliases, addScripts, setScriptDir + , setVersion, setFullVersion + -- * Accessor functions + , getExercises, getServices, getViews + , getVersion, getFullVersion, getTestSuite + , findExercise, findService + , readScript, defaultScript + ) where + +import Common.Library +import Common.Utils (Some(..)) +import Common.Utils.TestSuite +import Control.Monad.Error +import Control.Monad.State +import Data.Maybe +import Service.FeedbackScript.Parser +import Service.Types + +----------------------------------------------------------------------- +-- Domain Reasoner data type + +newtype DomainReasoner a = DR { unDR :: ErrorT String (StateT Content IO) a } + +data Content = Content + { exercises :: [Some Exercise] + , services :: [Some Exercise] -> [Service] + , views :: [ViewPackage] + , aliases :: [(Id, Id)] + , scriptDir :: Maybe FilePath + , scripts :: [(Id, FilePath)] + , testSuite :: TestSuite + , version :: String + , fullVersion :: Maybe String + } + +noContent :: Content +noContent = Content [] (const []) [] [] Nothing [] (return ()) [] Nothing + +runDomainReasoner :: DomainReasoner a -> IO a +runDomainReasoner m = do + result <- evalStateT (runErrorT (unDR m)) noContent + case result of + Left msg -> fail msg + Right a -> return a + +-- | Returns a run function, based on the current state, inside the monad +runWithCurrent :: DomainReasoner (DomainReasoner a -> IO a) +runWithCurrent = + get >>= \st -> return (runDomainReasoner . (put st >>)) + +liftEither :: Either String a -> DomainReasoner a +liftEither = either throwError return + +----------------------------------------------------------------------- +-- Instance declarations + +instance Monad DomainReasoner where + return a = DR (return a) + DR m >>= f = DR (m >>= unDR . f) + fail s = DR (throwError s) + +instance MonadError String DomainReasoner where + throwError s = DR (throwError s) + catchError m f = DR (unDR m `catchError` (unDR . f)) + +instance MonadPlus DomainReasoner where + mzero = DR mzero + a `mplus` b = DR (unDR a `mplus` unDR b) + +instance MonadState Content DomainReasoner where + get = DR get + put s = DR (put s) + +instance MonadIO DomainReasoner where + liftIO m = DR (liftIO m) + +----------------------------------------------------------------------- +-- Update functions + +addExercises :: [Some Exercise] -> DomainReasoner () +addExercises xs = modify $ \c -> c { exercises = xs ++ exercises c } + +addExercise :: Some Exercise -> DomainReasoner () +addExercise ex = addExercises [ex] + +addExerciseService :: ([Some Exercise] -> Service) -> DomainReasoner () +addExerciseService f = modify $ \c -> + c { services = \xs -> f xs : services c xs } + +addServices :: [Service] -> DomainReasoner () +addServices = mapM_ (addExerciseService . const) + +addService :: Service -> DomainReasoner () +addService s = addServices [s] + +addViews :: [ViewPackage] -> DomainReasoner () +addViews xs = modify $ \c -> c { views = xs ++ views c } + +addView :: ViewPackage -> DomainReasoner () +addView = addViews . return + +addTestSuite :: TestSuite -> DomainReasoner () +addTestSuite m = modify $ \c -> c { testSuite = testSuite c >> m } + +addAliases :: [(Id, Id)] -> DomainReasoner () +addAliases xs = modify $ \c -> c { aliases = xs ++ aliases c } + +setScriptDir :: FilePath -> DomainReasoner () +setScriptDir path = modify $ \c -> c { scriptDir = Just path } + +addScripts :: [(Id, FilePath)] -> DomainReasoner () +addScripts xs = modify $ \c -> c { scripts = xs ++ scripts c } + +setVersion :: String -> DomainReasoner () +setVersion s = modify $ \c -> c { version = s } + +setFullVersion :: String -> DomainReasoner () +setFullVersion s = modify $ \c -> c { fullVersion = Just s } + +----------------------------------------------------------------------- +-- Accessor functions + +getExercises :: DomainReasoner [Some Exercise] +getExercises = gets exercises + +getServices :: DomainReasoner [Service] +getServices = gets (\c -> services c (exercises c)) + +getViews :: DomainReasoner [ViewPackage] +getViews = gets views + +getVersion :: DomainReasoner String +getVersion = gets version + +getFullVersion :: DomainReasoner String +getFullVersion = gets fullVersion >>= maybe getVersion return + +getTestSuite :: DomainReasoner TestSuite +getTestSuite = gets testSuite + +findExercise :: Id -> DomainReasoner (Some Exercise) +findExercise i = do + xs <- getExercises + table <- gets aliases + let res = fromMaybe i (lookup i table) + case [ a | a@(Some ex) <- xs, getId ex == res ] of + [this] -> return this + _ -> throwError $ "Exercise " ++ show i ++ " not found" + +findService :: String -> DomainReasoner Service +findService txt = do + srvs <- getServices + case filter ((==txt) . showId) srvs of + [hd] -> return hd + [] -> throwError $ "No service " ++ txt + _ -> throwError $ "Ambiguous service " ++ txt + +defaultScript :: Id -> DomainReasoner Script +defaultScript a = do + list <- gets scripts + maybe (return mempty) readScript (lookup a list) + +-- | Returns an empty script if the file does not exist +readScript :: FilePath -> DomainReasoner Script +readScript file = do + path <- gets scriptDir + liftIO $ parseScript path file + `catchError` + \_ -> return mempty diff --git a/src/Service/Evaluator.hs b/src/Service/Evaluator.hs --- a/src/Service/Evaluator.hs +++ b/src/Service/Evaluator.hs @@ -1,100 +1,106 @@ -{-# LANGUAGE GADTs, Rank2Types #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.Evaluator where - -import Common.Library -import Control.Monad -import Data.List -import Service.ExercisePackage -import Service.Types -import Service.DomainReasoner - -evalService :: Evaluator inp out a -> Service -> inp -> DomainReasoner out -evalService f = eval f . serviceFunction - -data Evaluator inp out a = Evaluator - { encoder :: Encoder out a - , decoder :: Decoder inp a - } - -data Encoder s a = Encoder - { encodeType :: forall t . Type a t -> t -> DomainReasoner s - , encodeTerm :: a -> DomainReasoner s - , encodeTuple :: [s] -> s - } - -data Decoder s a = Decoder - { decodeType :: forall t . Type a t -> s -> DomainReasoner (t, s) - , decodeTerm :: s -> DomainReasoner a - , decoderPackage :: ExercisePackage a - } - -decoderExercise :: Decoder s a -> Exercise a -decoderExercise = exercise . decoderPackage - -eval :: Evaluator inp out a -> TypedValue a -> inp -> DomainReasoner out -eval f (tv ::: tp) s = - case tp of - t1 :-> t2 -> do - (a, s1) <- decodeType (decoder f) t1 s - eval f (tv a ::: t2) s1 - _ -> - encodeType (encoder f) tp tv - -decodeDefault :: Decoder s a -> Type a t -> s -> DomainReasoner (t, s) -decodeDefault dec tp s = - case tp of - Iso f _ t -> liftM (first f) (decodeType dec t s) - Pair t1 t2 -> do - (a, s1) <- decodeType dec t1 s - (b, s2) <- decodeType dec t2 s1 - return ((a, b), s2) - t1 :|: t2 -> - liftM (first Left) (decodeType dec t1 s) `mplus` - liftM (first Right) (decodeType dec t2 s) - Unit -> - return ((), s) - Tag _ t1 -> - decodeType dec t1 s - ExercisePkg -> - return (decoderPackage dec, s) - _ -> - fail $ "No support for argument type: " ++ show tp - -encodeDefault :: Encoder s a -> Type a t -> t -> DomainReasoner s -encodeDefault enc tp tv = - case tp of - Iso _ f t -> encodeType enc t (f tv) - Pair t1 t2 -> do - let (a, b) = tv - x <- encodeType enc t1 a - y <- encodeType enc t2 b - return (encodeTuple enc [x, y]) - t1 :|: t2 -> case tv of - Left a -> encodeType enc t1 a - Right b -> encodeType enc t2 b - Unit -> return (encodeTuple enc []) - Tag _ t1 -> encodeType enc t1 tv - IO t1 -> do let pp s | "user error (" `isPrefixOf` s = init (drop 12 s) - | otherwise = s - result <- liftIO $ - liftM Right tv `catch` (return . Left . pp . show) - case result of - Left msg -> fail msg - Right a -> encodeType enc t1 a - Rule -> encodeType enc String (showId tv) - Term -> encodeTerm enc tv - Context -> fromContext tv >>= encodeType enc Term - Location -> encodeType enc String (show tv) - ExercisePkg -> return (encodeTuple enc []) - _ -> fail ("No support for result type: " ++ show tp) +{-# LANGUAGE GADTs, Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.Evaluator where + +import Common.Library +import Control.Monad +import Service.DomainReasoner +import Service.Types +import System.Random + +evalService :: Evaluator inp out a -> Service -> inp -> DomainReasoner out +evalService f = eval f . serviceFunction + +data Evaluator inp out a = Evaluator + { encoder :: Encoder out a + , decoder :: Decoder inp a + } + +data Encoder s a = Encoder + { encodeType :: forall t . Type a t -> t -> DomainReasoner s + , encodeCtxTerm :: Context a -> DomainReasoner s + , encodeTerm :: a -> DomainReasoner s + , encodeTuple :: [s] -> s + } + +data Decoder s a = Decoder + { decodeType :: forall t . Type a t -> s -> DomainReasoner (t, s) + , decodeTerm :: s -> DomainReasoner a + , decoderExercise :: Exercise a + } + +eval :: Evaluator inp out a -> TypedValue a -> inp -> DomainReasoner out +eval f (tv ::: tp) s = + case tp of + t1 :-> t2 -> do + (a, s1) <- decodeType (decoder f) t1 s + eval f (tv a ::: t2) s1 + _ -> + encodeType (encoder f) tp tv + +decodeDefault :: Decoder s a -> Type a t -> s -> DomainReasoner (t, s) +decodeDefault dec tp s = + case tp of + Iso p t -> liftM (from (first p)) (decodeType dec t s) + Pair t1 t2 -> do + (a, s1) <- decodeType dec t1 s + (b, s2) <- decodeType dec t2 s1 + return ((a, b), s2) + t1 :|: t2 -> + liftM (first Left) (decodeType dec t1 s) `mplus` + liftM (first Right) (decodeType dec t2 s) + Unit -> + return ((), s) + Tag _ t1 -> + decodeType dec t1 s + Exercise -> + return (decoderExercise dec, s) + StdGen -> do + stdgen <- liftIO newStdGen + return (stdgen, s) + Script -> do + script <- defaultScript (getId (decoderExercise dec)) + return (script, s) + _ -> + fail $ "No support for argument type: " ++ show tp + +encodeDefault :: Encoder s a -> Type a t -> t -> DomainReasoner s +encodeDefault enc tp tv = + case tp of + Iso p t -> encodeType enc t (to p tv) + Pair t1 t2 -> + case tv of + (a, b) -> do + x <- encodeType enc t1 a + y <- encodeType enc t2 b + return (encodeTuple enc [x, y]) + List t -> liftM (encodeTuple enc) (mapM (encodeType enc t) tv) + t1 :|: t2 -> case tv of + Left a -> encodeType enc t1 a + Right b -> encodeType enc t2 b + Unit -> return (encodeTuple enc []) + Tag _ t1 -> encodeType enc t1 tv + Rule -> encodeType enc String (showId tv) + Term -> encodeTerm enc tv + Context -> fromContext tv >>= encodeType enc Term + Location -> encodeAsString enc tv + Id -> encodeAsString enc tv + Int -> encodeAsString enc tv + Exercise -> return (encodeTuple enc []) + IO t -> do a <- liftIO tv + encodeType enc t a + Exception -> fail tv + _ -> fail ("No support for result type: " ++ show tp) + +encodeAsString :: Show b => Encoder s a -> b -> DomainReasoner s +encodeAsString enc a = encodeType enc String (show a) diff --git a/src/Service/ExercisePackage.hs b/src/Service/ExercisePackage.hs deleted file mode 100644 --- a/src/Service/ExercisePackage.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.ExercisePackage - ( -- Type, and selectors - ExercisePackage, exercise, withOpenMath - , toOpenMath, fromOpenMath, getExerciseText - -- Constructors - , package, termPackage, somePackage, someTermPackage - -- Conversion functions to/from OpenMath - , termToOMOBJ, omobjToTerm - -- ExerciseText datatype - , ExerciseText(..) - ) where - -import Common.Library -import Common.Utils (Some(..)) -import Common.Rewriting.Term -import Control.Monad -import Data.Char -import Data.List -import Text.OpenMath.Object -import qualified Text.OpenMath.Symbol as OM -import Text.OpenMath.Dictionary.Fns1 - ------------------------------------------------------------------------------ --- Package data type (and constructor functions) - -data ExercisePackage a = P - { exercise :: Exercise a - , withOpenMath :: Bool - , toOpenMath :: a -> OMOBJ - , fromOpenMath :: MonadPlus m => OMOBJ -> m a - , getExerciseText :: Maybe (ExerciseText a) - } - -instance HasId (ExercisePackage a) where - getId = getId . exercise - changeId f pkg = pkg { exercise = changeId f (exercise pkg) } - -package :: Exercise a -> ExercisePackage a -package ex = P - { exercise = ex - , withOpenMath = False - , toOpenMath = error "no OpenMath support" - , fromOpenMath = fail "no OpenMath support" - , getExerciseText = Nothing - } - -termPackage :: IsTerm a => Exercise a -> ExercisePackage a -termPackage ex = (package ex) - { withOpenMath = True - , toOpenMath = termToOMOBJ . toTerm - , fromOpenMath = (>>= fromTerm) . omobjToTerm - } - -somePackage :: Exercise a -> Some ExercisePackage -somePackage = Some . package - -someTermPackage :: IsTerm a => Exercise a -> Some ExercisePackage -someTermPackage = Some . termPackage - ------------------------------------------------------------------------------ --- Utility functions for conversion to/from OpenMath - -termToOMOBJ :: Term -> OMOBJ -termToOMOBJ term = - case term of - Var s -> OMV s - Con s -> OMS (idToSymbol (getId s)) - Meta i -> OMV ('$' : show i) - Num n -> OMI n - Float d -> OMF d - Apply _ _ -> let (f, xs) = getSpine term - in make (map termToOMOBJ (f:xs)) - where - make [OMS s, OMV x, body] | s == lambdaSymbol = - OMBIND (OMS s) [x] body - make xs = OMA xs - -omobjToTerm :: MonadPlus m => OMOBJ -> m Term -omobjToTerm omobj = - case omobj of - OMV x -> case isMeta x of - Just n -> return (Meta n) - Nothing -> return (Var x) - OMS s -> return (symbol (newSymbol (OM.dictionary s # OM.symbolName s))) - OMI n -> return (Num n) - OMF a -> return (Float a) - OMA (x:xs) -> liftM2 makeTerm (omobjToTerm x) (mapM omobjToTerm xs) - OMBIND binder xs body -> - omobjToTerm (OMA (binder:map OMV xs++[body])) - _ -> fail "Invalid OpenMath object" - where - isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' - isMeta _ = Nothing - -idToSymbol :: Id -> OM.Symbol -idToSymbol a - | null (qualifiers a) = - OM.extraSymbol (unqualified a) - | otherwise = - OM.makeSymbol (qualification a) (unqualified a) - ------------------------------------------------------------- --- Exercise Text data type --- Note: ideally, this should be defined elsewhere - --- Exercise extension for textual feedback -data ExerciseText a = ExerciseText - { ruleText :: Rule (Context a) -> Maybe String - , appliedRule :: Rule (Context a) -> String - , feedbackSyntaxError :: String -> String - , feedbackSame :: String - , feedbackBuggy :: Bool -> [Rule (Context a)] -> String - , feedbackNotEquivalent :: Bool -> String - , feedbackOk :: [Rule (Context a)] -> (String, Bool) - , feedbackDetour :: Bool -> Maybe (Rule (Context a)) -> [Rule (Context a)] -> (String, Bool) - , feedbackUnknown :: Bool -> String - } diff --git a/src/Service/FeedbackScript/Analysis.hs b/src/Service/FeedbackScript/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Service/FeedbackScript/Analysis.hs @@ -0,0 +1,101 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Analysis of a feedbackscript +-- +----------------------------------------------------------------------------- +module Service.FeedbackScript.Analysis (withScripts) where + +import Common.Exercise +import Common.Id +import Common.Transformation +import Common.Utils (Some(..)) +import Common.Utils.Uniplate +import Control.Monad +import Data.Either +import Data.List +import Service.DomainReasoner +import Service.FeedbackScript.Parser +import Service.FeedbackScript.Run +import Service.FeedbackScript.Syntax + +withScripts :: Maybe FilePath -> [String] -> [FilePath] -> DomainReasoner () +withScripts path xs ys = do + -- generate scripts + forM_ xs $ \s -> do + Some ex <- findExercise (newId s) + liftIO $ print (generateScript ex) + -- analyze scripts + forM_ ys $ \file -> do + liftIO $ putStrLn $ "Parsing " ++ show file + script <- liftIO $ parseScript path file + let sups = [ a | Supports as <- scriptDecls script, a <- as ] + exs <- forM sups $ \a -> + liftM Right (findExercise a) + `catchError` \_ -> return $ Left $ UnknownExercise a + + let ms = lefts exs ++ analyzeScript (rights exs) script + liftIO $ do + putStrLn $ unlines $ map show ms + putStrLn $ "(errors: " ++ show (length ms) ++ ")" + +generateScript :: Exercise a -> Script +generateScript ex = makeScript $ + Supports [getId ex] : + [ feedbackDecl s mempty | s <- feedbackIds ] ++ + [ textForIdDecl r (makeText (description r)) | r <- nrs ] ++ + [ textForIdDecl r (makeText (description r)) | r <- brs ] + where + (brs, nrs) = partition isBuggyRule (ruleset ex) + +data Message = UnknownExercise Id + | UnknownFeedback Id + | FeedbackUndefined Id + | NoTextForRule Id Id + | UnknownAttribute Id + | UnknownCondAttr Id + +instance Show Message where + show message = + case message of + UnknownExercise a -> "Unknown exercise id " ++ show a + UnknownFeedback a -> "Unknown feedback category " ++ show a + FeedbackUndefined a -> "Feedback category " ++ show a ++ " is not defined" + NoTextForRule a b -> "No text for rule " ++ show a ++ " of exercise " ++ show b + UnknownAttribute a -> "Unknown attribute @" ++ show a ++ " in text" + UnknownCondAttr a -> "Unknown attribute @" ++ show a ++ " in condition" + +analyzeScript :: [Some Exercise] -> Script -> [Message] +analyzeScript exs script = + map FeedbackUndefined (filter (`notElem` fbids) feedbackIds) ++ + map UnknownFeedback (filter (`notElem`feedbackIds ) fbids) ++ + [ NoTextForRule (getId r) (getId ex) + | Some ex <- exs, r <- ruleset ex, noTextFor (getId r) + ] ++ + [ UnknownAttribute a | a <- textRefs + , a `notElem` feedbackIds ++ attributeIds ++ strids ] ++ + [ UnknownCondAttr a | a <- condRefs, a `notElem` conditionIds ] + where + decls = scriptDecls script + fbids = [ a | Simple Feedback as _ <- decls, a <- as ] ++ + [ a | Guarded Feedback as _ <- decls, a <- as ] + txids = [ a | Simple TextForId as _ <- decls, a <- as ] ++ + [ a | Guarded TextForId as _ <- decls, a <- as ] + strids = [ a | Simple StringDecl as _ <- decls, a <- as ] ++ + [ a | Guarded StringDecl as _ <- decls, a <- as ] + namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ] + noTextFor a = null [ () | n <- namespaces, b <- txids, n#b == a ] + + texts = [ t | Simple _ _ t <- decls ] ++ + [ t | Guarded _ _ xs <- decls, (_, t) <- xs ] + textRefs = [ a | t <- texts, TextRef a <- universe t ] + + conditions = [ c | Guarded _ _ xs <- decls , (c, _) <- xs ] + condRefs = [ a | c <- conditions, CondRef a <- universe c ] diff --git a/src/Service/FeedbackScript/Parser.hs b/src/Service/FeedbackScript/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Service/FeedbackScript/Parser.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Simple parser for feedback scripts +-- +----------------------------------------------------------------------------- +module Service.FeedbackScript.Parser (parseScript, Script) where + +import Common.Id +import Control.Monad.Error +import Data.Char +import Data.Monoid +import Service.FeedbackScript.Syntax +import Text.ParserCombinators.Parsec +import Text.Parsing + +-- chases all included script files +parseScript :: Maybe FilePath -> FilePath -> IO Script +parseScript path file = rec [] [file] + where + rec _ [] = return mempty + rec hist (a:as) + | a `elem` hist = rec hist as + | otherwise = do + s1 <- parseOneScriptFile path a + let new = [ b | Include bs <- scriptDecls s1, b <- bs ] + s2 <- rec (a:hist) (new++as) -- depth-first + return (s1 <> s2) -- included parts are inserted at the end + +parseOneScriptFile :: Maybe FilePath -> FilePath -> IO Script +parseOneScriptFile path file = do + result <- parseFromFile script full + case result of + Left e -> print e >> return mempty + Right xs -> return xs + where + full = maybe id (\p a -> p ++ "/" ++ a) path file + +script :: Parser Script +script = makeScript <$> complete decls + +decls :: Parser [Decl] +decls = many $ do + pos <- getPosition + guard (sourceColumn pos == 1) + decl + +decl :: Parser Decl +decl = do + dt <- declType + a <- identifiers + f <- simpleDecl <|> guardedDecl + return (f dt a) + <|> + NameSpace <$ lexString "namespace" <*> identifiers + <|> + Supports <$ lexString "supports" <*> identifiers + <|> + Include <$ lexString "include" <*> filenames + "declaration" + +simpleDecl, guardedDecl :: Parser (DeclType -> [Id] -> Decl) +simpleDecl = (\t dt a -> Simple dt a t) + <$> text +guardedDecl = (\xs dt a -> Guarded dt a xs) + <$> many1 ((,) <$> (lexChar '|' *> condition) <*> text) + +declType :: Parser DeclType +declType = (TextForId <$ lexString "text") + <|> (StringDecl <$ lexString "string") + <|> (Feedback <$ lexString "feedback") + +condition :: Parser Condition +condition = choice + [ CondRef <$> lexeme attribute + , RecognizedIs <$ lexString "recognize" <*> identifier + , CondConst True <$ lexString "true" + , CondConst False <$ lexString "false" + , CondNot <$ lexString "not" <*> condition + ] + +text :: Parser Text +text = lexChar '=' *> (singleLineText <|> multiLineText) + +singleLineText :: Parser Text +singleLineText = + mconcat <$> manyTill textItem (lexeme (skip newline <|> comment)) + +multiLineText :: Parser Text +multiLineText = + mconcat <$ char '{' + <*> manyTill (textItem <|> (mempty <$ newline)) (lexChar '}') + +textItem :: Parser Text +textItem = makeText <$> many1 (noneOf "@#{}\n" <|> try escaped) + <|> TextRef <$> attribute + where + escaped = char '@' *> satisfy (not . isAlphaNum) + +identifiers :: Parser [Id] +identifiers = sepBy1 identifier (lexChar ',') + +-- Lexical units +identifier :: Parser Id +identifier = lexeme (mconcat . map newId <$> idPart `sepBy1` char '.') + "identifier" + where + idPart = many1 idLetter + idLetter = alphaNum <|> oneOf "-_" + +attribute :: Parser Id +attribute = newId <$ skip (char '@') <*> many1 (alphaNum <|> oneOf "-_") + "attribute" + +filenames :: Parser [FilePath] +filenames = sepBy1 filename (lexChar ',') + +filename :: Parser FilePath +filename = lexeme $ many1 (alphaNum <|> oneOf "+-_./\\:;|") + +lexChar :: Char -> Parser () +lexChar = skip . lexeme . char + +lexString :: String -> Parser () +lexString s = skip (lexeme (try (string s))) "string " ++ show s + +comment :: Parser () +comment = skip (char '#' <* manyTill (noneOf "\n") (skip newline <|> eof)) + +-- parse white space and comments afterwards +lexeme :: Parser a -> Parser a +lexeme p = p <* skipMany (skip space <|> comment) diff --git a/src/Service/FeedbackScript/Run.hs b/src/Service/FeedbackScript/Run.hs new file mode 100644 --- /dev/null +++ b/src/Service/FeedbackScript/Run.hs @@ -0,0 +1,161 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Run a feedbackscript +-- +----------------------------------------------------------------------------- +module Service.FeedbackScript.Run + ( Script + , Environment(..), newEnvironment + , feedbackDiagnosis, feedbackHint + , ruleToString, feedbackIds, attributeIds, conditionIds + ) where + +import Common.Library hiding (ready, Environment) +import Common.Utils (safeHead) +import Control.Monad +import Data.List +import Data.Maybe +import Service.BasicServices +import Service.Diagnose +import Service.FeedbackScript.Syntax +import Service.State + +data Environment a = Env + { oldReady :: Bool + , expected :: Maybe (Rule (Context a)) + , recognized :: Maybe (Rule (Context a)) + , diffPair :: Maybe (String, String) + , before :: Maybe Term + , after :: Maybe Term + , afterText :: Maybe String + } + +newEnvironment :: State a -> Environment a +newEnvironment st = Env + { oldReady = ready st + , expected = fmap fst4 next + , recognized = Nothing + , diffPair = Nothing + , before = f st + , after = liftM fth4 next >>= f + , afterText = liftM fth4 next >>= g + } + where + next = either (const Nothing) Just (onefirst st) + f s = fmap (`build` stateTerm s) (hasTermView (exercise s)) + g s = return $ prettyPrinter (exercise s) (stateTerm s) + fst4 (a, _, _, _) = a + fth4 (_, _, _, a) = a + +toText :: Environment a -> Script -> Text -> Maybe Text +toText env script = eval env script . Right + +ruleToString :: Environment a -> Script -> Rule b -> String +ruleToString env script r = + let f = eval env script . Left . getId + in maybe (showId r) show (f r) + +eval :: Environment a -> Script -> Either Id Text -> Maybe Text +eval env script = either (return . findIdRef) evalText + where + evalText :: Text -> Maybe Text + evalText = liftM mconcat . mapM unref . textItems + where + unref (TextRef a) + | a == expectedId = fmap (findIdRef . getId) (expected env) + | a == recognizedId = fmap (findIdRef . getId) (recognized env) + | a == diffbeforeId = fmap (TextString . fst) (diffPair env) + | a == diffafterId = fmap (TextString . snd) (diffPair env) + | a == beforeId = fmap TextTerm (before env) + | a == afterId = fmap TextTerm (after env) + | a == afterTextId = fmap TextString (afterText env) + | otherwise = findRef (==a) + unref t = Just t + + evalBool :: Condition -> Bool + evalBool (RecognizedIs a) = maybe False (eqId a . getId) (recognized env) + evalBool (CondNot c) = not (evalBool c) + evalBool (CondConst b) = b + evalBool (CondRef a) + | a == oldreadyId = oldReady env + | a == hasexpectedId = isJust (expected env) + | otherwise = False + + namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ] + + -- equality with namespaces + eqId :: Id -> Id -> Bool + eqId a b = any (\n -> n#a == b) namespaces + + findIdRef :: Id -> Text + findIdRef x = fromMaybe (TextString (showId x)) (findRef (`eqId` x)) + + findRef :: (Id -> Bool) -> Maybe Text + findRef p = safeHead $ catMaybes + [ evalText t + | (as, c, t) <- allDecls + , any p as && evalBool c + ] + + allDecls = + let f (Simple _ as t) = [ (as, CondConst True, t) ] + f (Guarded _ as xs) = [ (as, c, t) | (c, t) <- xs ] + f _ = [] + in concatMap f (scriptDecls script) + +feedbackDiagnosis :: Diagnosis a -> Environment a -> Script -> Text +feedbackDiagnosis diagnosis env = + fromMaybe (TextString "ERROR") . + case diagnosis of + Buggy _ r -> make "buggy" env {recognized = Just r} + NotEquivalent -> make "noteq" env + Expected _ _ r -> make "ok" env {recognized = Just r} + Similar _ _ -> make "same" env + Detour _ _ _ r -> make "detour" env {recognized = Just r} + Correct _ _ -> make "unknown" env + +feedbackHint :: Bool -> Environment a -> Script -> Text +feedbackHint b env script = + fromMaybe (defaultHint env script) $ + make (if b then "hint" else "step") env script + +defaultHint :: Environment a -> Script -> Text +defaultHint env script = makeText $ + case expected env of + Just r -> ruleToString env script r + Nothing -> "Sorry, not hint available." + +make :: String -> Environment a -> Script -> Maybe Text +make s env script = toText env script (TextRef (newId s)) + +feedbackIds :: [Id] +feedbackIds = map newId + ["same", "noteq", "unknown", "ok", "buggy", "detour", "hint", "step"] + +attributeIds :: [Id] +attributeIds = + [expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId] + +conditionIds :: [Id] +conditionIds = [oldreadyId, hasexpectedId] + +expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId :: Id +expectedId = newId "expected" +recognizedId = newId "recognized" +diffbeforeId = newId "diffbefore" +diffafterId = newId "diffafter" +beforeId = newId "before" +afterId = newId "after" +afterTextId = newId "aftertext" + +oldreadyId, hasexpectedId :: Id +oldreadyId = newId "oldready" +hasexpectedId = newId "hasexpected" diff --git a/src/Service/FeedbackScript/Syntax.hs b/src/Service/FeedbackScript/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Service/FeedbackScript/Syntax.hs @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Abstract syntax for feedback scripts, and pretty-printer (Show instance) +-- +----------------------------------------------------------------------------- +module Service.FeedbackScript.Syntax + ( Script, makeScript, scriptDecls, makeText, textItems + , Decl(..), DeclType(..), Text(..), Condition(..) + , feedbackDecl, textForIdDecl + , module Data.Monoid, (<>) + ) where + +import Common.Algebra.Group ((<>)) +import Common.Library +import Common.Utils (commaList, safeHead) +import Common.Utils.Uniplate +import Data.Char +import Data.Monoid + +newtype Script = S { scriptDecls :: [Decl] } + +makeScript :: [Decl] -> Script +makeScript = S + +data Decl + = NameSpace [Id] + | Supports [Id] + | Include [FilePath] + | Simple DeclType [Id] Text + | Guarded DeclType [Id] [(Condition, Text)] + +data DeclType = TextForId | StringDecl | Feedback + +data Text + = TextString String + | TextTerm Term + | TextRef Id + | TextEmpty + | Text :<>: Text + +data Condition + = RecognizedIs Id + | CondNot Condition + | CondConst Bool + | CondRef Id + +makeText :: String -> Text +makeText s = case words s of + [] -> TextEmpty + xs -> TextString (combineList xs) + +feedbackDecl, textForIdDecl :: HasId a => a -> Text -> Decl +feedbackDecl a = Simple Feedback [getId a] +textForIdDecl a = Simple TextForId [getId a] + +instance Show Script where + show = unlines . map show . scriptDecls + +instance Show Decl where + show decl = + let idList = commaList . map show + f dt as = unwords [show dt, idList as] + g (c, t) = " | " ++ show c ++ " = " ++ nonEmpty (show t) + nonEmpty xs = if null xs then "{}" else xs + in case decl of + NameSpace as -> "namespace " ++ idList as + Supports as -> "supports " ++ idList as + Include xs -> "include " ++ commaList xs + Simple dt as t -> f dt as ++ " = " ++ nonEmpty (show t) + Guarded dt as xs -> unlines (f dt as : map g xs) + +instance Show DeclType where + show TextForId = "text" + show StringDecl = "string" + show Feedback = "feedback" + +instance Show Condition where + show (RecognizedIs a) = "recognize " ++ show a + show (CondNot c) = "not " ++ show c + show (CondConst b) = map toLower (show b) + show (CondRef a) = '@' : show a + +instance Show Text where + show (TextString s) = s + show (TextTerm a) = show a + show TextEmpty = "" + show t@(_ :<>: _) = show [t] + show (TextRef a) = '@' : show a + + showList xs ys = + foldr (combine . show) ys (concatMap textItems xs) + +instance Monoid Script where + mempty = makeScript [] + mappend s t = makeScript (scriptDecls s ++ scriptDecls t) + +instance Monoid Text where + mempty = TextEmpty + mappend = (:<>:) + +instance Uniplate Condition where + uniplate (CondNot a) = plate CondNot |* a + uniplate c = plate c + +instance Uniplate Text where + uniplate (a :<>: b) = plate (:<>:) |* a |* b + uniplate t = plate t + +textItems :: Text -> [Text] +textItems t = rec t [] + where + rec (a :<>: b) = rec a . rec b + rec TextEmpty = id + rec a = (a:) + +combineList :: [String] -> String +combineList = foldr combine [] + +combine :: String -> String -> String +combine a b + | null a = b + | null b = a + | maybe False special (safeHead b) = a ++ b + | otherwise = a ++ " " ++ b + where + special = (`elem` ".,:;?!") diff --git a/src/Service/FeedbackText.hs b/src/Service/FeedbackText.hs --- a/src/Service/FeedbackText.hs +++ b/src/Service/FeedbackText.hs @@ -1,111 +1,76 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.FeedbackText - ( ExerciseText(..) - , onefirsttext, submittext, derivationtext, submitHelper - ) where - -import Common.Library hiding (derivation) -import Data.Maybe -import Common.Utils -import Service.Diagnose (restartIfNeeded) -import Service.ExercisePackage -import Service.State -import Service.Submit -import Service.BasicServices - ------------------------------------------------------------- --- Services - -derivationtext :: Monad m => State a -> Maybe String -> m [(String, Context a)] -derivationtext state _event = do - exText <- exerciseText state - xs <- derivation Nothing state - return (map (first (showRule exText)) xs) - -onefirsttext :: Monad m => State a -> Maybe String -> m (Bool, String, State a) -onefirsttext state event = - case onefirst state of - Just (r, _, s) -> do - exText <- exerciseText state - let mtxt = fromContext (stateContext s) >>= useToRewrite exText r state - msg = case mtxt of - Just txt | event /= Just "hint button" -> txt - _ -> "Use " ++ showRule exText r - return (True, msg, s) - _ -> return (False, "Sorry, no hint available", state) - -submittext :: Monad m => State a -> String -> Maybe String -> m (Bool, String, State a) -submittext state input _event = do - exText <- exerciseText state - return $ - case parser (exercise (exercisePkg state)) input of - Left err -> - (False, feedbackSyntaxError exText err, state) - Right a -> - let result = submit state a - (txt, b) = submitHelper exText state a result - in case getResultState result of - Just new | b -> (True, txt, restartIfNeeded new) - _ -> (False, txt, state) - --- Feedback messages for submit service (free student input). The boolean --- indicates whether the student is allowed to continue (True), or forced --- to go back to the previous state (False) -submitHelper :: ExerciseText a -> State a -> a -> Result a -> (String, Bool) -submitHelper exText old a result = - case result of - Buggy rs -> ( fromMaybe "" (youRewroteInto old a) ++ - feedbackBuggy exText (ready old) rs - , False) - NotEquivalent -> ( fromMaybe "" (youRewroteInto old a) ++ - feedbackNotEquivalent exText (ready old) - , False) - Ok rs _ - | null rs -> (feedbackSame exText, False) - | otherwise -> feedbackOk exText rs - Detour rs _ -> feedbackDetour exText (ready old) (expected old) rs - Unknown _ -> ( fromMaybe "" (youRewroteInto old a) ++ - feedbackUnknown exText (ready old) - , False) - where - expected s = do - xs <- allfirsts s - fmap fst3 (safeHead xs) - ------------------------------------------------------------- --- Helper functions - -showRule :: ExerciseText a -> Rule (Context a) -> String -showRule exText r = - fromMaybe ("rule " ++ showId r) (ruleText exText r) - -useToRewrite :: ExerciseText a -> Rule (Context a) -> State a -> a -> Maybe String -useToRewrite exText r old = rewriteIntoText True txt old - where - txt = "Use " ++ showRule exText r ++ " to rewrite " - -youRewroteInto :: State a -> a -> Maybe String -youRewroteInto = rewriteIntoText False "You rewrote " - -rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String -rewriteIntoText mode txt old a = do - let ex = exercise (exercisePkg old) - p <- fromContext (stateContext old) - (p1, a1) <- difference ex mode p a - return $ txt ++ prettyPrinter ex p1 - ++ " into " ++ prettyPrinter ex a1 ++ ". " - -exerciseText :: Monad m => State a -> m (ExerciseText a) -exerciseText = - let msg = "No support for textual feedback" - in maybe (fail msg) return . getExerciseText . exercisePkg +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.FeedbackText + ( onefirsttext, submittext, derivationtext, feedbacktext + ) where + +import Common.Library hiding (derivation) +import Service.BasicServices +import Service.Diagnose +import Service.FeedbackScript.Run +import Service.FeedbackScript.Syntax +import Service.State + +------------------------------------------------------------ +-- Services + +derivationtext :: Script -> State a -> Either String (Derivation String (Context a)) +derivationtext script state = + let f = ruleToString (newEnvironment state) script . fst + in right (mapFirst f) (derivation Nothing state) + +onefirsttext :: Script -> State a -> Maybe String -> (Text, Maybe (State a)) +onefirsttext script old event = + ( feedbackHint (event == Just "hint button") env script + , fmap fth4 next + ) + where + ex = exercise old + next = either (const Nothing) Just (onefirst old) + fth4 (_, _, _, a) = a + env = (newEnvironment old) + { diffPair = do + new <- fmap fth4 next + oldC <- fromContext (stateContext old) + a <- fromContext (stateContext new) + (d1, d2) <- difference ex oldC a + return (prettyPrinter ex d1, prettyPrinter ex d2) + } + +-- Feedback messages for submit service (free student input). The boolean +-- indicates whether the student is allowed to continue (True), or forced +-- to go back to the previous state (False) +submittext :: Script -> State a -> String -> (Bool, Text, State a) +submittext script old input = + case parser (exercise old) input of + Left msg -> (False, TextString msg, old) + Right a -> feedbacktext script old a + +feedbacktext :: Script -> State a -> a -> (Bool, Text, State a) +feedbacktext script old a = + case diagnosis of + Buggy _ _ -> (False, output, old) + NotEquivalent -> (False, output, old) + Expected _ s _ -> (True, output, s) + Similar _ s -> (True, output, s) + Detour _ s _ _ -> (True, output, s) + Correct _ s -> (False, output, s) + where + diagnosis = diagnose old a + output = feedbackDiagnosis diagnosis env script + ex = exercise old + env = (newEnvironment old) + { diffPair = do + oldC <- fromContext (stateContext old) + (d1, d2) <- difference ex oldC a + return (prettyPrinter ex d1, prettyPrinter ex d2) + } diff --git a/src/Service/ModeJSON.hs b/src/Service/ModeJSON.hs --- a/src/Service/ModeJSON.hs +++ b/src/Service/ModeJSON.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -16,18 +16,17 @@ import Common.Library hiding (exerciseId) import Common.Utils (Some(..), distinct, readM) -import Text.JSON +import Control.Monad.Error +import Data.Char +import Data.Maybe +import Service.DomainReasoner +import Service.Evaluator import Service.Request import Service.State -import qualified Service.Types as Tp -import Service.Types hiding (String) import Service.Submit -import Service.Evaluator -import Service.ExercisePackage -import Service.DomainReasoner -import Control.Monad -import Data.Maybe -import Data.Char +import Service.Types hiding (String) +import Text.JSON +import qualified Service.Types as Tp -- TODO: Clean-up code extractExerciseId :: Monad m => JSON -> m Id @@ -38,12 +37,12 @@ Array (String s:tl) | any p s -> extractExerciseId (Array tl) Array (hd:_) -> extractExerciseId hd _ -> fail "no code" - where + where p c = not (isAlphaNum c || isSpace c || c `elem` ".-") processJSON :: String -> DomainReasoner (Request, String, String) processJSON input = do - json <- parseJSON input + json <- either throwError return (parseJSON input) req <- jsonRequest json vers <- getVersion resp <- jsonRPC json myHandler @@ -51,7 +50,7 @@ return (req, out, "application/json") addVersion :: String -> JSON -> JSON -addVersion version json = +addVersion version json = case json of Object xs -> Object (xs ++ [info]) _ -> json @@ -63,7 +62,7 @@ srv <- case lookupM "method" json of Just (String s) -> return s _ -> fail "Invalid method" - let a = (lookupM "params" json >>= extractExerciseId) + let a = lookupM "params" json >>= extractExerciseId enc <- case lookupM "encoding" json of Nothing -> return Nothing Just (String s) -> liftM Just (readEncoding s) @@ -72,7 +71,7 @@ Nothing -> return Nothing Just (String s) -> return (Just s) _ -> fail "Invalid source" - return Request + return Request { service = srv , exerciseId = a , source = src @@ -82,86 +81,94 @@ myHandler :: JSON_RPC_Handler DomainReasoner myHandler fun arg = do - pkg <- if fun == "exerciselist" - then return (Some (package emptyExercise)) - else extractExerciseId arg >>= findPackage + ex <- if fun == "exerciselist" + then return (Some emptyExercise) + else extractExerciseId arg >>= findExercise srv <- findService fun - case jsonConverter pkg of + case jsonConverter ex of Some conv -> evalService conv srv arg -jsonConverter :: Some ExercisePackage -> Some (Evaluator JSON JSON) -jsonConverter (Some pkg) = - Some (Evaluator (jsonEncoder (exercise pkg)) (jsonDecoder pkg)) +jsonConverter :: Some Exercise -> Some (Evaluator JSON JSON) +jsonConverter (Some ex) = + Some (Evaluator (jsonEncoder ex) (jsonDecoder ex)) jsonEncoder :: Exercise a -> Encoder JSON a jsonEncoder ex = Encoder - { encodeType = encode (jsonEncoder ex) - , encodeTerm = return . String . prettyPrinter ex - , encodeTuple = jsonTuple + { encodeType = encode (jsonEncoder ex) + , encodeCtxTerm = liftM (String . prettyPrinter ex) . fromContext + , encodeTerm = return . String . prettyPrinter ex + , encodeTuple = jsonTuple } where encode :: Encoder JSON a -> Type a t -> t -> DomainReasoner JSON encode enc serviceType a | length xs > 1 = liftM jsonTuple (mapM (\(b ::: t) -> encode enc t b) xs) - | otherwise = + | otherwise = case serviceType of - Tp.Tag s t | s == "Result" -> do - result <- isSynonym submitTypeSynonym (a ::: serviceType) - encodeResult enc result - | s == "elem" -> - encode enc t a - | s == "State" -> do - st <- isSynonym stateTypeSynonym (a ::: serviceType) - encodeState (encodeTerm enc) st - - Tp.List t -> liftM Array (mapM (encode enc t) a) - Tp.Tag s t -> liftM (\b -> Object [(s, b)]) (encode enc t a) - Tp.Int -> return (toJSON a) - Tp.Bool -> return (toJSON a) - Tp.String -> return (toJSON a) - _ -> encodeDefault enc serviceType a + Tp.Tag s t + | s `elem` ["elem", "list"] -> + encode enc t a + | s == "Result" -> do + conv <- equalM serviceType submitType + encodeResult enc (conv a) + | s == "state" -> do + conv <- equalM serviceType stateType + encodeState (encodeTerm enc) (conv a) + + Tp.List t -> liftM Array (mapM (encode enc t) a) + Tp.ArgValueTp -> case a of + ArgValue descr x -> return $ + Object [(labelArgument descr, String (showArgument descr x))] + Tp.Text -> return (toJSON (show a)) + Tp.Tag s t -> liftM (\b -> Object [(s, b)]) (encode enc t a) + Tp.Int -> return (toJSON a) + Tp.Bool -> return (toJSON a) + Tp.String -> return (toJSON a) + _ -> encodeDefault enc serviceType a where xs = tupleList (a ::: serviceType) - + tupleList :: TypedValue a -> [TypedValue a] - tupleList (a ::: Tp.Iso _ f t) = tupleList (f a ::: t) - tupleList (p ::: Tp.Pair t1 t2) = + tupleList (a ::: Tp.Iso p t) = tupleList (to p a ::: t) + tupleList (p ::: Tp.Pair t1 t2) = tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2) + tupleList (a ::: Tag s t) + | s `elem` ["ruletext", "message", "accept"] = tupleList (a ::: t) tupleList tv = [tv] -jsonDecoder :: ExercisePackage a -> Decoder JSON a -jsonDecoder pkg = Decoder - { decodeType = decode (jsonDecoder pkg) - , decodeTerm = reader (exercise pkg) - , decoderPackage = pkg +jsonDecoder :: Exercise a -> Decoder JSON a +jsonDecoder ex = Decoder + { decodeType = decode (jsonDecoder ex) + , decodeTerm = reader (parser ex) + , decoderExercise = ex } where - reader :: Monad m => Exercise a -> JSON -> m a - reader ex (String s) = either (fail . show) return (parser ex s) - reader _ _ = fail "Expecting a string when reading a term" - - decode :: Decoder JSON a -> Type a t -> JSON -> DomainReasoner (t, JSON) + reader :: Monad m => (String -> Either String a) -> JSON -> m a + reader f (String s) = either (fail . show) return (f s) + reader _ _ = fail "Expecting a string when reading a term" + + decode :: Decoder JSON a -> Type a t -> JSON -> DomainReasoner (t, JSON) decode dec serviceType = case serviceType of Tp.Location -> useFirst decodeLocation Tp.Term -> useFirst $ decodeTerm dec Tp.Rule -> useFirst $ \x -> jsonToId x >>= getRule (decoderExercise dec) - Tp.ExercisePkg -> \json -> case json of - Array (String _:rest) -> return (decoderPackage dec, Array rest) - _ -> return (decoderPackage dec, json) - Tp.Int -> useFirst $ \json -> case json of + Tp.Exercise -> \json -> case json of + Array (String _:rest) -> return (decoderExercise dec, Array rest) + _ -> return (decoderExercise dec, json) + Tp.Int -> useFirst $ \json -> case json of Number (I n) -> return (fromIntegral n) _ -> fail "not an integer" - Tp.String -> useFirst $ \json -> case json of + Tp.String -> useFirst $ \json -> case json of String s -> return s _ -> fail "not a string" - Tp.Tag s _ | s == "State" -> do - f <- equalM stateTp serviceType - useFirst (liftM f . decodeState (decoderPackage dec) (decodeTerm dec)) + Tp.Tag s _ | s == "state" -> do + f <- equalM stateType serviceType + useFirst (liftM f . decodeState (decoderExercise dec) (decodeTerm dec)) _ -> decodeDefault dec serviceType - + useFirst :: Monad m => (JSON -> m a) -> JSON -> m (a, JSON) useFirst f (Array (x:xs)) = do a <- f x @@ -178,10 +185,10 @@ -------------------------- encodeState :: Monad m => (a -> m JSON) -> State a -> m JSON -encodeState f st = do +encodeState f st = do theTerm <- f (stateTerm st) return $ Array - [ String (showId (exercisePkg st)) + [ String (showId (exercise st)) , String (maybe "NoPrefix" show (statePrefix st)) , theTerm , encodeContext (getEnvironment (stateContext st)) @@ -192,43 +199,42 @@ where f k = (k, String $ fromMaybe "" $ lookupEnv k env) -decodeState :: Monad m => ExercisePackage a -> (JSON -> m a) -> JSON -> m (State a) -decodeState pkg f (Array [a]) = decodeState pkg f a -decodeState pkg f (Array [String _code, String p, ce, jsonContext]) = do - let ex = exercise pkg - mpr = readM p >>= (`makePrefix` strategy ex) - a <- f ce +decodeState :: Monad m => Exercise a -> (JSON -> m a) -> JSON -> m (State a) +decodeState ex f (Array [a]) = decodeState ex f a +decodeState ex f (Array [String _code, String p, ce, jsonContext]) = do + let mpr = readM p >>= (`makePrefix` strategy ex) + a <- f ce env <- decodeContext jsonContext - return $ makeState pkg mpr (makeContext ex env a) + return $ makeState ex mpr (makeContext ex env a) decodeState _ _ s = fail $ "invalid state" ++ show s decodeContext :: Monad m => JSON -> m Environment decodeContext (String "") = decodeContext (Object []) -- Being backwards compatible (for now) decodeContext (Object xs) = foldM add emptyEnv xs - where - add env (k, String s) = return (storeEnv k s env) + where + add env (k, String s) = return (storeEnv k s env) add _ _ = fail "invalid item in context" decodeContext json = fail $ "invalid context: " ++ show json - + encodeResult :: Encoder JSON a -> Result a -> DomainReasoner JSON encodeResult enc result = case result of -- SyntaxError _ -> [("result", String "SyntaxError")] Buggy rs -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . showId) rs)] - NotEquivalent -> return $ Object [("result", String "NotEquivalent")] + NotEquivalent -> return $ Object [("result", String "NotEquivalent")] Ok rs st -> do - json <- encodeType enc stateTp st + json <- encodeType enc stateType st return $ Object [("result", String "Ok"), ("rules", Array $ map (String . showId) rs), ("state", json)] Detour rs st -> do - json <- encodeType enc stateTp st + json <- encodeType enc stateType st return $ Object [("result", String "Detour"), ("rules", Array $ map (String . showId) rs), ("state", json)] Unknown st -> do - json <- encodeType enc stateTp st + json <- encodeType enc stateType st return $ Object [("result", String "Unknown"), ("state", json)] jsonTuple :: [JSON] -> JSON -jsonTuple xs = - case mapM f xs of +jsonTuple xs = + case mapM f xs of Just ys | distinct (map fst ys) -> Object ys _ -> Array xs where diff --git a/src/Service/ModeXML.hs b/src/Service/ModeXML.hs --- a/src/Service/ModeXML.hs +++ b/src/Service/ModeXML.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -12,30 +12,31 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- -module Service.ModeXML +module Service.ModeXML ( processXML, xmlRequest, openMathConverterTp, stringFormatConverterTp , resultOk, resultError, addVersion ) where import Common.Library hiding (exerciseId) import Common.Utils (Some(..), readM) +import Common.Utils.Uniplate (transform) import Control.Monad import Data.Char import Data.List import Data.Maybe -import Service.ExercisePackage -import Service.ProblemDecomposition +import Service.DomainReasoner +import Service.Evaluator +import Service.FeedbackScript.Syntax +import Service.OpenMathSupport import Service.Request import Service.RulesInfo (rulesInfoXML) -import Service.StrategyInfo import Service.State -import Service.Diagnose +import Service.StrategyInfo import Service.Types -import qualified Service.Types as Tp -import Service.Evaluator import Text.OpenMath.Object +import Text.OpenMath.Symbol import Text.XML -import Service.DomainReasoner +import qualified Service.Types as Tp processXML :: String -> DomainReasoner (Request, String, String) processXML input = do @@ -48,20 +49,20 @@ return (req, out, "application/xml") addVersion :: String -> XML -> XML -addVersion s xml = +addVersion s xml = let info = [ "version" := s ] in xml { attributes = attributes xml ++ info } xmlRequest :: XML -> Either String Request -xmlRequest xml = do +xmlRequest xml = do unless (name xml == "request") $ fail "expected xml tag request" srv <- findAttribute "service" xml let a = extractExerciseId xml enc <- case findAttribute "encoding" xml of Just s -> liftM Just (readEncoding s) - Nothing -> return Nothing - return Request + Nothing -> return Nothing + return Request { service = srv , exerciseId = a , source = findAttribute "source" xml @@ -72,18 +73,18 @@ xmlReply :: Request -> XML -> DomainReasoner XML xmlReply request xml = do srv <- findService (service request) - pkg <- + ex <- case exerciseId request of - Just code -> findPackage code - Nothing + Just code -> findExercise code + Nothing | service request == "exerciselist" -> - return (Some (package emptyExercise)) - | otherwise -> + return (Some emptyExercise) + | otherwise -> fail "unknown exercise code" Some conv <- case encoding request of - Just StringEncoding -> return (stringFormatConverter pkg) - _ -> return (openMathConverter pkg) + Just StringEncoding -> return (stringFormatConverter ex) + _ -> return (openMathConverter ex) res <- evalService conv srv xml return (resultOk res) @@ -91,244 +92,244 @@ extractExerciseId = liftM newId . findAttribute "exerciseid" resultOk :: XMLBuilder -> XML -resultOk body = makeXML "reply" $ do +resultOk body = makeXML "reply" $ do "result" .=. "ok" body resultError :: String -> XML -resultError txt = makeXML "reply" $ do +resultError txt = makeXML "reply" $ do "result" .=. "error" element "message" (text txt) ------------------------------------------------------------ -- Mixing abstract syntax (OpenMath format) and concrete syntax (string) -stringFormatConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder) -stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg) +stringFormatConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder) +stringFormatConverter (Some ex) = Some (stringFormatConverterTp ex) -stringFormatConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a -stringFormatConverterTp pkg = - Evaluator (xmlEncoder False f pkg) (xmlDecoder False g pkg) +stringFormatConverterTp :: Exercise a -> Evaluator XML XMLBuilder a +stringFormatConverterTp ex = + Evaluator (xmlEncoder False f ex) (xmlDecoder False g ex) where - ex = exercise pkg - f = return . element "expr" . text . prettyPrinter ex + f = liftM (element "expr" . text . prettyPrinter ex) . fromContext g xml0 = do xml <- findChild "expr" xml0 -- quick fix -- guard (name xml == "expr") let input = getData xml either (fail . show) return (parser ex input) -openMathConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder) -openMathConverter (Some pkg) = Some (openMathConverterTp pkg) - -openMathConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a -openMathConverterTp pkg = - Evaluator (xmlEncoder True f pkg) (xmlDecoder True g pkg) +openMathConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder) +openMathConverter (Some ex) = Some (openMathConverterTp ex) + +openMathConverterTp :: Exercise a -> Evaluator XML XMLBuilder a +openMathConverterTp ex = + Evaluator (xmlEncoder True f ex) (xmlDecoder True g ex) where - f = return . builder . toXML . toOpenMath pkg + f ctx = liftM (builder . toXML) $ + case changeT (return . markFocus) ctx >>= leaveT of + Just term | useFocus -> + return (toOMOBJ (term :: Term)) + _ -> + fromContext ctx >>= toOpenMath ex g xml = do xob <- findChild "OMOBJ" xml omobj <- liftEither (xml2omobj xob) - case fromOpenMath pkg omobj of + case fromOpenMath ex (if useFocus then transform noFocus omobj else omobj) of Just a -> return a - Nothing -> fail "Unknown OpenMath object" + Nothing -> fail "Invalid OpenMath object for this exercise" -xmlEncoder :: Bool -> (a -> DomainReasoner XMLBuilder) -> ExercisePackage a -> Encoder XMLBuilder a -xmlEncoder b f pkg = Encoder - { encodeType = xmlEncodeType b (xmlEncoder b f pkg) pkg - , encodeTerm = f - , encodeTuple = sequence_ + markFocus :: Term -> Term + markFocus = unary (newSymbol focusSymbol) + + noFocus :: OMOBJ -> OMOBJ + noFocus (OMA [OMS s, x]) | s == focusSymbol = x + noFocus a = a + + focusSymbol = makeSymbol "ideas" "focus" + useFocus = False + +xmlEncoder :: Bool -> (Context a -> DomainReasoner XMLBuilder) -> Exercise a -> Encoder XMLBuilder a +xmlEncoder isOM f ex = Encoder + { encodeType = xmlEncodeType isOM (xmlEncoder isOM f ex) ex + , encodeCtxTerm = f + , encodeTerm = f . inContext ex -- (not so nice) + , encodeTuple = sequence_ } -xmlEncodeType :: Bool -> Encoder XMLBuilder a -> ExercisePackage a -> Type a t -> t -> DomainReasoner XMLBuilder -xmlEncodeType b enc pkg serviceType = +xmlEncodeType :: Bool -> Encoder XMLBuilder a -> Exercise a -> Type a t -> t -> DomainReasoner XMLBuilder +xmlEncodeType b enc ex serviceType = case serviceType of - Tp.Tag s _ - | s == "Diagnosis" -> \a -> do - d <- isSynonym diagnosisTypeSynonym (a ::: serviceType) - encodeDiagnosis b (encodeTerm enc) d - | s == "DecompositionReply" -> \a -> do - reply <- isSynonym replyTypeSynonym (a ::: serviceType) - encodeReply (encodeState b (encodeTerm enc)) reply + Tp.Tag s t1 | s == "RulesInfo" -> \_ -> - rulesInfoXML (exercise pkg) (encodeTerm enc) - | s == "State" -> \a -> do - st <- isSynonym stateTypeSynonym (a ::: serviceType) - encodeState b (encodeTerm enc) st - Tp.List t1 -> \xs -> - case allAreTagged t1 of - Just f -> do - let make = element "elem" . mapM_ (uncurry (.=.)) . f - let elems = mapM_ make xs - return (element "list" elems) - _ -> do - bs <- mapM (xmlEncodeType b enc pkg t1) xs - let elems = mapM_ (element "elem") bs - return (element "list" elems) - Tp.Tag s t1 -> liftM (element s) . xmlEncodeType b enc pkg t1 -- quick fix - Tp.Strategy -> return . builder . strategyToXML - Tp.Rule -> return . ("ruleid" .=.) . showId - Tp.Term -> encodeTerm enc - Tp.Context -> encodeContext b (encodeTerm enc) - Tp.Location -> return . {-element "location" .-} text . show - Tp.Id -> return . text . show - Tp.Bool -> return . text . map toLower . show - Tp.String -> return . text - Tp.Int -> return . text . show - _ -> encodeDefault enc serviceType + rulesInfoXML ex (encodeTerm enc) + | otherwise -> + case useAttribute t1 of + Just f | s /= "message" -> return . (s .=.) . f + _ -> liftM (element s) . xmlEncodeType b enc ex t1 + Tp.Strategy -> return . builder . strategyToXML + Tp.Rule -> return . ("ruleid" .=.) . showId + Tp.Term -> encodeTerm enc + Tp.Context -> encodeContext b (encodeCtxTerm enc) + Tp.Location -> return . ("location" .=.) . show + Tp.ArgValueTp -> return . encodeArgValue b + Tp.Text -> encodeText enc ex + Tp.Bool -> return . text . map toLower . show + Tp.String -> return . text + _ -> encodeDefault enc serviceType -xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> ExercisePackage a -> Decoder XML a -xmlDecoder b f pkg = Decoder - { decodeType = xmlDecodeType b (xmlDecoder b f pkg) - , decodeTerm = f - , decoderPackage = pkg +xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> Exercise a -> Decoder XML a +xmlDecoder b f ex = Decoder + { decodeType = xmlDecodeType b (xmlDecoder b f ex) + , decodeTerm = f + , decoderExercise = ex } xmlDecodeType :: Bool -> Decoder XML a -> Type a t -> XML -> DomainReasoner (t, XML) -xmlDecodeType b dec serviceType = +xmlDecodeType b dec serviceType = case serviceType of - Tp.Context -> keep $ decodeContext b (decoderPackage dec) (decodeTerm dec) + Tp.Context -> keep $ decodeContext b (decoderExercise dec) (decodeTerm dec) Tp.Location -> keep $ liftM (read . getData) . findChild "location" Tp.Id -> keep $ \xml -> do a <- findChild "location" xml return (newId (getData a)) Tp.Rule -> keep $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . newId . getData) . findChild "ruleid" Tp.Term -> keep $ decodeTerm dec - Tp.StrategyCfg -> decodeConfiguration + Tp.StrategyCfg -> keep decodeConfiguration + Tp.Script -> keep $ \xml -> + case findAttribute "script" xml of + Just s -> readScript s + Nothing -> + defaultScript (getId (decoderExercise dec)) Tp.Tag s t - | s == "State" -> \xml -> do - g <- equalM stateTp serviceType - st <- decodeState b (decoderPackage dec) (decodeTerm dec) xml - return (g st, xml) - | s == "answer" -> \xml -> - findChild "answer" xml >>= xmlDecodeType b dec t + | s == "state" -> keep $ \xml -> do + g <- equalM stateType serviceType + st <- decodeState b (decoderExercise dec) (decodeTerm dec) xml + return (g st) + | s == "answer" -> keep $ \xml -> do + c <- findChild "answer" xml + (a, _) <- xmlDecodeType b dec t c + return a + | s == "difficulty" -> keep $ \xml -> do + g <- equalM difficultyType serviceType + a <- findAttribute "difficulty" xml + maybe (fail "unknown difficulty level") (return . g) (readDifficulty a) + {- s == "prefix" -> \xml -> do + f <- equalM String t + mp <- decodePrefix (decoderExercise dec) xml + s <- maybe (fail "no prefix") (return . show) mp + return (f s, xml) -} + | otherwise -> keep $ \xml -> + findChild s xml >>= liftM fst . xmlDecodeType b dec t + _ -> decodeDefault dec serviceType - where + where keep :: Monad m => (XML -> m a) -> XML -> m (a, XML) keep f xml = liftM (\a -> (a, xml)) (f xml) - -allAreTagged :: Type a t -> Maybe (t -> [(String, String)]) -allAreTagged (Iso _ f t) = fmap (. f) (allAreTagged t) -allAreTagged (Pair t1 t2) = do - f1 <- allAreTagged t1 - f2 <- allAreTagged t2 - return $ \(a,b) -> f1 a ++ f2 b -allAreTagged (Tag s Bool) = Just $ \b -> [(s, map toLower (show b))] -allAreTagged (Tag s String) = Just $ \a -> [(s, a)] -allAreTagged _ = Nothing - -decodeState :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (State a) -decodeState b pkg f xmlTop = do - xml <- findChild "state" xmlTop - unless (name xml == "state") (fail "expected a state tag") - mpr <- decodePrefix pkg xml - term <- decodeContext b pkg f xml - return (makeState pkg mpr term) -decodePrefix :: Monad m => ExercisePackage a -> XML -> m (Maybe (Prefix (Context a))) -decodePrefix pkg xml +useAttribute :: Type a t -> Maybe (t -> String) +useAttribute String = Just id +useAttribute Bool = Just (map toLower . show) +useAttribute _ = Nothing + +decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a) +decodeState b ex f xmlTop = do + xml <- findChild "state" xmlTop + mpr <- decodePrefix ex xml + term <- decodeContext b ex f xml + return (makeState ex mpr term) + +decodePrefix :: Monad m => Exercise a -> XML -> m (Maybe (Prefix (Context a))) +decodePrefix ex xml | all isSpace prefixText = return (Just (emptyPrefix str)) | prefixText ~= "no prefix" = - return Nothing + return Nothing | otherwise = do a <- readM prefixText pr <- makePrefix a str return (Just pr) where prefixText = maybe "" getData (findChild "prefix" xml) - str = strategy (exercise pkg) + str = strategy ex a ~= b = g a == g b g = map toLower . filter (not . isSpace) - -decodeContext :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (Context a) -decodeContext b pkg f xml = do + +decodeContext :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (Context a) +decodeContext b ex f xml = do expr <- f xml env <- decodeEnvironment b xml - return (makeContext (exercise pkg) env expr) + return (makeContext ex env expr) decodeEnvironment :: Monad m => Bool -> XML -> m Environment decodeEnvironment b xml = - case findChild "context" xml of + case findChild "context" xml of Just this -> foldM add emptyEnv (children this) Nothing -> return emptyEnv where - add env item = do - unless (name item == "item") $ + add env item = do + unless (name item == "item") $ fail $ "expecting item tag, found " ++ name item n <- findAttribute "name" item case findChild "OMOBJ" item of -- OpenMath object found inside item tag Just this | b -> - case xml2omobj this >>= omobjToTerm of + case xml2omobj this >>= fromOMOBJ of Left err -> fail err - Right term -> - return (storeEnv n term env) + Right term -> + return (storeEnv n (term :: Term) env) -- Simple value in attribute _ -> do value <- findAttribute "value" item return (storeEnv n value env) -decodeConfiguration :: MonadPlus m => XML -> m (StrategyConfiguration, XML) +decodeConfiguration :: MonadPlus m => XML -> m StrategyConfiguration decodeConfiguration xml = case findChild "configuration" xml of - Just this -> mapM decodeAction (children this) >>= \xs -> return (xs, xml) - Nothing -> fail "no strategy configuration" + Just this -> mapM decodeAction (children this) + Nothing -> fail "no strategy configuration" where - decodeAction item = do + decodeAction item = do guard (null (children item)) - action <- + action <- case find (\a -> map toLower (show a) == name item) configActions of Just a -> return a Nothing -> fail $ "unknown action " ++ show (name item) cfgloc <- findAttribute "name" item return (byName (newId cfgloc), action) -encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder -encodeState b f state = do - body <- f (stateTerm state) - return $ element "state" $ do - encodePrefix (statePrefix state) - let env = getEnvironment (stateContext state) - encodeEnvironment b (location (stateContext state)) env - body - -encodePrefix :: Maybe (Prefix a) -> XMLBuilder -encodePrefix = element "prefix" . text . maybe "no prefix" show - encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder encodeEnvironment b loc env0 | nullEnv env = return () | otherwise = element "context" $ forM_ (keysEnv env) $ \k -> - element "item" $ do + element "item" $ do "name" .=. k - case lookupEnv k env of - Just term | b -> builder (omobj2xml (termToOMOBJ term)) + case lookupEnv k env of + Just term | b -> builder (omobj2xml (toOMOBJ (term :: Term))) _ -> "value" .=. fromMaybe "" (lookupEnv k env) where env | null loc = env0 | otherwise = storeEnv "location" loc env0 -encodeDiagnosis :: Monad m => Bool -> (a -> m XMLBuilder) -> Diagnosis a -> m XMLBuilder -encodeDiagnosis mode f diagnosis = - case diagnosis of - Buggy r -> return $ element "buggy" $ "ruleid" .=. showId r - NotEquivalent -> return $ tag "notequiv" - Similar b s -> ok "similar" b s Nothing - Expected b s r -> ok "expected" b s (Just (showId r)) - Detour b s r -> ok "detour" b s (Just (showId r)) - Correct b s -> ok "correct" b s Nothing - where - ok t b s mr = do - body <- encodeState mode f s - return $ element t $ do - "ready" .=. map toLower (show b) - maybe (return ()) ("ruleid" .=.) mr - body - -encodeContext :: Monad m => Bool -> (a -> m XMLBuilder) -> Context a -> m XMLBuilder +encodeContext :: Monad m => Bool -> (Context a -> m XMLBuilder) -> Context a -> m XMLBuilder encodeContext b f ctx = do - a <- fromContext ctx - xml <- f a - return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx)) + xml <- f ctx + return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx)) + +encodeArgValue :: Bool -> ArgValue -> XMLBuilder +encodeArgValue b (ArgValue descr a) = element "argument" $ do + "description" .=. labelArgument descr + showValue a + where + showValue + | b = builder . omobj2xml . toOMOBJ . build (termViewArgument descr) + | otherwise = text . showArgument descr + +encodeText :: Encoder s a -> Exercise a -> Text -> DomainReasoner s +encodeText enc ex = liftM (encodeTuple enc) . mapM f . textItems + where + f (TextTerm a) = fromMaybe (encodeAsString enc a) $ do + v <- hasTermView ex + b <- match v a + return (encodeTerm enc b) + f a = encodeAsString enc a diff --git a/src/Service/OpenMathSupport.hs b/src/Service/OpenMathSupport.hs new file mode 100644 --- /dev/null +++ b/src/Service/OpenMathSupport.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.OpenMathSupport + ( -- * Conversion functions to/from OpenMath + toOpenMath, fromOpenMath + , toOMOBJ, fromOMOBJ + ) where + +import Common.Library +import Control.Monad +import Data.Char +import Data.List +import Text.OpenMath.Dictionary.Arith1 +import Text.OpenMath.Dictionary.Fns1 +import Text.OpenMath.Object +import qualified Text.OpenMath.Symbol as OM + +----------------------------------------------------------------------------- +-- Utility functions for conversion to/from OpenMath + +toOpenMath :: Monad m => Exercise a -> a -> m OMOBJ +toOpenMath ex a = do + v <- hasTermViewM ex + return (toOMOBJ (build v a)) + +fromOpenMath :: MonadPlus m => Exercise a -> OMOBJ -> m a +fromOpenMath ex omobj = do + v <- hasTermViewM ex + a <- fromOMOBJ omobj + matchM v a + +toOMOBJ :: IsTerm a => a -> OMOBJ +toOMOBJ = rec . toTerm + where + rec term = + case term of + TVar s -> OMV s + TCon s -> OMS (idToSymbol (getId s)) + TMeta i -> OMV ('$' : show i) + TNum n -> OMI n + TFloat d -> OMF d + TApp _ _ -> let (f, xs) = getSpine term + in make (map rec (f:xs)) + + make [OMS s, OMV x, body] | s == lambdaSymbol = + OMBIND (OMS s) [x] body + make [OMS s, a, b, c] | s == mfSymbol = -- special for mixed fraction symbol + OMA [OMS plusSymbol, a, OMA [OMS divideSymbol, b, c]] + make xs = OMA xs + +fromOMOBJ :: (MonadPlus m, IsTerm a) => OMOBJ -> m a +fromOMOBJ = (>>= fromTerm) . rec + where + rec omobj = + case omobj of + OMV x -> case isMeta x of + Just n -> return (TMeta n) + Nothing -> return (TVar x) + OMS s -> return (symbol (newSymbol (OM.dictionary s # OM.symbolName s))) + OMI n -> return (TNum n) + OMF a -> return (TFloat a) + OMA (x:xs) -> liftM2 makeTerm (rec x) (mapM rec xs) + OMBIND binder xs body -> + rec (OMA (binder:map OMV xs++[body])) + _ -> fail "Invalid OpenMath object" + + isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' + isMeta _ = Nothing + +idToSymbol :: Id -> OM.Symbol +idToSymbol a + | null (qualifiers a) = + OM.extraSymbol (unqualified a) + | otherwise = + OM.makeSymbol (qualification a) (unqualified a) + +hasTermViewM :: Monad m => Exercise a -> m (View Term a) +hasTermViewM = maybe (fail "No support for terms") return . hasTermView + +mfSymbol :: OM.Symbol +mfSymbol = OM.makeSymbol "extra" "mixedfraction" diff --git a/src/Service/ProblemDecomposition.hs b/src/Service/ProblemDecomposition.hs --- a/src/Service/ProblemDecomposition.hs +++ b/src/Service/ProblemDecomposition.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,67 +9,58 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Service.ProblemDecomposition - ( problemDecomposition - , replyType, replyTypeSynonym, encodeReply +module Service.ProblemDecomposition + ( problemDecomposition, replyType ) where import Common.Library import Common.Utils -import Control.Monad import Data.Maybe -import Service.ExercisePackage import Service.State import Service.Types -import Text.XML hiding (name) -problemDecomposition :: Monad m => Maybe Id -> State a -> Maybe a -> m (Reply a) -problemDecomposition msloc state answer +problemDecomposition :: Maybe Id -> State a -> Maybe a -> Either String (Reply a) +problemDecomposition msloc state answer | isNothing $ subStrategy sloc (strategy ex) = - fail "request error: invalid location for strategy" + Left "request error: invalid location for strategy" | otherwise = let pr = fromMaybe (emptyPrefix $ strategy ex) (statePrefix state) in - case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of - ([], _) -> fail "strategy error: not able to compute an expected answer" + case (runPrefixLocation sloc pr requestedTerm, fmap (inContext ex) answer) of + ([], _) -> Left "strategy error: not able to compute an expected answer" (answers, Just answeredTerm) - | not (null witnesses) -> return $ + | not (null witnesses) -> Right $ Ok newLocation newState - where - witnesses = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers + where + witnesses = filter (similarity ex answeredTerm . fst) $ take 1 answers (newCtx, newPrefix) = head witnesses - newLocation = nextTaskLocation (strategy ex) sloc $ + newLocation = nextTaskLocation (strategy ex) sloc $ fromMaybe topId $ nextMajorForPrefix newPrefix newCtx - newState = makeState pkg (Just newPrefix) newCtx - ((expected, pref):_, maybeAnswer) -> return $ + newState = makeState ex (Just newPrefix) newCtx + ((expected, pref):_, maybeAnswer) -> Right $ Incorrect isEquiv newLocation expState arguments where newLocation = subTaskLocation (strategy ex) sloc loc - expState = makeState pkg (Just pref) expected - isEquiv = maybe False (equivalenceContext ex expected) maybeAnswer - (loc, arguments) = fromMaybe (topId, []) $ + expState = makeState ex (Just pref) expected + isEquiv = maybe False (equivalence ex expected) maybeAnswer + (loc, arguments) = fromMaybe (topId, []) $ firstMajorInPrefix pr pref requestedTerm where - pkg = exercisePkg state - ex = exercise pkg + ex = exercise state topId = getId (strategy ex) sloc = fromMaybe topId msloc requestedTerm = stateContext state - -similarityCtx :: Exercise a -> Context a -> Context a -> Bool -similarityCtx ex a b = fromMaybe False $ - liftM2 (similarity ex) (fromContext a) (fromContext b) -- | Continue with a prefix until a certain strategy location is reached. At least one -- major rule should have been executed runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)] runPrefixLocation loc p0 = - concatMap (checkPair . f) . derivations . + concatMap (checkPair . f) . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0 where - f d = (last (terms d), if isEmpty d then p0 else last (steps d)) + f d = (lastTerm d, fromMaybe p0 (lastStep d)) stop (Just (Exit info)) = getId info == loc stop _ = False - + checkPair result@(a, p) | null rules = [result] | all isMinorRule rules = runPrefixLocation loc p a @@ -77,7 +68,7 @@ where rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p -firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, Args) +firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, ArgValues) firstMajorInPrefix p0 p a = do let newSteps = drop (length $ prefixToSteps p0) (prefixToSteps p) is <- firstLocation newSteps @@ -87,17 +78,16 @@ firstLocation [] = Nothing firstLocation (Enter info:RuleStep r:_) | isMajorRule r = Just (getId info) firstLocation (_:rest) = firstLocation rest - -argumentsForSteps :: a -> [Step l a] -> Args + +argumentsForSteps :: a -> [Step l a] -> ArgValues argumentsForSteps a0 = flip rec a0 . stepsToRules where rec [] _ = [] rec (r:rs) a | isMinorRule r = concatMap (rec rs) (applyAll r a) - | applicable r a = let ds = map (\(Some d) -> labelArgument d) (getDescriptors r) - in maybe [] (zip ds) (expectedArguments r a) + | applicable r a = fromMaybe [] (expectedArguments r a) | otherwise = [] - + nextMajorForPrefix :: Prefix a -> a -> Maybe Id nextMajorForPrefix p0 a = do (_, p1) <- safeHead $ runPrefixMajor p0 a @@ -107,62 +97,36 @@ rec (Enter info:_) = Just (getId info) rec (Exit info:_) = Just (getId info) rec (_:rest) = rec rest - + -- Copied from TypedAbstractService: clean me up runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)] -runPrefixMajor p0 = +runPrefixMajor p0 = map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0 where - f d = (last (terms d), if isEmpty d then p0 else last (steps d)) + f d = (lastTerm d, fromMaybe p0 (lastStep d)) stop (Just (RuleStep r)) = isMajorRule r stop _ = False - + ------------------------------------------------------------------------ -- Data types for replies data Reply a = Ok Id (State a) - | Incorrect Bool Id (State a) Args - -type Args = [(String, String)] + | Incorrect Bool Id (State a) ArgValues ------------------------------------------------------------------------ --- Conversion functions to XML - -encodeReply :: Monad m => (State a -> m XMLBuilder) -> Reply a -> m XMLBuilder -encodeReply showState reply = - case reply of - Ok loc state -> do - stateXML <- showState state - return $ - element "correct" $ do - element "location" (text $ show loc) - stateXML - Incorrect b loc state args -> do - stateXML <- showState state - return $ - element "incorrect" $ do - "equivalent" .=. show b - element "location" (text $ show loc) - stateXML - let f (x, y) = element "elem" $ do - "descr" .=. x - text y - unless (null args) $ - element "arguments" $ mapM_ f args +-- Type definition replyType :: Type a (Reply a) -replyType = useSynonym replyTypeSynonym - -replyTypeSynonym :: TypeSynonym a (Reply a) -replyTypeSynonym = typeSynonym "DecompositionReply" to from tp +replyType = Iso (f <-> g) tp where - to (Left (a, b)) = Ok a b - to (Right (a, b, c, d)) = Incorrect a b c d - - from (Ok a b) = Left (a, b) - from (Incorrect a b c d) = Right (a, b, c, d) - - tp = tuple2 Id stateTp - :|: tuple4 Bool Id stateTp argsTp + f (Left (a, b)) = Ok a b + f (Right (a, b, c, d)) = Incorrect a b c d - argsTp = List (Pair String String) + g (Ok a b) = Left (a, b) + g (Incorrect a b c d) = Right (a, b, c, d) + + tp = Tag "correct" (tuple2 locType stateType) + :|: Tag "incorrect" (tuple4 (Tag "equivalent" Bool) locType stateType argsType) + + locType = Tag "location" Id + argsType = List ArgValueTp diff --git a/src/Service/Request.hs b/src/Service/Request.hs --- a/src/Service/Request.hs +++ b/src/Service/Request.hs @@ -1,44 +1,43 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.Request where - -import Common.Library hiding (exerciseId) -import Data.Char - -data Request = Request - { service :: String - , exerciseId :: Maybe Id - , source :: Maybe String - , dataformat :: DataFormat - , encoding :: Maybe Encoding - } - deriving Show - -data DataFormat = XML | JSON - deriving Show - -data Encoding = OpenMath | StringEncoding - deriving Show - -discoverDataFormat :: Monad m => String -> m DataFormat -discoverDataFormat xs = - case dropWhile isSpace xs of - '<':_ -> return XML - '{':_ -> return JSON - _ -> fail "Unknown data format" - -readEncoding :: Monad m => String -> m Encoding -readEncoding xs = - case map toLower xs of - "openmath" -> return OpenMath - "string" -> return StringEncoding +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.Request where + +import Common.Library hiding (exerciseId) +import Data.Char + +data Request = Request + { service :: String + , exerciseId :: Maybe Id + , source :: Maybe String + , dataformat :: DataFormat + , encoding :: Maybe Encoding + } + +data DataFormat = XML | JSON + deriving Show -- needed for LoggingDatabase + +data Encoding = OpenMath | StringEncoding + deriving Show -- needed for LoggingDatabase + +discoverDataFormat :: Monad m => String -> m DataFormat +discoverDataFormat xs = + case dropWhile isSpace xs of + '<':_ -> return XML + '{':_ -> return JSON + _ -> fail "Unknown data format" + +readEncoding :: Monad m => String -> m Encoding +readEncoding xs = + case map toLower xs of + "openmath" -> return OpenMath + "string" -> return StringEncoding _ -> fail $ "Invalid encoding: " ++ xs diff --git a/src/Service/RulesInfo.hs b/src/Service/RulesInfo.hs --- a/src/Service/RulesInfo.hs +++ b/src/Service/RulesInfo.hs @@ -1,83 +1,81 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.RulesInfo - ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap, rulesInfoType - ) where - -import Common.Library -import Common.Utils (Some(..)) -import Data.Char -import Control.Monad -import Text.OpenMath.Object -import Text.OpenMath.FMP -import Text.XML hiding (name) -import Service.ExercisePackage (termToOMOBJ) -import Service.Types -import qualified Data.Map as M - -rulesInfoXML :: Monad m => Exercise a -> (a -> m XMLBuilder) -> m XMLBuilder -rulesInfoXML ex enc = combine $ forM (ruleset ex) $ \r -> do - - let pairs = M.findWithDefault [] (getId r) exampleMap - xs <- forM (take 3 pairs) $ \(a, b) -> - liftM2 (,) (enc a) (enc b) - - return $ element "rule" $ do - "name" .=. showId r - "buggy" .=. f (isBuggyRule r) - "rewriterule" .=. f (isRewriteRule r) - -- More information - let descr = description r - -- to do: rules should carry descriptions - txt = if null descr then showId r else descr - unless (null txt) $ - element "description" $ text txt - forM_ (ruleGroups r) $ \s -> - element "group" $ text (showId s) - forM_ (ruleSiblings r) $ \s -> - element "sibling" $ text $ showId s - -- FMPs and CMPs - forM_ (getRewriteRules r) $ \(Some rr, b) -> do - let fmp = rewriteRuleToFMP b rr - case showRewriteRule b rr of - Nothing -> return () - Just s -> element "CMP" (text s) - element "FMP" $ - builder (omobj2xml (toObject fmp)) - -- Examples - forM_ xs $ \(a, b) -> - element "example" (a >> b) - where - f = map toLower . show - exampleMap = collectExamples ex - combine = liftM sequence_ - -rewriteRuleToFMP :: Bool -> RewriteRule a -> FMP -rewriteRuleToFMP sound r - | sound = eqFMP a b - | otherwise = buggyFMP a b - where - a :~> b = fmap termToOMOBJ (ruleSpecTerm r) - -type ExampleMap a = M.Map Id [(a, a)] - -collectExamples :: Exercise a -> ExampleMap a -collectExamples ex = foldr add M.empty (examples ex) - where - add a m = let tree = derivationTree (strategy ex) (inContext ex a) - f Nothing = m - f (Just d) = foldr g m (zip3 (terms d) (steps d) (drop 1 (terms d))) - g (x, r, y) = M.insertWith (++) (getId r) (liftM2 (,) (fromContext x) (fromContext y)) - in f (derivation tree) - -rulesInfoType :: Type a () -rulesInfoType = useSynonym (typeSynonym "RulesInfo" id id Unit) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.RulesInfo + ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap, rulesInfoType + ) where + +import Common.Library +import Common.Utils (Some(..)) +import Control.Monad +import Data.Char +import Service.OpenMathSupport (toOMOBJ) +import Service.Types +import Text.OpenMath.FMP +import Text.OpenMath.Object +import Text.XML hiding (name) +import qualified Data.Map as M + +rulesInfoXML :: Monad m => Exercise a -> (a -> m XMLBuilder) -> m XMLBuilder +rulesInfoXML ex enc = combine $ forM (ruleset ex) $ \r -> do + + let pairs = M.findWithDefault [] (getId r) exampleMap + xs <- forM (take 3 pairs) $ \(a, b) -> + liftM2 (,) (enc a) (enc b) + + return $ element "rule" $ do + "name" .=. showId r + "buggy" .=. f (isBuggyRule r) + "rewriterule" .=. f (isRewriteRule r) + -- More information + let descr = description r + -- to do: rules should carry descriptions + txt = if null descr then showId r else descr + unless (null txt) $ + element "description" $ text txt + forM_ (ruleSiblings r) $ \s -> + element "sibling" $ text $ showId s + -- FMPs and CMPs + forM_ (getRewriteRules r) $ \(Some rr, b) -> do + let fmp = rewriteRuleToFMP b rr + case showRewriteRule b rr of + Nothing -> return () + Just s -> element "CMP" (text s) + element "FMP" $ + builder (omobj2xml (toObject fmp)) + -- Examples + forM_ xs $ \(a, b) -> + element "example" (a >> b) + where + f = map toLower . show + exampleMap = collectExamples ex + combine = liftM sequence_ + +rewriteRuleToFMP :: Bool -> RewriteRule a -> FMP +rewriteRuleToFMP sound r + | sound = eqFMP a b + | otherwise = buggyFMP a b + where + a :~> b = fmap toOMOBJ (ruleSpecTerm r) + +type ExampleMap a = M.Map Id [(a, a)] + +collectExamples :: Exercise a -> ExampleMap a +collectExamples ex = foldr (add . snd) M.empty (examples ex) + where + add a m = let tree = derivationTree (strategy ex) (inContext ex a) + f Nothing = m + f (Just d) = foldr g m (triples d) + g (x, r, y) = M.insertWith (++) (getId r) (liftM2 (,) (fromContext x) (fromContext y)) + in f (derivation tree) + +rulesInfoType :: Type a () +rulesInfoType = Tag "RulesInfo" Unit diff --git a/src/Service/ServiceList.hs b/src/Service/ServiceList.hs --- a/src/Service/ServiceList.hs +++ b/src/Service/ServiceList.hs @@ -1,227 +1,237 @@ -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.ServiceList (serviceList, exerciselistS) where - -import Common.Library hiding (apply, applicable, derivation) -import Common.Utils (Some(..)) -import Data.List (sortBy) -import Data.Ord -import Service.FeedbackText -import Service.ProblemDecomposition (problemDecomposition, replyType) -import Service.ExercisePackage -import Service.Types -import Service.RulesInfo -import Service.State -import Service.BasicServices -import qualified Service.Diagnose as Diagnose -import qualified Service.Submit as Submit - ------------------------------------------------------- --- Querying a service - -serviceList :: [Service] -serviceList = - [ derivationS, allfirstsS, onefirstS, readyS - , stepsremainingS, applicableS, allapplicationsS - , applyS, generateS - , examplesS, submitS, diagnoseS - , onefirsttextS, findbuggyrulesS - , submittextS, derivationtextS - , problemdecompositionS - , rulelistS, rulesinfoS, strategyinfoS - ] - ------------------------------------------------------- --- Basic services - -derivationS :: Service -derivationS = makeService "derivation" - "Returns one possible derivation (or: worked-out example) starting with the \ - \current expression. The first optional argument lets you configure the \ - \strategy, i.e., make some minor modifications to it. Rules used and \ - \intermediate expressions are returned in a list." $ - derivation ::: maybeTp StrategyCfg :-> stateTp :-> errorTp (List (tuple2 Rule Context)) - -allfirstsS :: Service -allfirstsS = makeService "allfirsts" - "Returns all next steps that are suggested by the strategy. See the \ - \onefirst service to get only one suggestion. For each suggestion, a new \ - \state, the rule used, and the location where the rule was applied are \ - \returned." $ - allfirsts ::: stateTp :-> errorTp (List (tuple3 Rule Location stateTp)) - -onefirstS :: Service -onefirstS = makeService "onefirst" - "Returns a possible next step according to the strategy. Use the allfirsts \ - \service to get all possible steps that are allowed by the strategy. In \ - \addition to a new state, the rule used and the location where to apply \ - \this rule are returned." $ - onefirst ::: stateTp :-> elemTp (errorTp (tuple3 Rule Location stateTp)) - -readyS :: Service -readyS = makeService "ready" - "Test if the current expression is in a form accepted as a final answer. \ - \For this, the strategy is not used." $ - ready ::: stateTp :-> Bool - -stepsremainingS :: Service -stepsremainingS = makeService "stepsremaining" - "Computes how many steps are remaining to be done, according to the \ - \strategy. For this, only the first derivation is considered, which \ - \corresponds to the one returned by the derivation service." $ - stepsremaining ::: stateTp :-> errorTp Int - -applicableS :: Service -applicableS = makeService "applicable" - "Given a current expression and a location in this expression, this service \ - \yields all rules that can be applied at this location, regardless of the \ - \strategy." $ - applicable ::: Location :-> stateTp :-> List Rule - -allapplicationsS :: Service -allapplicationsS = makeService "allapplications" - "Given a current expression, this service yields all rules that can be \ - \applied at a certain location, regardless wether the rule used is buggy \ - \or not. Some results are within the strategys, others are not." $ - allapplications ::: stateTp :-> List (tuple3 Rule Location stateTp) - -applyS :: Service -applyS = makeService "apply" - "Apply a rule at a certain location to the current expression. If this rule \ - \was not expected by the strategy, we deviate from it. If the rule cannot \ - \be applied, this service call results in an error." $ - apply ::: Rule :-> Location :-> stateTp :-> errorTp stateTp - -generateS :: Service -generateS = makeService "generate" - "Given an exercise code and a difficulty level (optional), this service \ - \returns an initial state with a freshly generated expression. The meaning \ - \of the difficulty level (an integer) depends on the exercise at hand." $ - generate ::: ExercisePkg :-> optionTp 5 Int :-> IO stateTp - -examplesS :: Service -examplesS = makeService "examples" - "This services returns a list of example expresssions that can be solved \ - \with an exercise. These are the examples that appear at the page generated \ - \for each exercise. Also see the generate service, which returns a random \ - \start term." $ - (examples . exercise) ::: ExercisePkg :-> List Term - -findbuggyrulesS :: Service -findbuggyrulesS = makeService "findbuggyrules" - "Search for common misconceptions (buggy rules) in an expression (compared \ - \to the current state). It is assumed that the expression is indeed not \ - \correct. This service has been superseded by the diagnose service." $ - findbuggyrules ::: stateTp :-> Term :-> List Rule - -submitS :: Service -submitS = deprecate $ makeService "submit" - "Analyze an expression submitted by a student. Possible answers are Buggy, \ - \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \ - \by the diagnose service." $ - Submit.submit ::: stateTp :-> Term :-> Submit.submitType - -diagnoseS :: Service -diagnoseS = makeService "diagnose" - "Diagnose an expression submitted by a student. Possible diagnosis are \ - \Buggy (a common misconception was detected), NotEquivalent (something is \ - \wrong, but we don't know what), Similar (the expression is pretty similar \ - \to the last expression in the derivation), Expected (the submitted \ - \expression was anticipated by the strategy), Detour (the submitted \ - \expression was not expected by the strategy, but the applied rule was \ - \detected), and Correct (it is correct, but we don't know which rule was \ - \applied)." $ - Diagnose.diagnose ::: stateTp :-> Term :-> Diagnose.diagnosisType - ------------------------------------------------------- --- Services with a feedback component - -onefirsttextS :: Service -onefirsttextS = makeService "onefirsttext" - "Similar to the onefirst service, except that the result is now returned as \ - \a formatted text message. The optional string is for announcing the event \ - \leading to this service call (which can influence the returned result). \ - \The boolean in the result specifies whether a suggestion was available or \ - \not." $ - onefirsttext ::: stateTp :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp)) - -submittextS :: Service -submittextS = makeService "submittext" - "Similar to the submit service, except that the result is now returned as \ - \a formatted text message. The expression 'submitted' by the student is sent \ - \in plain text (and parsed by the exercise's parser). The optional string is \ - \for announcing the event leading to this service call. The boolean in the \ - \result specifies whether the submitted term is accepted and incorporated \ - \in the new state." $ - submittext ::: stateTp :-> String :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp)) - -derivationtextS :: Service -derivationtextS = makeService "derivationtext" - "Similar to the derivation service, but the rules appearing in the derivation \ - \have been replaced by a short description of the rule. The optional string is \ - \for announcing the event leading to this service call." $ - derivationtext ::: stateTp :-> maybeTp String :-> errorTp (List (tuple2 String Context)) - ------------------------------------------------------- --- Problem decomposition service - - -problemdecompositionS :: Service -problemdecompositionS = makeService "problemdecomposition" - "Strategy service developed for the SURF project Intelligent Feedback for a \ - \binding with the MathDox system on linear algebra exercises. This is a \ - \composite service, and available for backwards compatibility." $ - problemDecomposition ::: maybeTp Id :-> stateTp :-> maybeTp (Tag "answer" Term) :-> errorTp replyType - ------------------------------------------------------- --- Reflective services - -exerciselistS :: [Some ExercisePackage] -> Service -exerciselistS list = makeService "exerciselist" - "Returns all exercises known to the system. For each exercise, its domain, \ - \identifier, a short description, and its current status are returned." $ - allExercises list ::: List (tuple3 (Tag "exerciseid" String) (Tag "description" String) (Tag "status" String)) - -rulelistS :: Service -rulelistS = makeService "rulelist" - "Returns all rules of a particular exercise. For each rule, we return its \ - \name (or identifier), whether the rule is buggy, and whether the rule was \ - \expressed as an observable rewrite rule. See rulesinfo for more details \ - \about the rules." $ - allRules ::: ExercisePkg :-> List (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) - -rulesinfoS :: Service -rulesinfoS = makeService "rulesinfo" - "Returns a list of all rules of a particular exercise, with many details \ - \including Formal Mathematical Properties (FMPs) and example applications." $ - () ::: rulesInfoType - -strategyinfoS :: Service -strategyinfoS = makeService "strategyinfo" - "Returns the representation of the strategy of a particular exercise." $ - (toStrategy . strategy . exercise) ::: ExercisePkg :-> Strategy - -allExercises :: [Some ExercisePackage] -> [(String, String, String)] -allExercises = map make . sortBy (comparing f) - where - f (Some pkg) = showId (exercise pkg) - make (Some pkg) = - (showId pkg, description pkg, show (status (exercise pkg))) - -allRules :: ExercisePackage a -> [(String, Bool, Bool)] -allRules = map make . ruleset . exercise - where +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.ServiceList (serviceList, exerciselistS) where + +import Common.Library hiding (apply, applicable, derivation, ready) +import Common.Utils (Some(..)) +import Data.List (sortBy) +import Data.Ord +import Service.BasicServices +import Service.FeedbackScript.Syntax +import Service.FeedbackText +import Service.ProblemDecomposition (problemDecomposition, replyType) +import Service.RulesInfo +import Service.State +import Service.Types +import qualified Service.Diagnose as Diagnose +import qualified Service.Submit as Submit + +------------------------------------------------------ +-- Querying a service + +serviceList :: [Service] +serviceList = + [ derivationS, allfirstsS, onefirstS, readyS + , stepsremainingS, applicableS, allapplicationsS + , applyS, generateS + , examplesS, submitS, diagnoseS + , onefirsttextS, findbuggyrulesS + , submittextS, derivationtextS + , feedbacktextS + , problemdecompositionS + , rulelistS, rulesinfoS, strategyinfoS + ] + +------------------------------------------------------ +-- Basic services + +derivationS :: Service +derivationS = makeService "derivation" + "Returns one possible derivation (or: worked-out example) starting with the \ + \current expression. The first optional argument lets you configure the \ + \strategy, i.e., make some minor modifications to it. Rules used and \ + \intermediate expressions are returned in a list." $ + -- derivationTemp ::: maybeType StrategyCfg :-> stateType :-> errorType (derivationType Rule Context) + derivation ::: maybeType StrategyCfg :-> stateType :-> errorType (derivationType (tuple2 Rule (List ArgValueTp)) Context) + +allfirstsS :: Service +allfirstsS = makeService "allfirsts" + "Returns all next steps that are suggested by the strategy. See the \ + \onefirst service to get only one suggestion. For each suggestion, a new \ + \state, the rule used, and the location where the rule was applied are \ + \returned." $ + allfirsts ::: stateType :-> errorType (listType (tuple4 Rule Location (List ArgValueTp) stateType)) + +onefirstS :: Service +onefirstS = makeService "onefirst" + "Returns a possible next step according to the strategy. Use the allfirsts \ + \service to get all possible steps that are allowed by the strategy. In \ + \addition to a new state, the rule used and the location where to apply \ + \this rule are returned." $ + onefirst ::: stateType :-> elemType (errorType (tuple4 Rule Location (List ArgValueTp) stateType)) + +readyS :: Service +readyS = makeService "ready" + "Test if the current expression is in a form accepted as a final answer. \ + \For this, the strategy is not used." $ + ready ::: stateType :-> Bool + +stepsremainingS :: Service +stepsremainingS = makeService "stepsremaining" + "Computes how many steps are remaining to be done, according to the \ + \strategy. For this, only the first derivation is considered, which \ + \corresponds to the one returned by the derivation service." $ + stepsremaining ::: stateType :-> errorType Int + +applicableS :: Service +applicableS = makeService "applicable" + "Given a current expression and a location in this expression, this service \ + \yields all rules that can be applied at this location, regardless of the \ + \strategy." $ + applicable ::: Location :-> stateType :-> listType Rule + +allapplicationsS :: Service +allapplicationsS = makeService "allapplications" + "Given a current expression, this service yields all rules that can be \ + \applied at a certain location, regardless wether the rule used is buggy \ + \or not. Some results are within the strategy, others are not." $ + allapplications ::: stateType :-> listType (tuple3 Rule Location stateType) + +applyS :: Service +applyS = makeService "apply" + "Apply a rule at a certain location to the current expression. If this rule \ + \was not expected by the strategy, we deviate from it. If the rule cannot \ + \be applied, this service call results in an error." $ + apply ::: Rule :-> Location :-> stateType :-> errorType stateType + +generateS :: Service +generateS = makeService "generate" + "Given an exercise code and a difficulty level (optional), this service \ + \returns an initial state with a freshly generated expression." $ + generate ::: StdGen :-> Exercise :-> optionType Medium difficultyType :-> stateType + +examplesS :: Service +examplesS = makeService "examples" + "This services returns a list of example expresssions that can be solved \ + \with an exercise. These are the examples that appear at the page generated \ + \for each exercise. Also see the generate service, which returns a random \ + \start term." $ + (map snd . examples) ::: Exercise :-> listType Term + +findbuggyrulesS :: Service +findbuggyrulesS = makeService "findbuggyrules" + "Search for common misconceptions (buggy rules) in an expression (compared \ + \to the current state). It is assumed that the expression is indeed not \ + \correct. This service has been superseded by the diagnose service." $ + findbuggyrules ::: stateType :-> Term :-> listType (tuple3 Rule Location (List ArgValueTp)) + +submitS :: Service +submitS = deprecate $ makeService "submit" + "Analyze an expression submitted by a student. Possible answers are Buggy, \ + \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \ + \by the diagnose service." $ + Submit.submit ::: stateType :-> Term :-> Submit.submitType + +diagnoseS :: Service +diagnoseS = makeService "diagnose" + "Diagnose an expression submitted by a student. Possible diagnosis are \ + \Buggy (a common misconception was detected), NotEquivalent (something is \ + \wrong, but we don't know what), Similar (the expression is pretty similar \ + \to the last expression in the derivation), Expected (the submitted \ + \expression was anticipated by the strategy), Detour (the submitted \ + \expression was not expected by the strategy, but the applied rule was \ + \detected), and Correct (it is correct, but we don't know which rule was \ + \applied)." $ + Diagnose.diagnose ::: stateType :-> Term :-> Diagnose.diagnosisType + +------------------------------------------------------ +-- Services with a feedback component + +onefirsttextS :: Service +onefirsttextS = makeService "onefirsttext" + "Similar to the onefirst service, except that the result is now returned as \ + \a formatted text message. The optional string is for announcing the event \ + \leading to this service call (which can influence the returned result)." $ + onefirsttext ::: Script :-> stateType :-> maybeType String + :-> tuple2 (messageType Text) (maybeType stateType) + +derivationtextS :: Service +derivationtextS = makeService "derivationtext" + "Similar to the derivation service, but the rules appearing in the derivation \ + \have been replaced by a short description of the rule." $ + derivationtext ::: Script :-> stateType :-> errorType (derivationType (Tag "ruletext" String) Context) + +submittextS :: Service +submittextS = deprecate $ makeService "submittext" + "Similar to the submit service, except that the result is now returned as \ + \a formatted text message. The expression 'submitted' by the student is sent \ + \in plain text (and parsed by the exercise's parser). \ + \The boolean in the \ + \result specifies whether the submitted term is accepted and incorporated \ + \in the new state." $ + submittext ::: Script :-> stateType :-> String :-> messageAndState + +feedbacktextS :: Service +feedbacktextS = makeService "feedbacktext" + "Textual feedback for diagnose service. Experimental." $ + feedbacktext ::: Script :-> stateType :-> Term :-> messageAndState + +-- Helper type for submittext and feedbacktext: reorders elements, and inserts +-- some extra tags +messageAndState :: Type a (Bool, Text, State a) +messageAndState = Iso (f <-> g) tp + where + f ((a, b), c) = (a, b, c) + g (a, b, c) = ((a, b), c) + tp = tuple2 (messageType (tuple2 (Tag "accept" Bool) Text)) stateType + +------------------------------------------------------ +-- Problem decomposition service + +problemdecompositionS :: Service +problemdecompositionS = makeService "problemdecomposition" + "Strategy service developed for the SURF project Intelligent Feedback for a \ + \binding with the MathDox system on linear algebra exercises. This is a \ + \composite service, and available for backwards compatibility." $ + problemDecomposition ::: maybeType Id :-> stateType :-> maybeType (Tag "answer" Term) :-> errorType replyType + +------------------------------------------------------ +-- Reflective services + +exerciselistS :: [Some Exercise] -> Service +exerciselistS list = makeService "exerciselist" + "Returns all exercises known to the system. For each exercise, its domain, \ + \identifier, a short description, and its current status are returned." $ + allExercises list ::: listType (tuple3 (Tag "exerciseid" String) (Tag "description" String) (Tag "status" String)) + +rulelistS :: Service +rulelistS = makeService "rulelist" + "Returns all rules of a particular exercise. For each rule, we return its \ + \name (or identifier), whether the rule is buggy, and whether the rule was \ + \expressed as an observable rewrite rule. See rulesinfo for more details \ + \about the rules." $ + allRules ::: Exercise :-> listType (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) + +rulesinfoS :: Service +rulesinfoS = makeService "rulesinfo" + "Returns a list of all rules of a particular exercise, with many details \ + \including Formal Mathematical Properties (FMPs) and example applications." $ + () ::: rulesInfoType + +strategyinfoS :: Service +strategyinfoS = makeService "strategyinfo" + "Returns the representation of the strategy of a particular exercise." $ + (toStrategy . strategy) ::: Exercise :-> Strategy + +allExercises :: [Some Exercise] -> [(String, String, String)] +allExercises = map make . sortBy (comparing f) + where + f :: Some Exercise -> String + f (Some ex) = showId ex + make (Some ex) = + (showId ex, description ex, show (status ex)) + +allRules :: Exercise a -> [(String, Bool, Bool)] +allRules = map make . ruleset + where make r = (showId r, isBuggyRule r, isRewriteRule r) - -elemTp :: Type a t -> Type a t -elemTp = Tag "elem" diff --git a/src/Service/State.hs b/src/Service/State.hs --- a/src/Service/State.hs +++ b/src/Service/State.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -12,61 +12,69 @@ -- derivation. -- ----------------------------------------------------------------------------- -module Service.State +module Service.State ( -- * Exercise state - State, makeState, empyStateContext, emptyState - , exercisePkg, statePrefix, stateContext, stateTerm + State, makeState, empyStateContext, emptyState + , exercise, statePrefix, stateContext, stateTerm -- * Types - , stateTp, stateTypeSynonym + , stateType ) where import Common.Library import Common.Utils (readM) -import Service.Types import Data.Maybe -import Service.ExercisePackage +import Service.Types -data State a = State - { exercisePkg :: ExercisePackage a +data State a = State + { exercise :: Exercise a , statePrefix :: Maybe (Prefix (Context a)) , stateContext :: Context a } +instance Show (State a) where + show s = unlines $ "State {" : map (" "++) xs ++ ["}"] + where + xs = [ "exercise = " ++ showId s + , "prefix = " ++ maybe "no prefix" show (statePrefix s) + , "steps = " ++ maybe "no prefix" (show . prefixToSteps) (statePrefix s) + , "term = " ++ prettyPrinterContext (exercise s) (stateContext s) + ] + +instance HasId (State a) where + getId = getId . exercise + changeId f s = s { exercise = changeId f (exercise s) } + stateTerm :: State a -> a stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext ----------------------------------------------------------- -makeState :: ExercisePackage a -> Maybe (Prefix (Context a)) -> Context a -> State a +makeState :: Exercise a -> Maybe (Prefix (Context a)) -> Context a -> State a makeState = State -empyStateContext :: ExercisePackage a -> Context a -> State a -empyStateContext pkg = makeState pkg (Just pr) +empyStateContext :: Exercise a -> Context a -> State a +empyStateContext ex = makeState ex (Just pr) where - ex = exercise pkg pr = emptyPrefix (strategy ex) -emptyState :: ExercisePackage a -> a -> State a -emptyState pkg = empyStateContext pkg . inContext (exercise pkg) +emptyState :: Exercise a -> a -> State a +emptyState ex = empyStateContext ex . inContext ex -------------------------------------------------------------- -stateTp :: Type a (State a) -stateTp = useSynonym stateTypeSynonym - -stateTypeSynonym :: TypeSynonym a (State a) -stateTypeSynonym = typeSynonym "State" to from tp +stateType :: Type a (State a) +stateType = Tag "state" (Iso (f <-> g) tp) where - to (pkg, mp, ctx) = - let str = strategy (exercise pkg) - f = fromMaybe [] . readM - in makeState pkg (mp >>= flip makePrefix str . f) ctx - from st = - ( exercisePkg st + f (ex, mp, ctx) = + let str = strategy ex + h = fromMaybe [] . readM + in makeState ex (mp >>= flip makePrefix str . h) ctx + g st = + ( exercise st , fmap show (statePrefix st) , stateContext st ) - tp = tuple3 ExercisePkg prefixTp Context + tp = tuple3 Exercise prefixType Context -prefixTp :: Type a (Maybe String) -prefixTp = Tag "Prefix" (maybeTp String) + -- iso prevents that prefix is turned into an (XML) attribute + prefixType = maybeType (Tag "prefix" (Iso identity String)) diff --git a/src/Service/StrategyInfo.hs b/src/Service/StrategyInfo.hs --- a/src/Service/StrategyInfo.hs +++ b/src/Service/StrategyInfo.hs @@ -1,165 +1,177 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Converting a strategy to XML, and the other way around. --- ------------------------------------------------------------------------------ -module Service.StrategyInfo (strategyToXML, xmlToStrategy) where - -import Data.Char -import Data.Maybe -import Control.Monad -import Common.Library -import Common.Strategy.Core (Core(..), noLabels) -import Common.Strategy.Abstract -import Text.XML -import Common.Utils (readInt) - ------------------------------------------------------------------------ --- Strategy to XML - -strategyToXML :: IsStrategy f => f a -> XML -strategyToXML = coreToXML . toCore . toStrategy - -infoToXML :: LabelInfo -> XMLBuilder -infoToXML info = do - "name" .=. showId info - when (removed info) ("removed" .=. "true") - when (collapsed info) ("collapsed" .=. "true") - when (hidden info) ("hidden" .=. "true") - -coreToXML :: Core LabelInfo a -> XML -coreToXML core = makeXML "label" $ - case core of - Label l a -> infoToXML l >> coreBuilder infoToXML a - _ -> coreBuilder infoToXML core - -coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder -coreBuilder f = rec - where - rec core = - case core of - _ :*: _ -> asList "sequence" isSequence - _ :|: _ -> asList "choice" isChoice - _ :|>: _ -> asList "orelse" isOrElse - Many a -> element "many" (rec a) - Repeat a -> element "repeat" (rec a) - Label l (Rule r) | getId l == getId r -> element "rule" (f l) - Label l a -> element "label" (f l >> rec a) - Rec n a -> element "rec" (("var" .=. show n) >> rec a) - Not a -> element "not" (recNot a) - Rule r -> element "rule" ("name" .=. show r) - Var n -> element "var" ("var" .=. show n) - Succeed -> tag "succeed" - Fail -> tag "fail" - where - asList s g = element s (mapM_ rec (collect g core)) - recNot = coreBuilder (const (return ())) - -collect :: (a -> Maybe (a, a)) -> a -> [a] -collect f = ($ []) . rec - where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a) - -isSequence :: Core l a -> Maybe (Core l a, Core l a) -isSequence (a :*: b) = Just (a, b) -isSequence _ = Nothing - -isChoice :: Core l a -> Maybe (Core l a, Core l a) -isChoice (a :|: b) = Just (a, b) -isChoice _ = Nothing - -isOrElse :: Core l a -> Maybe (Core l a, Core l a) -isOrElse (a :|>: b) = Just (a, b) -isOrElse _ = Nothing - ------------------------------------------------------------------------ --- XML to strategy - -xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) -> XML -> m (Strategy a) -xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g - where - g info = case f (showId info) of - Just r -> return r - Nothing -> fail $ "Unknown rule: " ++ showId info - -xmlToInfo :: Monad m => XML -> m LabelInfo -xmlToInfo xml = do - n <- findAttribute "name" xml - let boolAttr s = fromMaybe False (findBool s xml) - return (makeInfo n) - { removed = boolAttr "removed" - , collapsed = boolAttr "collapsed" - , hidden = boolAttr "hidden" - } - -findBool :: Monad m => String -> XML -> m Bool -findBool attr xml = do - s <- findAttribute attr xml - case map toLower s of - "true" -> return True - "false" -> return False - _ -> fail "not a boolean" - -readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a) -readStrategy toLabel findRule xml = do - xs <- mapM (readStrategy toLabel findRule) (children xml) - let s = name xml - case lookup s table of - Just f -> f s xs - Nothing -> - fail $ "Unknown strategy combinator " ++ show s - where - buildSequence _ xs - | null xs = return Succeed - | otherwise = return (foldr1 (:*:) xs) - buildChoice _ xs - | null xs = return Fail - | otherwise = return (foldr1 (:|:) xs) - buildOrElse _ xs - | null xs = return Fail - | otherwise = return (foldr1 (:|>:) xs) - buildLabel x = do - info <- toLabel xml - return (Label info x) - buildRule = do - info <- toLabel xml - r <- findRule info - return (Label info (Rule r)) - buildRec x = do - s <- findAttribute "var" xml - i <- maybe (fail "var: not an int") return (readInt s) - return (Rec i x) - buildVar = do - s <- findAttribute "var" xml - i <- maybe (fail "var: not an int") return (readInt s) - return (Var i) - - comb0 a _ [] = return a - comb0 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 0 args" - - comb1 f _ [x] = return (f x) - comb1 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 1 arg" - - join2 f g a b = join (f g a b) - - table = - [ ("sequence", buildSequence) - , ("choice", buildChoice) - , ("orelse", buildOrElse) - , ("many", comb1 Many) - , ("repeat", comb1 Repeat) - , ("label", join2 comb1 buildLabel) - , ("rec", join2 comb1 buildRec) - , ("not", comb1 (Not . noLabels)) - , ("rule", join2 comb0 buildRule) - , ("var", join2 comb0 buildVar) - , ("succeed", comb0 Succeed) - , ("fail", comb0 Fail) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Converting a strategy to XML, and the other way around. +-- +----------------------------------------------------------------------------- +module Service.StrategyInfo (strategyToXML, xmlToStrategy) where + +import Common.Library +import Common.Strategy.Abstract +import Common.Strategy.Core +import Common.Utils (readInt) +import Control.Monad +import Data.Char +import Data.Maybe +import Text.XML + +----------------------------------------------------------------------- +-- Strategy to XML + +strategyToXML :: IsStrategy f => f a -> XML +strategyToXML = coreToXML . toCore . toStrategy + +infoToXML :: LabelInfo -> XMLBuilder +infoToXML info = do + "name" .=. showId info + when (removed info) ("removed" .=. "true") + when (collapsed info) ("collapsed" .=. "true") + when (hidden info) ("hidden" .=. "true") + +coreToXML :: Core LabelInfo a -> XML +coreToXML core = makeXML "label" $ + case core of + Label l a -> infoToXML l >> coreBuilder infoToXML a + _ -> coreBuilder infoToXML core + +coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder +coreBuilder f = rec + where + rec core = + case core of + _ :*: _ -> asList "sequence" isSequence + _ :|: _ -> asList "choice" isChoice + _ :|>: _ -> asList "orelse" isOrElse + _ :%: _ -> asList "interleave" isInterleave + a :!%: b -> element "interleft" (rec a >> rec b) + Many a -> element "many" (rec a) + Repeat a -> element "repeat" (rec a) + Label l (Rule r) | getId l == getId r -> element "rule" (f l) + Label l a -> element "label" (f l >> rec a) + Atomic a -> element "atomic" (rec a) + Rec n a -> element "rec" (("var" .=. show n) >> rec a) + Not a -> element "not" (recNot a) + Rule r -> element "rule" ("name" .=. show r) + Var n -> element "var" ("var" .=. show n) + Succeed -> tag "succeed" + Fail -> tag "fail" + where + asList s g = element s (mapM_ rec (collect g core)) + recNot = coreBuilder (const (return ())) + +collect :: (a -> Maybe (a, a)) -> a -> [a] +collect f = ($ []) . rec + where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a) + +isSequence :: Core l a -> Maybe (Core l a, Core l a) +isSequence (a :*: b) = Just (a, b) +isSequence _ = Nothing + +isChoice :: Core l a -> Maybe (Core l a, Core l a) +isChoice (a :|: b) = Just (a, b) +isChoice _ = Nothing + +isOrElse :: Core l a -> Maybe (Core l a, Core l a) +isOrElse (a :|>: b) = Just (a, b) +isOrElse _ = Nothing + +isInterleave :: Core l a -> Maybe (Core l a, Core l a) +isInterleave (a :%: b) = Just (a, b) +isInterleave _ = Nothing + +----------------------------------------------------------------------- +-- XML to strategy + +xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) -> XML -> m (Strategy a) +xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g + where + g info = case f (showId info) of + Just r -> return r + Nothing -> fail $ "Unknown rule: " ++ showId info + +xmlToInfo :: Monad m => XML -> m LabelInfo +xmlToInfo xml = do + n <- findAttribute "name" xml + let boolAttr s = fromMaybe False (findBool s xml) + return (makeInfo n) + { removed = boolAttr "removed" + , collapsed = boolAttr "collapsed" + , hidden = boolAttr "hidden" + } + +findBool :: Monad m => String -> XML -> m Bool +findBool attr xml = do + s <- findAttribute attr xml + case map toLower s of + "true" -> return True + "false" -> return False + _ -> fail "not a boolean" + +readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a) +readStrategy toLabel findRule xml = do + xs <- mapM (readStrategy toLabel findRule) (children xml) + let s = name xml + case lookup s table of + Just f -> f s xs + Nothing -> + fail $ "Unknown strategy combinator " ++ show s + where + buildSequence _ xs + | null xs = return Succeed + | otherwise = return (foldr1 (:*:) xs) + buildChoice _ xs + | null xs = return Fail + | otherwise = return (foldr1 (:|:) xs) + buildOrElse _ xs + | null xs = return Fail + | otherwise = return (foldr1 (:|>:) xs) + buildInterleave _ xs + | null xs = return Succeed + | otherwise = return (foldr1 (:%:) xs) + buildLabel x = do + info <- toLabel xml + return (Label info x) + buildRule = do + info <- toLabel xml + r <- findRule info + return (Label info (Rule r)) + buildRec x = do + s <- findAttribute "var" xml + i <- maybe (fail "var: not an int") return (readInt s) + return (Rec i x) + buildVar = do + s <- findAttribute "var" xml + i <- maybe (fail "var: not an int") return (readInt s) + return (Var i) + + comb0 a _ [] = return a + comb0 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 0 args" + + comb1 f _ [x] = return (f x) + comb1 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 1 arg" + + join2 f g a b = join (f g a b) + + table = + [ ("sequence", buildSequence) + , ("choice", buildChoice) + , ("orelse", buildOrElse) + , ("interleave", buildInterleave) + , ("many", comb1 Many) + , ("repeat", comb1 Repeat) + , ("label", join2 comb1 buildLabel) + , ("atomic", comb1 Atomic) + , ("rec", join2 comb1 buildRec) + , ("not", comb1 (Not . noLabels)) + , ("rule", join2 comb0 buildRule) + , ("var", join2 comb0 buildVar) + , ("succeed", comb0 Succeed) + , ("fail", comb0 Fail) ] diff --git a/src/Service/Submit.hs b/src/Service/Submit.hs --- a/src/Service/Submit.hs +++ b/src/Service/Submit.hs @@ -1,75 +1,66 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Diagnose a term submitted by a student. Deprecated (see diagnose service). --- ------------------------------------------------------------------------------ -module Service.Submit - ( submit, Result(..), getResultState - , submitType, submitTypeSynonym - ) where - -import Common.Library -import qualified Service.Diagnose as Diagnose -import Service.Diagnose (Diagnosis, diagnose) -import Service.State -import Service.Types - --- Note that in the typed setting there is no syntax error -data Result a = Buggy [Rule (Context a)] - | NotEquivalent - | Ok [Rule (Context a)] (State a) -- equivalent - | Detour [Rule (Context a)] (State a) -- equivalent - | Unknown (State a) -- equivalent - -fromDiagnose :: Diagnosis a -> Result a -fromDiagnose diagnosis = - case diagnosis of - Diagnose.Buggy r -> Buggy [r] - Diagnose.NotEquivalent -> NotEquivalent - Diagnose.Similar _ s -> Ok [] s - Diagnose.Expected _ s r -> Ok [r] s - Diagnose.Detour _ s r -> Detour [r] s - Diagnose.Correct _ s -> Unknown s - -submit :: State a -> a -> Result a -submit state = fromDiagnose . diagnose state - -getResultState :: Result a -> Maybe (State a) -getResultState result = - case result of - Ok _ st -> return st - Detour _ st -> return st - Unknown st -> return st - _ -> Nothing - -submitType :: Type a (Result a) -submitType = useSynonym submitTypeSynonym - -submitTypeSynonym :: TypeSynonym a (Result a) -submitTypeSynonym = typeSynonym "Result" to from tp - where - to (Left rs) = Buggy rs - to (Right (Left ())) = NotEquivalent - to (Right (Right (Left (rs, s)))) = Ok rs s - to (Right (Right (Right (Left (rs, s))))) = Detour rs s - to (Right (Right (Right (Right s)))) = Unknown s - - from (Buggy rs) = Left rs - from (NotEquivalent) = Right (Left ()) - from (Ok rs s) = Right (Right (Left (rs, s))) - from (Detour rs s) = Right (Right (Right (Left (rs, s)))) - from (Unknown s) = Right (Right (Right (Right s))) - - tp = List Rule - :|: Unit - :|: Pair (List Rule) stateTp - :|: Pair (List Rule) stateTp - :|: stateTp +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Diagnose a term submitted by a student. Deprecated (see diagnose service). +-- +----------------------------------------------------------------------------- +module Service.Submit + ( submit, Result(..) + , submitType + ) where + +import Common.Library +import Service.Diagnose (Diagnosis, diagnose) +import Service.State +import Service.Types +import qualified Service.Diagnose as Diagnose + +-- Note that in the typed setting there is no syntax error +data Result a = Buggy [Rule (Context a)] + | NotEquivalent + | Ok [Rule (Context a)] (State a) -- equivalent + | Detour [Rule (Context a)] (State a) -- equivalent + | Unknown (State a) -- equivalent + +fromDiagnose :: Diagnosis a -> Result a +fromDiagnose diagnosis = + case diagnosis of + Diagnose.Buggy _ r -> Buggy [r] + Diagnose.NotEquivalent -> NotEquivalent + Diagnose.Similar _ s -> Ok [] s + Diagnose.Expected _ s r -> Ok [r] s + Diagnose.Detour _ s _ r -> Detour [r] s + Diagnose.Correct _ s -> Unknown s +-- Diagnose.Missing -> NotEquivalent +-- Diagnose.IncorrectPart _ -> NotEquivalent + +submit :: State a -> a -> Result a +submit state = fromDiagnose . diagnose state + +submitType :: Type a (Result a) +submitType = Tag "Result" (Iso (f <-> g) tp) + where + f (Left rs) = Buggy rs + f (Right (Left ())) = NotEquivalent + f (Right (Right (Left (rs, s)))) = Ok rs s + f (Right (Right (Right (Left (rs, s))))) = Detour rs s + f (Right (Right (Right (Right s)))) = Unknown s + + g (Buggy rs) = Left rs + g (NotEquivalent) = Right (Left ()) + g (Ok rs s) = Right (Right (Left (rs, s))) + g (Detour rs s) = Right (Right (Right (Left (rs, s)))) + g (Unknown s) = Right (Right (Right (Right s))) + + tp = List Rule + :|: Unit + :|: Pair (List Rule) stateType + :|: Pair (List Rule) stateType + :|: stateType diff --git a/src/Service/TypedExample.hs b/src/Service/TypedExample.hs --- a/src/Service/TypedExample.hs +++ b/src/Service/TypedExample.hs @@ -1,81 +1,81 @@ -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.TypedExample (typedExample) where - -import Data.Char -import Service.DomainReasoner -import Service.ModeXML -import Service.ExercisePackage -import Service.Evaluator -import Service.Types -import Common.Library -import Text.XML - -typedExample :: ExercisePackage a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool) -typedExample pkg service args = do - -- Construct a request in xml - request <- - case makeArgType args of - Nothing -> return $ - stdReply (showId service) enc (exercise pkg) (return ()) - Just (reqTuple ::: reqTp) -> do - xml <- encodeType (encoder evaluator) reqTp reqTuple - return $ - stdReply (showId service) enc (exercise pkg) xml - -- Construct a reply in xml - reply <- - case foldl dynamicApply (serviceFunction service) args of - reply ::: replyTp -> do - xml <- encodeType (encoder evaluator) replyTp reply - return (resultOk xml) - `catchError` - (return . resultError) - -- Check request/reply pair - vers <- getVersion - xmlTest <- do - (_, txt, _) <- processXML (show request) - let p = filter (not . isSpace) - out = showXML (if null vers then reply else addVersion vers reply) - return (p txt == p out) - `catchError` - const (return False) - return (request, reply, xmlTest) - where - (evaluator, enc) - | withOpenMath pkg = (openMathConverterTp pkg, "openmath") - | otherwise = (stringFormatConverterTp pkg, "string") - -stdReply :: String -> String -> Exercise a -> XMLBuilder -> XML -stdReply s enc ex body = makeXML "request" $ do - "service" .=. s - "exerciseid" .=. showId ex - "source" .=. "test" - "encoding" .=. enc - body - -makeArgType :: [TypedValue a] -> Maybe (TypedValue a) -makeArgType [] = fail "makeArgType: empty list" -makeArgType [_ ::: ExercisePkg] = fail "makeArgType: empty list" -makeArgType [tv] = return tv -makeArgType ((a1 ::: t1) : rest) = do - a2 ::: t2 <- makeArgType rest - return $ (a1, a2) ::: Pair t1 t2 - -dynamicApply :: TypedValue a -> TypedValue a -> TypedValue a -dynamicApply fun arg = - case (fun, arg) of - (f ::: t1 :-> t2, a ::: t3) -> - case equal t3 t1 of - Just eq -> f (eq a) ::: t2 - Nothing -> error $ "mismatch (argument type): " ++ show t3 ++ " does not match " ++ show t1 +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.TypedExample (typedExample) where + +import Common.Library +import Data.Char +import Data.Maybe +import Service.DomainReasoner +import Service.Evaluator +import Service.ModeXML +import Service.Types +import Text.XML + +typedExample :: Exercise a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool) +typedExample ex service args = do + -- Construct a request in xml + request <- + case makeArgType args of + Nothing -> return $ + stdReply (showId service) enc ex (return ()) + Just (reqTuple ::: reqTp) -> do + xml <- encodeType (encoder evaluator) reqTp reqTuple + return $ + stdReply (showId service) enc ex xml + -- Construct a reply in xml + reply <- + case foldl dynamicApply (serviceFunction service) args of + reply ::: replyTp -> do + xml <- encodeType (encoder evaluator) replyTp reply + return (resultOk xml) + `catchError` + (return . resultError) + -- Check request/reply pair + vers <- getVersion + xmlTest <- do + (_, txt, _) <- processXML (show request) + let p = filter (not . isSpace) + out = showXML (if null vers then reply else addVersion vers reply) + return (p txt == p out) + `catchError` + const (return False) + return (request, reply, xmlTest) + where + (evaluator, enc) + | isJust (hasTermView ex) = (openMathConverterTp ex, "openmath") + | otherwise = (stringFormatConverterTp ex, "string") + +stdReply :: String -> String -> Exercise a -> XMLBuilder -> XML +stdReply s enc ex body = makeXML "request" $ do + "service" .=. s + "exerciseid" .=. showId ex + "source" .=. "test" + "encoding" .=. enc + body + +makeArgType :: [TypedValue a] -> Maybe (TypedValue a) +makeArgType [] = fail "makeArgType: empty list" +makeArgType [_ ::: Exercise] = fail "makeArgType: empty list" +makeArgType [tv] = return tv +makeArgType ((a1 ::: t1) : rest) = do + a2 ::: t2 <- makeArgType rest + return $ (a1, a2) ::: Pair t1 t2 + +dynamicApply :: TypedValue a -> TypedValue a -> TypedValue a +dynamicApply fun arg = + case (fun, arg) of + (f ::: t1 :-> t2, a ::: t3) -> + case equal t3 t1 of + Just eq -> f (eq a) ::: t2 + Nothing -> error $ "mismatch (argument type): " ++ show t3 ++ " does not match " ++ show t1 _ -> error "mismatch (not a function)" diff --git a/src/Service/Types.hs b/src/Service/Types.hs --- a/src/Service/Types.hs +++ b/src/Service/Types.hs @@ -1,206 +1,210 @@ -{-# LANGUAGE GADTs, Rank2Types #-} ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Service.Types - ( -- * Services - Service, makeService, deprecate - , serviceDeprecated, serviceFunction - -- * Types - , Type(..), TypedValue(..), tuple2, tuple3, tuple4, maybeTp, optionTp - , errorTp, equal, isSynonym, useSynonym, TypeSynonym, typeSynonym - , equalM - ) where - -import Common.Library -import Common.Utils (commaList) -import Control.Monad -import Data.Maybe -import Service.ExercisePackage - ------------------------------------------------------------------------------ --- Services - -data Service = Service - { serviceId :: Id - , serviceDeprecated :: Bool - , serviceFunction :: forall a . TypedValue a - } - -instance HasId Service where - getId = serviceId - changeId f a = a { serviceId = f (serviceId a) } - -makeService :: String -> String -> (forall a . TypedValue a) -> Service -makeService s descr f = describe descr (Service (newId s) False f) - -deprecate :: Service -> Service -deprecate s = s { serviceDeprecated = True } - -equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2) -equalM t1 t2 = maybe (fail msg) return (equal t1 t2) - where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2 - -equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2) -equal type1 type2 = - case (type1, type2) of - (Pair a b, Pair c d ) -> equalPairs a b c d - (a :|: b, c :|: d ) -> equalChoice a b c d - (List a, List b ) -> liftM map (equal a b) - (Rule, Rule ) -> Just id - (Unit, Unit ) -> Just id - (StrategyCfg, StrategyCfg) -> Just id - (Location, Location ) -> Just id - (Id, Id ) -> Just id - (Term, Term ) -> Just id - (ExercisePkg, ExercisePkg) -> Just id - (Context, Context ) -> Just id - (Bool, Bool ) -> Just id - (String, String ) -> Just id - (Int, Int ) -> Just id - (Iso _ f a, _ ) -> fmap (. f) (equal a type2) - (_, Iso f _ b ) -> fmap (f .) (equal type1 b) - (Tag s1 a, Tag s2 b ) -> guard (s1==s2) >> equal a b - _ -> Nothing - where - equalPairs a b c d = - liftM2 (\f g (x, y) -> (f x, g y)) (equal a c) (equal b d) - - equalChoice a b c d = - liftM2 (\f g -> either (Left . f) (Right . g)) (equal a c) (equal b d) - -infixr 5 :|: - ------------------------------------------------------------------------------ --- Types - -infix 2 ::: -infixr 3 :-> - -data TypedValue a = forall t . t ::: Type a t - -tuple2 :: Type a t1 -> Type a t2 -> Type a (t1, t2) -tuple2 = Pair - -tuple3 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3) -tuple3 t1 t2 t3 = Iso f g (Pair t1 (Pair t2 t3)) - where - f (a, (b, c)) = (a, b, c) - g (a, b, c) = (a, (b, c)) - -tuple4 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4) -tuple4 t1 t2 t3 t4 = Iso f g (Pair t1 (Pair t2 (Pair t3 t4))) - where - f (a, (b, (c, d))) = (a, b, c, d) - g (a, b, c, d) = (a, (b, (c, d))) - -maybeTp :: Type a t1 -> Type a (Maybe t1) -maybeTp t = Iso f g (t :|: Unit) - where - f = either Just (const Nothing) - g = maybe (Right ()) Left - -optionTp :: t1 -> Type a t1 -> Type a t1 -optionTp a t = Iso (fromMaybe a) Just (maybeTp t) - -errorTp :: Type a t -> Type a (Either String t) -errorTp t = Iso f g (t :|: IO Unit) - where - f = either Right (const (Left "errorTp")) - g = either (Right . fail) Left - -data Type a t where - -- Type isomorphisms (for defining type synonyms) - Iso :: (t1 -> t2) -> (t2 -> t1) -> Type a t1 -> Type a t2 - -- Function type - (:->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) - -- Special annotations - Tag :: String -> Type a t1 -> Type a t1 - -- Type constructors - List :: Type a t -> Type a [t] - Pair :: Type a t1 -> Type a t2 -> Type a (t1, t2) - (:|:) :: Type a t1 -> Type a t2 -> Type a (Either t1 t2) - Unit :: Type a () - IO :: Type a t -> Type a (IO t) - -- Exercise-specific types - ExercisePkg :: Type a (ExercisePackage a) - Strategy :: Type a (Strategy (Context a)) - Rule :: Type a (Rule (Context a)) - Term :: Type a a - Context :: Type a (Context a) - Location :: Type a Location - Id :: Type a Id - StrategyCfg :: Type a StrategyConfiguration - -- Basic types - Bool :: Type a Bool - Int :: Type a Int - String :: Type a String - -instance Show (Type a t) where - show (Iso _ _ t) = show t - show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 - show t@(Pair _ _) = showTuple t - show (t1 :|: t2) = show t1 ++ " | " ++ show t2 - show (Tag s _) = s -- ++ "@(" ++ show t ++ ")" - show (List t) = "[" ++ show t ++ "]" - show (IO t) = show t - show t = fromMaybe "unknown" (groundType t) - -showTuple :: Type a t -> String -showTuple tp = "(" ++ commaList (collect tp) ++ ")" - where - collect :: Type a t -> [String] - collect (Pair t1 t2) = collect t1 ++ collect t2 - collect (Iso _ _ t) = collect t - collect t = [show t] - -groundType :: Type a t -> Maybe String -groundType tp = - case tp of - ExercisePkg -> Just "ExercisePkg" - Strategy -> Just "Strategy" - Rule -> Just "Rule" - Term -> Just "Term" - Context -> Just "Context" - Unit -> Just "()" - Bool -> Just "Bool" - Int -> Just "Int" - String -> Just "String" - Location -> Just "Location" - Id -> Just "Id" - StrategyCfg -> Just "StrategyConfiguration" +{-# LANGUAGE GADTs, Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.Types + ( -- * Services + Service, makeService, deprecate + , serviceDeprecated, serviceFunction + -- * Types + , Type(..), TypedValue(..), tuple2, tuple3, tuple4 + , maybeType, optionType + , errorType, difficultyType, listType, elemType + , derivationType, messageType + , equal, equalM + ) where + +import Common.Library +import Common.Utils (commaList) +import Control.Monad +import Data.Maybe +import Service.FeedbackScript.Syntax +import System.Random + +----------------------------------------------------------------------------- +-- Services + +data Service = Service + { serviceId :: Id + , serviceDeprecated :: Bool + , serviceFunction :: forall a . TypedValue a + } + +instance HasId Service where + getId = serviceId + changeId f a = a { serviceId = f (serviceId a) } + +makeService :: String -> String -> (forall a . TypedValue a) -> Service +makeService s descr f = describe descr (Service (newId s) False f) + +deprecate :: Service -> Service +deprecate s = s { serviceDeprecated = True } + +equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2) +equalM t1 t2 = maybe (fail msg) return (equal t1 t2) + where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2 + +equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2) +equal type1 type2 = + case (type1, type2) of + (Pair a b, Pair c d ) -> liftM2 (\f g (x, y) -> (f x, g y)) (equal a c) (equal b d) + (a :|: b, c :|: d ) -> liftM2 biMap (equal a c) (equal b d) + (List a, List b ) -> fmap map (equal a b) + (Rule, Rule ) -> Just id + (Unit, Unit ) -> Just id + (StrategyCfg, StrategyCfg) -> Just id + (Location, Location ) -> Just id + (Id, Id ) -> Just id + (Term, Term ) -> Just id + (Exercise, Exercise ) -> Just id + (Script, Script ) -> Just id + (Context, Context ) -> Just id + (ArgValueTp, ArgValueTp ) -> Just id + (Text, Text ) -> Just id + (StdGen, StdGen ) -> Just id + (IO a, IO b ) -> fmap liftM (equal a b) + (Exception, Exception ) -> Just id + (Bool, Bool ) -> Just id + (String, String ) -> Just id + (Int, Int ) -> Just id + (Iso p a, _ ) -> fmap (. to p) (equal a type2) + (_, Iso p b ) -> fmap (from p .) (equal type1 b) + (Tag s1 a, Tag s2 b ) -> guard (s1==s2) >> equal a b + _ -> Nothing + +infixr 5 :|: + +----------------------------------------------------------------------------- +-- Types + +infix 2 ::: +infixr 3 :-> + +data TypedValue a = forall t . t ::: Type a t + +tuple2 :: Type a t1 -> Type a t2 -> Type a (t1, t2) +tuple2 = Pair + +tuple3 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3) +tuple3 t1 t2 t3 = Iso (f <-> g) (Pair t1 (Pair t2 t3)) + where + f (a, (b, c)) = (a, b, c) + g (a, b, c) = (a, (b, c)) + +tuple4 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4) +tuple4 t1 t2 t3 t4 = Iso (f <-> g) (Pair t1 (Pair t2 (Pair t3 t4))) + where + f (a, (b, (c, d))) = (a, b, c, d) + g (a, b, c, d) = (a, (b, (c, d))) + +maybeType :: Type a t1 -> Type a (Maybe t1) +maybeType t = Iso (f <-> g) (t :|: Unit) + where + f = either Just (const Nothing) + g = maybe (Right ()) Left + +optionType :: t1 -> Type a t1 -> Type a t1 +optionType a t = Iso (fromMaybe a <-> Just) (maybeType t) + +errorType :: Type a t -> Type a (Either String t) +errorType t = Exception :|: t + +listType :: Type a t -> Type a [t] -- with list "tag" +listType = Tag "list" . List . elemType + +elemType :: Type a t -> Type a t +elemType = Tag "elem" + +messageType :: Type a t -> Type a t +messageType = Tag "message" + +difficultyType :: Type a Difficulty +difficultyType = Tag "difficulty" (Iso (f <-> show) String) + where + f = fromMaybe Medium . readDifficulty + +derivationType :: Type a t1 -> Type a t2 -> Type a (Derivation t1 t2) +derivationType t1 t2 = Iso (f <-> g) (listType (tuple2 t1 t2)) + where + f = foldl extend (emptyDerivation (error "derivationType") ) + g = map (\(_, s, a) -> (s, a)) . triples + +data Type a t where + -- Type isomorphisms (for defining type synonyms) + Iso :: Isomorphism t1 t2 -> Type a t1 -> Type a t2 + -- Function type + (:->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) + -- Special annotations + Tag :: String -> Type a t1 -> Type a t1 + -- Type constructors + List :: Type a t -> Type a [t] + Pair :: Type a t1 -> Type a t2 -> Type a (t1, t2) + (:|:) :: Type a t1 -> Type a t2 -> Type a (Either t1 t2) + Unit :: Type a () + StdGen :: Type a StdGen + IO :: Type a t -> Type a (IO t) + Exception :: Type a String + -- Exercise-specific types + Exercise :: Type a (Exercise a) + Script :: Type a Script + Strategy :: Type a (Strategy (Context a)) + Rule :: Type a (Rule (Context a)) + Term :: Type a a + Context :: Type a (Context a) + Location :: Type a Location + Id :: Type a Id + StrategyCfg :: Type a StrategyConfiguration + ArgValueTp :: Type a ArgValue + Text :: Type a Text + -- Basic types + Bool :: Type a Bool + Int :: Type a Int + String :: Type a String + +instance Show (Type a t) where + show (Iso _ t) = show t + show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 + show t@(Pair _ _) = showTuple t + show (t1 :|: t2) = show t1 ++ " | " ++ show t2 + show (Tag s _) = s -- ++ "@(" ++ show t ++ ")" + show (List t) = "[" ++ show t ++ "]" + show (IO t) = show t + show t = fromMaybe "unknown" (showGroundType t) + +showTuple :: Type a t -> String +showTuple tp = "(" ++ commaList (collect tp) ++ ")" + where + collect :: Type a t -> [String] + collect (Pair t1 t2) = collect t1 ++ collect t2 + collect (Iso _ t) = collect t + collect t = [show t] + +showGroundType :: Type a t -> Maybe String +showGroundType tp = + case tp of + Exercise -> Just "Exercise" + Script -> Just "Script" + Strategy -> Just "Strategy" + Rule -> Just "Rule" + Term -> Just "Term" + Context -> Just "Context" + Unit -> Just "()" + Bool -> Just "Bool" + Int -> Just "Int" + String -> Just "String" + Location -> Just "Location" + Id -> Just "Id" + StrategyCfg -> Just "StrategyConfiguration" + ArgValueTp -> Just "ArgumentValue" + Text -> Just "TextMessage" + StdGen -> Just "StdGen" + Exception -> Just "Exception" _ -> Nothing - ------------------------------------------------------------------------------ --- Type Synonyms - -data TypeSynonym a t = TS - { synonymName :: String - , useSynonym :: Type a t - , isSynonym :: Monad m => TypedValue a -> m t - } - -typeSynonym :: String -> (t2 -> t) -> (t -> t2) -> Type a t2 -> TypeSynonym a t -typeSynonym name to from tp = TS - { synonymName = name - , useSynonym = Tag name (Iso to from tp) - , isSynonym = maybe (fail name) return . matchSynonym - } - where - matchSynonym (a ::: t0) = do - (s, t) <- isTag t0 - guard (s == name) - f <- equal t tp - return (to (f a)) - -isTag :: Type a t -> Maybe (String, Type a t) -isTag (Tag s t) = Just (s, t) -isTag _ = Nothing diff --git a/src/Text/HTML.hs b/src/Text/HTML.hs --- a/src/Text/HTML.hs +++ b/src/Text/HTML.hs @@ -1,165 +1,187 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A minimal interface for constructing simple HTML pages --- ------------------------------------------------------------------------------ -module Text.HTML - ( HTML, HTMLBuilder, showHTML - , htmlPage, errorPage, link, linkTitle - , h1, h2, h3, h4, preText, ul, table - , text, image, space, tt, spaces, highlightXML - , font, bold, italic, para, ttText, hr, br, pre, center, bullet, divClass - ) where - -import Text.XML hiding (text) -import qualified Text.XML as XML -import Control.Monad -import Data.Char -import Data.List - -type HTML = XML - -type HTMLBuilder = XMLBuilder - -showHTML :: HTML -> String -showHTML = compactXML - --- html helper functions -htmlPage :: String -> Maybe String -> HTMLBuilder -> HTML -htmlPage title css body = makeXML "html" $ do - element "head" $ do - unless (null title) $ - element "title" (text title) - case css of - Nothing -> return () - Just n -> element "link" $ do - "rel" .=. "STYLESHEET" - "href" .=. n - "type" .=. "text/css" - element "body" body - -errorPage :: String -> HTML -errorPage s = htmlPage "Error" Nothing $ do - h1 "Error" - text s - -link :: String -> HTMLBuilder -> HTMLBuilder -link url body = element "a" $ - ("href" .=. url) >> body - -linkTitle :: String -> String -> HTMLBuilder -> HTMLBuilder -linkTitle url title body = element "a" $ - ("href" .=. url) >> ("title" .=. title) >> body - -center :: HTMLBuilder -> HTMLBuilder -center = element "center" - -h1 :: String -> HTMLBuilder -h1 = element "h1" . text - -h2 :: String -> HTMLBuilder -h2 = element "h2" . text - -h3 :: String -> HTMLBuilder -h3 = element "h3" . text - -h4 :: String -> HTMLBuilder -h4 = element "h4" . text - -font :: String -> HTMLBuilder -> HTMLBuilder -font n = element "font" . ("class" .=. n >>) - -bold, italic :: HTMLBuilder -> HTMLBuilder -bold = element "b" -italic = element "i" - -para :: HTMLBuilder -> HTMLBuilder -para = element "p" - -preText :: String -> HTMLBuilder -preText = pre . text - -pre :: HTMLBuilder -> HTMLBuilder -pre = element "pre" - -hr :: HTMLBuilder -hr = tag "hr" - -br :: HTMLBuilder -br = tag "br" - -tt :: HTMLBuilder -> HTMLBuilder -tt = element "tt" - -ttText :: String -> HTMLBuilder -ttText = tt . text - -ul :: [HTMLBuilder] -> HTMLBuilder -ul = element "ul" . mapM_ (element "li") - -table :: [[HTMLBuilder]] -> HTMLBuilder -table rows = element "table" $ do - "border" .=. "1" - forM_ (zip [0::Int ..] rows) $ \(i, r) -> - element "tr" $ do - "class" .=. getClass i - mapM_ (element "td") r - where - getClass i - | i == 0 = "topRow" - | even i = "evenRow" - | otherwise = "oddRow" - -spaces :: Int -> HTMLBuilder -spaces n = replicateM_ n space - -space, bullet :: HTMLBuilder -space = XML.unescaped " " -bullet = XML.unescaped "•" - -image :: String -> HTMLBuilder -image n = element "img" ("src" .=. n) - -text :: String -> HTMLBuilder -text = XML.text - -divClass :: String -> HTMLBuilder -> HTMLBuilder -divClass n body = element "div" ("class" .=. n >> body) - --- A simple XML highlighter -highlightXML :: Bool -> XML -> HTMLBuilder -highlightXML nice - | nice = builder . highlight . makeXML "pre" . text . showXML - | otherwise = builder . highlight . makeXML "tt" . text . compactXML - where - highlight :: HTML -> HTML - highlight html = html {content = map (either (Left . f) Right) (content html)} - - -- find < - f :: String -> String - f [] = [] - f list@(x:xs) - | "</" `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 +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A minimal interface for constructing simple HTML pages +-- See http://www.w3.org/TR/html4/ +-- +----------------------------------------------------------------------------- +module Text.HTML + ( HTML, HTMLBuilder, showHTML + , htmlPage, link + , h1, h2, h3, h4, h5, h6 + , preText, ul, table + , text, image, space, spaces, highlightXML + , para, ttText, hr, br, pre, bullet + , divClass, spanClass + -- HTML generic attributes + , idA, classA, styleA, titleA + -- Font style elements + , tt, italic, bold, big, small + ) where + +import Control.Monad +import Data.Char +import Data.List +import Prelude hiding (div) +import Text.XML hiding (text) +import qualified Text.XML as XML + +type HTML = XML + +type HTMLBuilder = XMLBuilder + +showHTML :: HTML -> String +showHTML = compactXML + +-- html helper functions +htmlPage :: String -> Maybe String -> HTMLBuilder -> HTML +htmlPage title css body = makeXML "html" $ do + element "head" $ do + unless (null title) $ + element "title" (text title) + case css of + Nothing -> return () + Just n -> element "link" $ do + "rel" .=. "STYLESHEET" + "href" .=. n + "type" .=. "text/css" + element "body" body + +link :: String -> HTMLBuilder -> HTMLBuilder +link url body = element "a" $ + ("href" .=. url) >> body + +h1, h2, h3, h4, h5, h6 :: String -> HTMLBuilder +h1 = element "h1" . text +h2 = element "h2" . text +h3 = element "h3" . text +h4 = element "h4" . text +h5 = element "h5" . text +h6 = element "h6" . text + +para :: HTMLBuilder -> HTMLBuilder +para = element "p" + +preText :: String -> HTMLBuilder +preText = pre . text + +pre :: HTMLBuilder -> HTMLBuilder +pre = element "pre" + +hr :: HTMLBuilder +hr = tag "hr" + +br :: HTMLBuilder +br = tag "br" + +ttText :: String -> HTMLBuilder +ttText = tt . text + +ul :: [HTMLBuilder] -> HTMLBuilder +ul = element "ul" . mapM_ (element "li") + +-- | First argument indicates whether the table has a header or not +table :: Bool -> [[HTMLBuilder]] -> HTMLBuilder +table b rows = element "table" $ do + "border" .=. "1" + forM_ (zip [0::Int ..] rows) $ \(i, r) -> + element "tr" $ do + "class" .=. getClass i + mapM_ ((if i==0 then classA "topCell" else id) . element "td") r + where + getClass i + | i == 0 && b = "topRow" + | even i = "evenRow" + | otherwise = "oddRow" + +spaces :: Int -> HTMLBuilder +spaces n = replicateM_ n space + +space, bullet :: HTMLBuilder +space = XML.unescaped " " +bullet = XML.unescaped "•" + +image :: String -> HTMLBuilder +image n = element "img" ("src" .=. n) + +text :: String -> HTMLBuilder +text = XML.text + +divClass :: String -> HTMLBuilder -> HTMLBuilder +divClass n = classA n . element "div" + +spanClass :: String -> HTMLBuilder -> HTMLBuilder +spanClass n = classA n . element "span" + +-- A simple XML highlighter +highlightXML :: Bool -> XML -> HTMLBuilder +highlightXML nice + | nice = builder . highlight . makeXML "pre" . text . showXML + | otherwise = builder . highlight . makeXML "tt" . text . compactXML + where + highlight :: HTML -> HTML + highlight html = html {content = map (either (Left . f) Right) (content html)} + + -- find < + f :: String -> String + f [] = [] + f list@(x:xs) + | "</" `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 + +----------------------------------------------------------- +-- * HTML generic attributes + +idA, classA, styleA, titleA :: String -> HTMLBuilder -> HTMLBuilder +idA = setA "id" -- document-wide unique id +classA = setA "class" -- space-separated list of classes +styleA = setA "style" -- associated style info +titleA = setA "title" -- advisory title + +setA :: String -> String -> HTMLBuilder -> HTMLBuilder +setA attr value = updateLast $ \e -> + e { attributes = (attr := value) : attributes e } + +----------------------------------------------------------- +-- * Font style elements + +-- | Renders as teletype or monospaced text. +tt :: HTMLBuilder -> HTMLBuilder +tt = element "tt" + +-- | Renders as italic text style. +italic :: HTMLBuilder -> HTMLBuilder +italic = element "i" + +-- | Renders as bold text style. +bold :: HTMLBuilder -> HTMLBuilder +bold = element "b" + +-- BIG: Renders text in a "large" font. +big :: HTMLBuilder -> HTMLBuilder +big = element "big" + +-- SMALL: Renders text in a "small" font. +small :: HTMLBuilder -> HTMLBuilder +small = element "small" diff --git a/src/Text/JSON.hs b/src/Text/JSON.hs --- a/src/Text/JSON.hs +++ b/src/Text/JSON.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -8,11 +8,11 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Support for JavaScript Object Notation (JSON) and remote procedure calls using --- JSON. JSON is a lightweight alternative for XML. +-- Support for JavaScript Object Notation (JSON) and remote procedure calls using +-- JSON. JSON is a lightweight alternative for XML. -- ----------------------------------------------------------------------------- -module Text.JSON +module Text.JSON ( JSON(..), Key, Number(..) -- types , InJSON(..) -- type class" , lookupM @@ -20,14 +20,15 @@ , jsonRPC, JSON_RPC_Handler, propEncoding ) where -import Text.Parsing -import qualified Text.UTF8 as UTF8 -import Data.List (intersperse) -import Data.Maybe import Control.Monad.Error +import Data.List (intercalate) +import Data.Maybe import Test.QuickCheck +import Text.Parsing +import qualified Text.ParserCombinators.Parsec.Token as P +import qualified Text.UTF8 as UTF8 -data JSON +data JSON = Number Number -- integer, real, or floating point | String String -- double-quoted Unicode with backslash escapement | Boolean Bool -- true and false @@ -37,31 +38,32 @@ deriving Eq type Key = String - + data Number = I Integer | D Double deriving Eq instance Show JSON where show = showPretty - + showCompact :: JSON -> String showCompact json = case json of Number n -> show n String s -> "\"" ++ escape s ++ "\"" Boolean b -> if b then "true" else "false" - Array xs -> squareBrackets $ concat $ intersperse ", " $ map showCompact xs + Array xs -> squareBrackets $ intercalate ", " $ map showCompact xs Object xs -> let f (k, v) = show k ++ ": " ++ showCompact v - in curlyBrackets $ concat $ intersperse ", " $ map f xs + in curlyBrackets $ intercalate ", " $ map f xs Null -> "null" - + -- Escape double quote and backslash, and convert to UTF8 encoding escape :: String -> String -escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM +escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM where + f '\n' = "\\\\n" f '"' = "\\\"" f '\\' = "\\\\" f c = [c] - + showPretty :: JSON -> String showPretty json = case json of @@ -69,11 +71,15 @@ Object xs -> let f (k, v) = show k ++ ": " ++ showPretty v in curlyBrackets $ '\n' : indent 3 (commas (map f xs)) _ -> showCompact json - where + where commas [] = [] commas [x] = x commas (x:xs) = x ++ ",\n" ++ commas xs - + +squareBrackets, curlyBrackets :: String -> String +squareBrackets s = "[" ++ s ++ "]" +curlyBrackets s = "{" ++ s ++ "}" + instance Show Number where show (I n) = show n show (D d) = show d @@ -88,20 +94,20 @@ listFromJSON (Array xs) = mapM fromJSON xs listFromJSON _ = fail "expecting an array" -instance InJSON Int where +instance InJSON Int where toJSON = toJSON . toInteger fromJSON = liftM fromInteger . fromJSON - -instance InJSON Integer where + +instance InJSON Integer where toJSON = Number . I fromJSON (Number (I n)) = return n fromJSON _ = fail "expecting a number" -instance InJSON Double where +instance InJSON Double where toJSON = Number . D fromJSON (Number (D n)) = return n fromJSON _ = fail "expecting a number" - + instance InJSON Char where toJSON c = String [c] listToJSON = String @@ -110,12 +116,12 @@ listFromJSON (String s) = return s listFromJSON _ = fail "expecting a string" -instance InJSON Bool where +instance InJSON Bool where toJSON = Boolean fromJSON (Boolean b) = return b fromJSON _ = fail "expecting a boolean" -instance InJSON a => InJSON [a] where +instance InJSON a => InJSON [a] where toJSON = listToJSON fromJSON = listFromJSON @@ -133,34 +139,30 @@ toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d) fromJSON _ = fail "expecting an array with 4 elements" - -parseJSON :: Monad m => String -> m JSON -parseJSON input = - case parseWith jsonScanner json input of - Left err -> fail (show err) - Right a -> return a + +-------------------------------------------------------- +-- Parser + +parseJSON :: String -> Either String JSON +parseJSON = parseSimple json where - jsonScanner = specialSymbols ":" defaultScanner - { keywords = ["true", "false", "null"] - , unaryMinus = True - } - - json :: TokenParser JSON - json = (Number . I) <$> pInteger - <|> (Number . D) <$> pReal - <|> (String . fromMaybe [] . UTF8.decodeM) <$> pString - <|> Boolean True <$ pKey "true" - <|> Boolean False <$ pKey "false" - <|> Array <$> pBracks (pCommas json) - <|> Object <$> pCurly (pCommas keyValue) - <|> Null <$ pKey "null" + json :: Parser JSON + json = choice + [ Null <$ P.reserved lexer "null" + , Boolean True <$ P.reserved lexer "true" + , Boolean False <$ P.reserved lexer "false" + , Number . either I D <$> naturalOrFloat -- redefined in Text.Parsing + , String . fromMaybe [] . UTF8.decodeM <$> P.stringLiteral lexer + , Array <$> P.brackets lexer (sepBy json (P.comma lexer)) + , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer)) + ] - keyValue :: TokenParser (String, JSON) - keyValue = (,) <$> pString <* pSpec ':' <*> json + keyValue :: Parser (String, JSON) + keyValue = (,) <$> P.stringLiteral lexer <* P.colon lexer <*> json -squareBrackets, curlyBrackets :: String -> String -squareBrackets s = "[" ++ s ++ "]" -curlyBrackets s = "{" ++ s ++ "}" + lexer :: P.TokenParser a + lexer = P.makeTokenParser $ emptyDef + { reservedNames = ["true", "false", "null"] } -------------------------------------------------------- -- JSON-RPC @@ -170,7 +172,7 @@ , requestParams :: JSON , requestId :: JSON } - + data JSON_RPC_Response = Response { responseResult :: JSON , responseError :: JSON @@ -196,7 +198,7 @@ case mj of String s -> return (Request s pj ij) _ -> fail "expecting a string" - + instance InJSON JSON_RPC_Response where toJSON resp = Object [ ("result", responseResult resp) @@ -208,14 +210,14 @@ ej <- lookupM "error" obj ij <- lookupM "id" obj return (Response rj ej ij) - + okResponse :: JSON -> JSON -> JSON_RPC_Response okResponse x y = Response { responseResult = x , responseError = Null , responseId = y } - + errorResponse :: JSON -> JSON -> JSON_RPC_Response errorResponse x y = Response { responseResult = Null @@ -235,10 +237,10 @@ type JSON_RPC_Handler m = String -> JSON -> m JSON -jsonRPC :: (MonadError a m, InJSON a) +jsonRPC :: (MonadError a m, InJSON a) => JSON -> JSON_RPC_Handler m -> m JSON_RPC_Response -jsonRPC input handler = - case fromJSON input of +jsonRPC input handler = + case fromJSON input of Nothing -> return (errorResponse (String "Invalid request") Null) Just req -> do json <- handler (requestMethod req) (requestParams req) @@ -252,25 +254,12 @@ instance Arbitrary JSON where arbitrary = sized arbJSON -instance CoArbitrary JSON where - coarbitrary json = - case json of - Number a -> variant (0 :: Int) . coarbitrary a - String s -> variant (1 :: Int) . coarbitrary s - Boolean b -> variant (2 :: Int) . coarbitrary b - Array xs -> variant (3 :: Int) . coarbitrary xs - Object xs -> variant (4 :: Int) . coarbitrary xs - Null -> variant (5 :: Int) - instance Arbitrary Number where arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary] -instance CoArbitrary Number where - coarbitrary (I n) = variant (0 :: Int) . coarbitrary n - coarbitrary (D d) = variant (1 :: Int) . coarbitrary d arbJSON :: Int -> Gen JSON -arbJSON n - | n == 0 = oneof +arbJSON n + | n == 0 = oneof [ liftM Number arbitrary, liftM String myStringGen , liftM Boolean arbitrary, return Null ] @@ -286,13 +275,13 @@ ] where rec = arbJSON (n `div` 2) - + myStringGen :: Gen String -myStringGen = do +myStringGen = do n <- choose (1, 10) - replicateM n $ oneof $ map return $ + replicateM n $ elements $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] - + propEncoding :: Property -propEncoding = property $ \a -> - parseJSON (show a) == Just a +propEncoding = property $ \a -> + parseJSON (show a) == Right a diff --git a/src/Text/OpenMath/ContentDictionary.hs b/src/Text/OpenMath/ContentDictionary.hs deleted file mode 100644 --- a/src/Text/OpenMath/ContentDictionary.hs +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Text.OpenMath.ContentDictionary - ( -- data types - ContentDictionary(..), VersionNumber, Date - , ContentDictionaryStatus(..), Definition(..) - -- parsing and reading - , readContentDictionary, main, findOCDs - ) where - -import Text.OpenMath.Object (OMOBJ, xml2omobj) -import Text.Scanning (scanInt, Pos(..)) -import Text.XML -import Data.Char -import Data.List -import Data.Maybe -import Control.Monad -import System.Directory - -main :: IO () -main = do - let base = "lib/Dictionaries" - f x = base ++ "/" ++ x - xs <- findOCDs base - cds <- mapM (readContentDictionary . f) xs - let defs = concatMap definitions cds - putStrLn $ show (length cds) ++ " valid dictionaries, with " ++ show (length defs) ++ " definitions" - - -- print [ p | d <- defs, p <- formalProperties d ] - -findOCDs :: String -> IO [FilePath] -findOCDs filepath = do - xs <- getDirectoryContents filepath - return $ filter (".ocd" `isSuffixOf`) xs - -readContentDictionary :: String -> IO ContentDictionary -readContentDictionary filename = do - putStrLn $ "reading " ++ show filename ++ "..." - input <- readFile filename - case parseXML input of - Left s -> err s - Right xml -> do - guard (name xml == "CD") - case buildContentDictionary xml of - Left s -> err s - Right cd -> do - putStrLn $ " found " ++ show (length $ definitions cd) ++ " definition(s)" - return cd - `catch` (err . show) - where - err s = fail $ "Content dictionary not found: " ++ s - -buildContentDictionary :: XML -> Either String ContentDictionary -buildContentDictionary xml = do - cdname <- extractText "CDName" xml - descr <- extractText "Description" xml - revision <- extractDate "CDDate" xml - review <- extractDate "CDReviewDate" xml - major <- extractInt "CDVersion" xml - minor <- extractInt "CDRevision" xml - theStatus <- extractStatus xml - let theBase = extractText "CDBase" xml - theURL <- extractText "CDURL" xml - defs <- mapM buildDefinition [ d | d <- children xml, name d == "CDDefinition" ] - return CD - { dictionaryName = cdname - , description = descr - , revisionDate = revision - , reviewDate = review - , versionNumber = (major, minor) - , status = theStatus - , base = theBase - , url = theURL - , definitions = defs - } - -buildDefinition :: XML -> Either String Definition -buildDefinition xml = do - theName <- extractText "Name" xml - descr <- extractText "Description" xml - let theRole = extractText "Role" xml - cmps = [ getData a | a <- children xml, name a == "CMP" ] - fmps = [ head xs | a <- children xml, name a == "FMP", let xs=children a, length xs==1 ] - exs = [ children a | a <- children xml, name a == "Example" ] - return Definition - { symbolName = theName - , symbolDescription = descr - , role = theRole - , commentedProperties = cmps - , formalProperties = map (either error id . xml2omobj) fmps - , examples = exs - } - -extractDate :: String -> XML -> Either String Date -extractDate s xml = do - txt <- extractText s xml - case txt of - [y1,y2,y3,y4,'-',m1,m2,'-',d1,d2] | all isDigit [y1,y2,y3,y4,m1,m2,d1,d2] -> - return (read [y1,y2,y3,y4], read [m1,m2], read [d1,d2]) - _ -> fail ("invalid date (YYYY-MM-DD): " ++ txt) - -extractInt :: String -> XML -> Either String Int -extractInt s xml = do - txt <- extractText s xml - case scanInt (Pos 0 0) txt of - Just (i, _, rest) | all isSpace rest - -> return i - _ -> fail "Not an int" - -extractStatus :: XML -> Either String ContentDictionaryStatus -extractStatus xml = do - txt <- extractText "CDStatus" xml - let (hd, tl) = splitAt 1 txt - list = [Official, Experimental, Private, Obsolete] - table = [ (show s, s) | s <- list ] - case lookup (map toUpper hd ++ map toLower tl) table of - Just hd -> return hd - _ -> fail "Unknown status" - -extractText :: MonadPlus m => String -> XML -> m String -extractText s xml = do - a <- findChild s xml - guard (null $ children a) - return (getData a) - -data ContentDictionary = CD - { dictionaryName :: String - , description :: String - , revisionDate :: Date - , reviewDate :: Date - , versionNumber :: VersionNumber - , status :: ContentDictionaryStatus - , base :: Maybe String - , url :: String - , definitions :: [Definition] - } deriving Show - -type VersionNumber = (Int, Int) -- major and minor part -type Date = (Int, Int, Int) -- YYYY-MM-DD - -data ContentDictionaryStatus = Official | Experimental | Private | Obsolete - deriving Show - -data Definition = Definition - { symbolName :: String - , symbolDescription :: String - , role :: Maybe String - , commentedProperties :: [String] - , formalProperties :: [OMOBJ] - , examples :: [[XML]] - } - deriving Show diff --git a/src/Text/OpenMath/Dictionary/Arith1.hs b/src/Text/OpenMath/Dictionary/Arith1.hs --- a/src/Text/OpenMath/Dictionary/Arith1.hs +++ b/src/Text/OpenMath/Dictionary/Arith1.hs @@ -76,5 +76,4 @@ multiplication e.g. an integral interval, the second being the function to be multiplied. Note that the product may be over an infinite interval. -} productSymbol :: Symbol -productSymbol = makeSymbol "arith1" "product" - +productSymbol = makeSymbol "arith1" "product" diff --git a/src/Text/OpenMath/Dictionary/Calculus1.hs b/src/Text/OpenMath/Dictionary/Calculus1.hs --- a/src/Text/OpenMath/Dictionary/Calculus1.hs +++ b/src/Text/OpenMath/Dictionary/Calculus1.hs @@ -33,5 +33,4 @@ It takes two arguments; the first being the range (e.g. a set) of integration, and the second the function. -} defintSymbol :: Symbol -defintSymbol = makeSymbol "calculus1" "defint" - +defintSymbol = makeSymbol "calculus1" "defint" diff --git a/src/Text/OpenMath/Dictionary/Fns1.hs b/src/Text/OpenMath/Dictionary/Fns1.hs --- a/src/Text/OpenMath/Dictionary/Fns1.hs +++ b/src/Text/OpenMath/Dictionary/Fns1.hs @@ -70,5 +70,4 @@ a list of variables, and the second of which is an expression, and it forms the function which is the lambda extraction of the expression -} lambdaSymbol :: Symbol -lambdaSymbol = makeSymbol "fns1" "lambda" - +lambdaSymbol = makeSymbol "fns1" "lambda" diff --git a/src/Text/OpenMath/Dictionary/Linalg2.hs b/src/Text/OpenMath/Dictionary/Linalg2.hs --- a/src/Text/OpenMath/Dictionary/Linalg2.hs +++ b/src/Text/OpenMath/Dictionary/Linalg2.hs @@ -21,5 +21,4 @@ {-| This symbol is an n-ary matrix constructor which requires matrixrow's as arguments. It is used to represent matrices. -} matrixSymbol :: Symbol -matrixSymbol = makeSymbol "linalg2" "matrix" - +matrixSymbol = makeSymbol "linalg2" "matrix" diff --git a/src/Text/OpenMath/Dictionary/List1.hs b/src/Text/OpenMath/Dictionary/List1.hs --- a/src/Text/OpenMath/Dictionary/List1.hs +++ b/src/Text/OpenMath/Dictionary/List1.hs @@ -25,5 +25,4 @@ {-| This symbol denotes the list construct which is an n-ary function. The list entries must be given explicitly. -} listSymbol :: Symbol -listSymbol = makeSymbol "list1" "list" - +listSymbol = makeSymbol "list1" "list" diff --git a/src/Text/OpenMath/Dictionary/Logic1.hs b/src/Text/OpenMath/Dictionary/Logic1.hs --- a/src/Text/OpenMath/Dictionary/Logic1.hs +++ b/src/Text/OpenMath/Dictionary/Logic1.hs @@ -47,5 +47,4 @@ {-| This symbol represents the boolean value false. -} falseSymbol :: Symbol -falseSymbol = makeSymbol "logic1" "false" - +falseSymbol = makeSymbol "logic1" "false" diff --git a/src/Text/OpenMath/Dictionary/Nums1.hs b/src/Text/OpenMath/Dictionary/Nums1.hs --- a/src/Text/OpenMath/Dictionary/Nums1.hs +++ b/src/Text/OpenMath/Dictionary/Nums1.hs @@ -51,5 +51,4 @@ {-| A symbol to convey the notion of not-a-number. The result of an ill-posed floating computation. See IEEE standard for floating point representations. -} naNSymbol :: Symbol -naNSymbol = makeSymbol "nums1" "NaN" - +naNSymbol = makeSymbol "nums1" "NaN" diff --git a/src/Text/OpenMath/Dictionary/Quant1.hs b/src/Text/OpenMath/Dictionary/Quant1.hs --- a/src/Text/OpenMath/Dictionary/Quant1.hs +++ b/src/Text/OpenMath/Dictionary/Quant1.hs @@ -19,5 +19,4 @@ argument is the bound variables (placed within an OMBVAR element), and the second is an expression. -} existsSymbol :: Symbol -existsSymbol = makeSymbol "quant1" "exists" - +existsSymbol = makeSymbol "quant1" "exists" diff --git a/src/Text/OpenMath/Dictionary/Relation1.hs b/src/Text/OpenMath/Dictionary/Relation1.hs --- a/src/Text/OpenMath/Dictionary/Relation1.hs +++ b/src/Text/OpenMath/Dictionary/Relation1.hs @@ -41,5 +41,4 @@ {-| This symbol is used to denote the approximate equality of its two arguments. -} approxSymbol :: Symbol -approxSymbol = makeSymbol "relation1" "approx" - +approxSymbol = makeSymbol "relation1" "approx" diff --git a/src/Text/OpenMath/Dictionary/Transc1.hs b/src/Text/OpenMath/Dictionary/Transc1.hs --- a/src/Text/OpenMath/Dictionary/Transc1.hs +++ b/src/Text/OpenMath/Dictionary/Transc1.hs @@ -146,5 +146,4 @@ {-| This symbol represents the arccoth function as described in Abramowitz and Stegun, section 4.6. -} arccothSymbol :: Symbol -arccothSymbol = makeSymbol "transc1" "arccoth" - +arccothSymbol = makeSymbol "transc1" "arccoth" diff --git a/src/Text/OpenMath/FMP.hs b/src/Text/OpenMath/FMP.hs --- a/src/Text/OpenMath/FMP.hs +++ b/src/Text/OpenMath/FMP.hs @@ -1,53 +1,53 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Formal mathematical properties (FMP) --- ------------------------------------------------------------------------------ -module Text.OpenMath.FMP where - -import Data.List (union) -import Text.OpenMath.Object -import Text.OpenMath.Symbol -import Text.OpenMath.Dictionary.Quant1 (forallSymbol, existsSymbol) -import Text.OpenMath.Dictionary.Relation1 (eqSymbol, neqSymbol) - -data FMP = FMP - { quantor :: Symbol - , metaVariables :: [String] - , leftHandSide :: OMOBJ - , relation :: Symbol - , rightHandSide :: OMOBJ - } - -toObject :: FMP -> OMOBJ -toObject fmp - | null (metaVariables fmp) = body - | otherwise = - OMBIND (OMS (quantor fmp)) (metaVariables fmp) body - where - body = OMA [OMS (relation fmp), leftHandSide fmp, rightHandSide fmp] - -eqFMP :: OMOBJ -> OMOBJ -> FMP -eqFMP lhs rhs = FMP - { quantor = forallSymbol - , metaVariables = getOMVs lhs `union` getOMVs rhs - , leftHandSide = lhs - , relation = eqSymbol - , rightHandSide = rhs - } - --- | Represents a common misconception. In certain (most) situations, --- the two objects are not the same. -buggyFMP :: OMOBJ -> OMOBJ -> FMP -buggyFMP lhs rhs = (eqFMP lhs rhs) - { quantor = existsSymbol - , relation = neqSymbol +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Formal mathematical properties (FMP) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.FMP where + +import Data.List (union) +import Text.OpenMath.Dictionary.Quant1 (forallSymbol, existsSymbol) +import Text.OpenMath.Dictionary.Relation1 (eqSymbol, neqSymbol) +import Text.OpenMath.Object +import Text.OpenMath.Symbol + +data FMP = FMP + { quantor :: Symbol + , metaVariables :: [String] + , leftHandSide :: OMOBJ + , relation :: Symbol + , rightHandSide :: OMOBJ + } + +toObject :: FMP -> OMOBJ +toObject fmp + | null (metaVariables fmp) = body + | otherwise = + OMBIND (OMS (quantor fmp)) (metaVariables fmp) body + where + body = OMA [OMS (relation fmp), leftHandSide fmp, rightHandSide fmp] + +eqFMP :: OMOBJ -> OMOBJ -> FMP +eqFMP lhs rhs = FMP + { quantor = forallSymbol + , metaVariables = getOMVs lhs `union` getOMVs rhs + , leftHandSide = lhs + , relation = eqSymbol + , rightHandSide = rhs + } + +-- | Represents a common misconception. In certain (most) situations, +-- the two objects are not the same. +buggyFMP :: OMOBJ -> OMOBJ -> FMP +buggyFMP lhs rhs = (eqFMP lhs rhs) + { quantor = existsSymbol + , relation = neqSymbol } diff --git a/src/Text/OpenMath/MakeSymbols.hs b/src/Text/OpenMath/MakeSymbols.hs --- a/src/Text/OpenMath/MakeSymbols.hs +++ b/src/Text/OpenMath/MakeSymbols.hs @@ -1,93 +1,93 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Create symbol definitions from OpenMath content dictionary (ocd) --- ------------------------------------------------------------------------------ -module Text.OpenMath.MakeSymbols where - -import Text.OpenMath.ContentDictionary hiding (main) -import Control.Monad -import Data.Char -import Data.List - -main :: IO () -main = do - let base = "lib/Dictionaries" - target = "src/Text/Openmath/Dictionary" - ocds <- findOCDs base - forM_ ocds $ \s -> do - let modn = target ++ "/" ++ moduleName s ++ ".hs" - txt <- makeSymbols (base ++ "/" ++ s) - putStrLn $ " writing " ++ modn - writeFile modn txt - -moduleName :: String -> String -moduleName s = dropSuffix (map toUpper (take 1 s) ++ drop 1 s) - -dropDir :: String -> String -dropDir s - | '/' `elem` s = dropDir $ drop 1 $dropWhile (/='/') s - | otherwise = s - -dropSuffix :: String -> String -dropSuffix = takeWhile (/='.') - -makeSymbols :: String -> IO String -makeSymbols file = do - cd <- readContentDictionary file - let cdname = dropDir file - return $ unlines $ - [ "-- Automatically generated from content dictionary " ++ cdname ++ ". \ - \ Do not change." - , "module Text.OpenMath.Dictionary." ++ moduleName cdname ++ " where\n" - , "import Text.OpenMath.Symbol\n" - , makeSymbolList cd - ] ++ - map (makeSymbol (dropSuffix cdname)) (definitions cd) - -symbolIdentifier :: Definition -> String -symbolIdentifier d = f (symbolName d) ++ "Symbol" - where f xs = map toLower (take 1 xs) ++ camelCase (drop 1 xs) - -camelCase :: String -> String -camelCase [] = [] -camelCase ('_':x:xs) = toUpper x : camelCase xs -camelCase (x:xs) = x : camelCase xs - -makeSymbolList :: ContentDictionary -> String -makeSymbolList cd = unlines - [ "-- | List of symbols defined in " ++ dictionaryName cd ++ " dictionary" - , name ++ " :: [Symbol]" - , name ++ " = [" ++ concat (intersperse ", " list) ++ "]" - ] - where - name = dictionaryName cd ++ "List" - list = map symbolIdentifier (definitions cd) - -makeSymbol :: String -> Definition -> String -makeSymbol dict def = unlines $ - makeComment 80 (symbolDescription def) ++ - [ name ++ " :: Symbol" - , name ++ " = makeSymbol " ++ show dict ++ " " ++ show (symbolName def) - ] - where - name = symbolIdentifier def - -makeComment :: Int -> String -> [String] -makeComment n = breaks . comment . words - where - comment xs = ["{-|"] ++ xs ++ ["-}"] - accLength = scanl (\n -> (+n) . succ . length) 0 - breaks xs - | null xs = [] - | otherwise = - case break ((>=n) . fst) (zip (drop 1 (accLength xs)) xs) of +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Create symbol definitions from OpenMath content dictionary (ocd) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.MakeSymbols where + +import Control.Monad +import Data.Char +import Data.List +import Text.OpenMath.ContentDictionary hiding (main) + +main :: IO () +main = do + let base = "lib/Dictionaries" + target = "src/Text/Openmath/Dictionary" + ocds <- findOCDs base + forM_ ocds $ \s -> do + let modn = target ++ "/" ++ moduleName s ++ ".hs" + txt <- makeSymbols (base ++ "/" ++ s) + putStrLn $ " writing " ++ modn + writeFile modn txt + +moduleName :: String -> String +moduleName s = dropSuffix (map toUpper (take 1 s) ++ drop 1 s) + +dropDir :: String -> String +dropDir s + | '/' `elem` s = dropDir $ drop 1 $dropWhile (/='/') s + | otherwise = s + +dropSuffix :: String -> String +dropSuffix = takeWhile (/='.') + +makeSymbols :: String -> IO String +makeSymbols file = do + cd <- readContentDictionary file + let cdname = dropDir file + return $ unlines $ + [ "-- Automatically generated from content dictionary " ++ cdname ++ ". \ + \ Do not change." + , "module Text.OpenMath.Dictionary." ++ moduleName cdname ++ " where\n" + , "import Text.OpenMath.Symbol\n" + , makeSymbolList cd + ] ++ + map (makeSymbol (dropSuffix cdname)) (definitions cd) + +symbolIdentifier :: Definition -> String +symbolIdentifier d = f (symbolName d) ++ "Symbol" + where f xs = map toLower (take 1 xs) ++ camelCase (drop 1 xs) + +camelCase :: String -> String +camelCase [] = [] +camelCase ('_':x:xs) = toUpper x : camelCase xs +camelCase (x:xs) = x : camelCase xs + +makeSymbolList :: ContentDictionary -> String +makeSymbolList cd = unlines + [ "-- | List of symbols defined in " ++ dictionaryName cd ++ " dictionary" + , name ++ " :: [Symbol]" + , name ++ " = [" ++ intercalate ", " list ++ "]" + ] + where + name = dictionaryName cd ++ "List" + list = map symbolIdentifier (definitions cd) + +makeSymbol :: String -> Definition -> String +makeSymbol dict def = unlines $ + makeComment 80 (symbolDescription def) ++ + [ name ++ " :: Symbol" + , name ++ " = makeSymbol " ++ show dict ++ " " ++ show (symbolName def) + ] + where + name = symbolIdentifier def + +makeComment :: Int -> String -> [String] +makeComment n = breaks . comment . words + where + comment xs = ["{-|"] ++ xs ++ ["-}"] + accLength = scanl (\n -> (+n) . succ . length) 0 + breaks xs + | null xs = [] + | otherwise = + case break ((>=n) . fst) (zip (drop 1 (accLength xs)) xs) of (as, bs) -> unwords (map snd as) : breaks (map snd bs) 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,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -10,25 +10,24 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- -module Text.OpenMath.Object +module Text.OpenMath.Object ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml ) where -import Data.Char (isSpace) -import Data.Generics.Uniplate hiding (children) +import Data.Char +import Data.Generics.Uniplate.Direct hiding (children) import Data.List (nub) import Data.Maybe import Data.Typeable import Text.OpenMath.Symbol -import Text.Scanning (scanInt, scanNumber, Pos(..)) import Text.XML -- internal representation for OpenMath objects -data OMOBJ = OMI Integer - | OMF Double - | OMV String - | OMS Symbol - | OMA [OMOBJ] +data OMOBJ = OMI Integer + | OMF Double + | OMV String + | OMS Symbol + | OMA [OMOBJ] | OMBIND OMOBJ [String] OMOBJ deriving (Show, Eq, Typeable) @@ -39,51 +38,49 @@ instance Uniplate OMOBJ where uniplate omobj = case omobj of - OMA xs -> (xs, OMA) - OMBIND a ss b -> ([a, b], \[x, y] -> OMBIND x ss y) - _ -> ([], \_ -> omobj) + OMA xs -> plate OMA ||* xs + OMBIND a ss b -> plate OMBIND |* a |- ss |* b + _ -> plate omobj getOMVs :: OMOBJ -> [String] getOMVs omobj = nub [ x | OMV x <- universe omobj ] ---------------------------------------------------------- -- conversion functions: XML <-> OMOBJ - + xml2omobj :: XML -> Either String OMOBJ xml2omobj xmlTop = - case xmlTop of + case xmlTop of Element "OMOBJ" _ [Right e] -> rec e _ -> fail $ "expected an OMOBJ tag" ++ show xmlTop where rec xml = case content xml of - + _ | name xml == "OMA" -> do - ys <- mapM rec (children xml) + ys <- mapM rec (children xml) return (OMA ys) - + [] | name xml == "OMS" -> do let mcd = findAttribute "cd" xml n <- findAttribute "name" xml - return (OMS (Symbol mcd n)) + return (OMS (mcd, n)) [Left s] | name xml == "OMI" -> - case scanInt (Pos 0 0) s of - Just (i, _, rest) | all isSpace rest - -> return (OMI (toInteger i)) - _ -> fail "invalid integer in OMI" - + case readInt s of + Just i -> return (OMI (toInteger i)) + _ -> fail "invalid integer in OMI" + [] | name xml == "OMF" -> do - s <- findAttribute "dec" xml - case scanNumber (Pos 0 0) s of - Just (nr, _, rest) | all isSpace rest - -> return (OMF (either fromIntegral id nr)) - _ -> fail "invalid floating-point in OMF" - + s <- findAttribute "dec" xml + case readDouble s of + Just nr -> return (OMF nr) + _ -> fail "invalid floating-point in OMF" + [] | name xml == "OMV" -> do s <- findAttribute "name" xml return (OMV s) - + [Right x1, Right x2, Right x3] | name xml == "OMBIND" -> do y1 <- rec x1 y2 <- recOMBVAR x2 @@ -91,15 +88,15 @@ return (OMBIND y1 y2 y3) _ -> fail ("invalid tag " ++ show (name xml)) - + recOMBVAR xml | name xml == "OMBVAR" = let f (Right (OMV s)) = return s f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this in mapM (f . rec) (children xml) - | otherwise = + | otherwise = fail ("expected tag OMVAR, but found " ++ show (name xml)) - + omobj2xml :: OMOBJ -> XML omobj2xml object = makeXML "OMOBJ" $ do "xmlns" .=. "http://www.openmath.org/OpenMath" @@ -116,7 +113,17 @@ OMS s -> element "OMS" $ do "cd" .=. fromMaybe "unknown" (dictionary s) "name" .=. symbolName s - OMBIND x ys z -> element "OMBIND" $ do - rec x - element "OMBVAR" (mapM_ (rec . OMV) ys) - rec z + OMBIND x ys z -> element "OMBIND" $ do + rec x + element "OMBVAR" (mapM_ (rec . OMV) ys) + rec z + +readInt :: String -> Maybe Integer +readInt s = case reads s of + [(n, xs)] | all isSpace xs -> Just n + _ -> Nothing + +readDouble :: String -> Maybe Double +readDouble s = case reads s of + [(n, xs)] | all isSpace xs -> Just n + _ -> Nothing diff --git a/src/Text/OpenMath/Symbol.hs b/src/Text/OpenMath/Symbol.hs --- a/src/Text/OpenMath/Symbol.hs +++ b/src/Text/OpenMath/Symbol.hs @@ -1,33 +1,35 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Text.OpenMath.Symbol where - -data Symbol = Symbol - { dictionary :: Maybe String - , symbolName :: String - } - deriving (Eq, Ord) - -instance Show Symbol where - show s = maybe "" (++".") (dictionary s) ++ symbolName s - -instance Read Symbol where - readsPrec _ s = - case break (=='.') s of - (xs,_:ys) -> [(makeSymbol xs ys, "")] - _ -> [(extraSymbol s, "")] - -makeSymbol :: String -> String -> Symbol -makeSymbol = Symbol . Just - -extraSymbol :: String -> Symbol -extraSymbol = Symbol Nothing +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Symbol where + +type Symbol = (Maybe String, String) + +-- * Constructor functions + +makeSymbol :: String -> String -> Symbol +makeSymbol = (,) . Just + +extraSymbol :: String -> Symbol +extraSymbol = (,) Nothing + +-- * Selector functions + +dictionary :: Symbol -> Maybe String +dictionary = fst + +symbolName :: Symbol -> String +symbolName = snd + +-- * Utility function + +showSymbol :: Symbol -> String +showSymbol s = maybe "" (++".") (dictionary s) ++ symbolName s diff --git a/src/Text/OpenMath/Tests.hs b/src/Text/OpenMath/Tests.hs --- a/src/Text/OpenMath/Tests.hs +++ b/src/Text/OpenMath/Tests.hs @@ -1,50 +1,50 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ -module Text.OpenMath.Tests (propEncoding) where - -import Control.Monad -import Text.OpenMath.Object -import Test.QuickCheck -import Text.OpenMath.Dictionary.Arith1 -import Text.OpenMath.Dictionary.Calculus1 -import Text.OpenMath.Dictionary.Fns1 -import Text.OpenMath.Dictionary.Linalg2 -import Text.OpenMath.Dictionary.List1 -import Text.OpenMath.Dictionary.Logic1 -import Text.OpenMath.Dictionary.Nums1 -import Text.OpenMath.Dictionary.Quant1 -import Text.OpenMath.Dictionary.Relation1 -import Text.OpenMath.Dictionary.Transc1 - -arbOMOBJ :: Gen OMOBJ -arbOMOBJ = sized rec - where - symbols = arith1List ++ calculus1List ++ fns1List ++ linalg2List ++ - list1List ++ logic1List ++ nums1List ++ quant1List ++ - relation1List ++ transc1List - - rec 0 = frequency - [ (1, liftM OMI arbitrary) - , (1, liftM OMF arbitrary) - , (1, liftM OMV arbitrary) - , (5, oneof $ map (return . OMS) symbols) - ] - rec n = frequency - [ (1, rec 0) - , (3, choose (1,4) >>= liftM OMA . (`replicateM` f)) - , (1, liftM3 OMBIND f arbitrary f) - ] - where - f = rec (n `div` 2) - -propEncoding :: Property +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Tests (propEncoding) where + +import Control.Monad +import Test.QuickCheck +import Text.OpenMath.Dictionary.Arith1 +import Text.OpenMath.Dictionary.Calculus1 +import Text.OpenMath.Dictionary.Fns1 +import Text.OpenMath.Dictionary.Linalg2 +import Text.OpenMath.Dictionary.List1 +import Text.OpenMath.Dictionary.Logic1 +import Text.OpenMath.Dictionary.Nums1 +import Text.OpenMath.Dictionary.Quant1 +import Text.OpenMath.Dictionary.Relation1 +import Text.OpenMath.Dictionary.Transc1 +import Text.OpenMath.Object + +arbOMOBJ :: Gen OMOBJ +arbOMOBJ = sized rec + where + symbols = arith1List ++ calculus1List ++ fns1List ++ linalg2List ++ + list1List ++ logic1List ++ nums1List ++ quant1List ++ + relation1List ++ transc1List + + rec 0 = frequency + [ (1, liftM OMI arbitrary) + , (1, liftM (\n -> OMF (fromInteger n / 1000)) arbitrary) + , (1, liftM OMV arbitrary) + , (5, elements $ map OMS symbols) + ] + rec n = frequency + [ (1, rec 0) + , (3, choose (1,4) >>= liftM OMA . (`replicateM` f)) + , (1, liftM3 OMBIND f arbitrary f) + ] + where + f = rec (n `div` 2) + +propEncoding :: Property propEncoding = forAll arbOMOBJ $ \x -> xml2omobj (omobj2xml x) == Right x diff --git a/src/Text/Parsing.hs b/src/Text/Parsing.hs --- a/src/Text/Parsing.hs +++ b/src/Text/Parsing.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -9,230 +8,111 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- A simplified interface to the UU.Parsing library. +-- Utility functions for parsing with Parsec library -- ----------------------------------------------------------------------------- -module Text.Parsing - ( -- * Scaning - module Text.Scanning - -- * Parsing - , Parser, CharParser, TokenParser - , parse, parseWith, parseWithM - -- * Primitive token parsers - , pVarid, pConid, pOpid, pQVarid, pQConid - , pKey, pSpec, pInt, pReal, pString - -- * Derived token parsers - , pParens, pBracks, pCurly, pCommas, pLines, pInteger - -- * UU parser combinators - , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1, pSepList - , pChainl, pChainr, pChoice, pFail - -- * Operator table (parser) - , OperatorTable, Associativity(..), pOperators +module Text.Parsing + ( module Export + , (<*>), (*>), (<*), (<$>), (<$), (<**>) + , parseSimple, complete, skip, (<..>), ranges, stopOn + , naturalOrFloat, float + , UnbalancedError(..), balanced ) where -import Data.Maybe -import Text.Scanning -import qualified UU.Parsing as UU - ----------------------------------------------------------- --- Parsing - --- | Abstract data type for a parser, where @s@ is the symbol type, and @a@ is --- the result type. This data type is an instance of the @IsParser@ type class --- defined in the UU libraries. -newtype Parser s a = P { unP :: UU.AnaParser [s] UU.Pair s (Maybe s) a } +import Control.Applicative hiding ((<|>)) +import Control.Arrow +import Data.Char +import Data.List +import Text.ParserCombinators.Parsec as Export +import Text.ParserCombinators.Parsec.Expr as Export +import Text.ParserCombinators.Parsec.Language as Export +import Text.ParserCombinators.Parsec.Pos --- | A parser with characters as symbol type -type CharParser = Parser Char +parseSimple :: Parser a -> String -> Either String a +parseSimple p = left show . runParser (complete p) () "" --- | A parser with tokens as symbol type -type TokenParser = Parser Token +complete :: Parser a -> Parser a +complete p = spaces *> (p <* eof) -instance (UU.Symbol s, Ord s) => UU.IsParser (Parser s) s where - ~(P p) <*> ~(P q) = P (p UU.<*> q) - ~(P p) <* ~(P q) = P (p UU.<* q) - ~(P p) *> ~(P q) = P (p UU.*> q) - ~(P p) <|> ~(P q) = P (p UU.<|> q) - a <$> ~(P p) = P (a UU.<$> p) - a <$ ~(P p) = P (a UU.<$ p) - pSucceed = P . UU.pSucceed - pFail = P UU.pFail - pLow = P . UU.pLow - pSym = P . UU.pSym - pRange a = P . UU.pRange a - pCostRange a b = P . UU.pCostRange a b - pCostSym a b = P . UU.pCostSym a b - getfirsts = UU.getfirsts . unP - setfirsts e = P . UU.setfirsts e . unP - getzerop = fmap P . UU.getzerop . unP - getonep = fmap P . UU.getonep . unP +skip :: Parser a -> Parser () +skip p = p >> return () -parse :: UU.Symbol s => Parser s a -> [s] -> Either (Maybe s) a -parse (P p) input = - case messages of - [] -> Right result - UU.Msg _ ms _:_ -> Left ms +-- Like the combinator from parser, except that for doubles +-- the read instance is used. This is a more precies representation +-- of the double (e.g., 1.413 is not 1.413000000001). +naturalOrFloat :: Parser (Either Integer Double) +naturalOrFloat = do + a <- num + b <- option "" ((:) <$> char '.' <*> nat) + c <- option "" ((:) <$> oneOf "eE" <*> num) + spaces + case reads (a++b++c) of + _ | null b && null c -> + case a of + '-':xs -> return (Left (negate (readInt xs))) + xs -> return (Left (readInt xs)) + [(d, [])] -> return (Right d) + _ -> fail "not a float" where - steps = UU.parse p input - messages = UU.getMsgs steps - result = (\(UU.Pair a _) -> a) (UU.evalSteps steps) - -parseWith :: Scanner -> TokenParser a -> String -> Either SyntaxError a -parseWith scanner p = either f Right . parse p . scanWith scanner - where - f (Just s) = Left (Unexpected s) - f Nothing = Left (ErrorMessage "Syntax error") - -parseWithM :: Monad m => Scanner -> TokenParser a -> String -> m a -parseWithM scanner p = either (fail . show) return . parseWith scanner p - ----------------------------------------------------------- --- Primitive token parsers - -pVarid, pConid, pOpid :: TokenParser String -pQVarid, pQConid :: TokenParser (String, String) -pString :: TokenParser String -pInt :: TokenParser Int -pReal :: TokenParser Double - -pKey :: String -> TokenParser String -pSpec :: Char -> TokenParser Char - -pVarid = makeTokS isTokenVarId TokenVarId -pConid = makeTokS isTokenConId TokenConId -pOpid = makeTokS isTokenOpId TokenOpId -pQVarid = makeTokT isTokenQVarId TokenQVarId -pQConid = makeTokT isTokenQConId TokenQConId -pString = makeTokS isTokenString TokenString -pInt = makeTokN isTokenInt TokenInt -pReal = makeTokR isTokenReal TokenReal -pKey = makeTokA TokenKeyword -pSpec = makeTokA TokenSpecial - --- helpers -makeTokS :: (Token -> Maybe a) -> (String -> Pos -> Token) -> TokenParser a -makeTokS f con = makeTok (fromJust . f) (con minString) (con maxString) - -makeTokT :: (Token -> Maybe a) -> (String -> String -> Pos -> Token) -> TokenParser a -makeTokT f con = makeTok (fromJust . f) (con minString minString) (con maxString maxString) - -makeTokN :: (Token -> Maybe Int) -> (Int -> Pos -> Token) -> TokenParser Int -makeTokN f con = makeTok (fromJust . f) (con minBound) (con maxBound) - -makeTokR :: (Token -> Maybe Double) -> (Double -> Pos -> Token) -> TokenParser Double -makeTokR f con = makeTok (fromJust . f) (con (-d)) (con d) - where d = (10 :: Double) ^ (500 :: Int) - -makeTokA :: (a -> Pos -> Token) -> a -> TokenParser a -makeTokA con a = makeTok (const a) (con a) (con a) - -makeTok :: (Token -> a) -> (Pos -> Token) -> (Pos -> Token) -> TokenParser a -makeTok f con1 con2 = - f UU.<$> con1 minPos UU.<..> con2 maxPos - -minPos, maxPos :: Pos -minPos = Pos minBound minBound -maxPos = Pos maxBound maxBound - -minString, maxString :: String -minString = [] -maxString = replicate 100 maxBound - ----------------------------------------------------------- --- Derived token parsers - -pParens, pBracks, pCurly :: TokenParser a -> TokenParser a -pParens p = pSpec '(' UU.*> p UU.<* pSpec ')' -pBracks p = pSpec '[' UU.*> p UU.<* pSpec ']' -pCurly p = pSpec '{' UU.*> p UU.<* pSpec '}' - -pCommas :: TokenParser a -> TokenParser [a] -pCommas p = optional ((:) <$> p <*> pList ((\_ a -> a) <$> pSpec ',' <*> p)) [] + nat = many1 digit + num = maybe id (:) <$> optionMaybe (char '-') <*> nat + readInt = foldl' op 0 -- ' + op a b = a*10+fromIntegral (ord b)-48 --- | Parse lines, separated by the newline character. The boolean argument indicates whether empy lines should --- be accepted or not. Make sure to configure the scanner to treat newlines as special characters! -pLines :: Bool -> TokenParser a -> TokenParser [a] -pLines allowEmptyLine p = catMaybes <$> pn +float :: Parser Double +float = do + a <- nat + b <- option "" ((:) <$> char '.' <*> nat) + c <- option "" ((:) <$> oneOf "eE" <*> num) + case reads (a++b++c) of + [(d, [])] -> return d + _ -> fail "not a float" where - pOne | allowEmptyLine = optional (Just <$> p) Nothing - | otherwise = Just <$> p - pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne) - -pInteger :: TokenParser Integer -pInteger = fromIntegral <$> pInt - ----------------------------------------------------------- --- UU parser combinators - -infixl 3 <|> -infixl 4 <$>, <$, <*>, <*, *> - -(<$>) :: (Ord s, UU.Symbol s) => (a -> b) -> Parser s a -> Parser s b -(<$>) = (UU.<$>) - -(<$) :: (Ord s, UU.Symbol s) => a -> Parser s b -> Parser s a -(<$) = (UU.<$) - -(<*>) :: (Ord s, UU.Symbol s) => Parser s (a -> b) -> Parser s a -> Parser s b -(<*>) = (UU.<*>) - -(*>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s b -(*>) = (UU.*>) - -(<*) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s a -(<*) = (UU.<*) - -(<|>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s a -> Parser s a -(<|>) = (UU.<|>) - -optional :: (Ord s, UU.Symbol s) => Parser s a -> a -> Parser s a -optional = UU.opt - -pList, pList1 :: (Ord s, UU.Symbol s) => Parser s a -> Parser s [a] -pList = UU.pList -pList1 = UU.pList1 - -pSepList :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s [a] -pSepList p q = (:) <$> p <*> pList (q *> p) - -pChainl, pChainr :: (Ord s, UU.Symbol s) => Parser s (a -> a -> a) -> Parser s a -> Parser s a -pChainl = UU.pChainl -pChainr = UU.pChainr + nat = many1 digit + num = (:) <$> char '-' <*> nat -pChoice :: (Ord s, UU.Symbol s) => [Parser s a] -> Parser s a -pChoice = foldr (<|>) UU.pFail +infix 6 <..> -pFail :: (Ord s, UU.Symbol s) => Parser s a -pFail = UU.pFail +(<..>) :: Char -> Char -> Parser Char +x <..> y = satisfy (\c -> c >= x && c <= y) ----------------------------------------------------------- --- Operator table (parser) +ranges :: [(Char, Char)] -> Parser Char +ranges xs = choice [ a <..> b | (a, b) <- xs ] --- | Type for an operator table. Operators with a low priority should appear in the front of the list. -type OperatorTable a = [(Associativity, [(String, a -> a -> a)])] +-- return in local function f needed for backwards compatibility +stopOn :: [String] -> Parser String +stopOn ys = rec + where + stop = choice (map f ys) + f x = try (string x >> return ' ') + rec = (:) <$ notFollowedBy stop <*> anyChar <*> rec + <|> return [] --- | Data type to express the kind of associativity. The NoMix constructor expresses that the operators --- in the list should not be mixed, but require extra parentheses in the input -data Associativity = LeftAssociative | RightAssociative | NonAssociative | NoMix +-- simple function for finding unbalanced pairs (e.g. parentheses) +balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError +balanced table = run (initialPos "") [] + where + run _ [] [] = Nothing + run _ ((pos, c):_) [] = return (NotClosed pos c) + run pos stack (x:xs) + | x `elem` opens = + run next ((pos, x):stack) xs + | x `elem` closes = + case stack of + (_, y):rest | Just x == lookup y table -> run next rest xs + _ -> return (NotOpened pos x) + | otherwise = + run next stack xs + where + next = updatePosChar pos x --- | Construct a parser using an operator table -pOperators :: OperatorTable a -> TokenParser a -> TokenParser a -pOperators table p = foldr combine p table - where combine (a, ops) q = - case a of - -- The NoMix variant is actually hard to define efficiently. Since we should not mix operators - -- that have the same priority, we have to inspect which operator we are dealing with before - -- we can use the chain combinator. - NoMix -> let make op = flip <$> f op <*> pChainr (f op) q - in flip ($) <$> q <*> optional (pChoice $ map make ops) id - _ -> pChain a (pChoice $ map f ops) q - f (s, g) = g <$ pKey s + (opens, closes) = unzip table +data UnbalancedError = NotClosed SourcePos Char + | NotOpened SourcePos Char --- local helper function -pChain :: (Ord s, UU.Symbol s) => Associativity -> Parser s (a -> a -> a) -> Parser s a -> Parser s a -pChain a p q = case a of - LeftAssociative -> pChainl p q - RightAssociative -> pChainr p q - NonAssociative -> flip ($) <$> q <*> p <*> q - NoMix -> pChainr p q +instance Show UnbalancedError where + show (NotClosed pos c) = + show pos ++ ": Opening symbol " ++ [c] ++ " is not closed" + show (NotOpened pos c) = + show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol" diff --git a/src/Text/Scanning.hs b/src/Text/Scanning.hs deleted file mode 100644 --- a/src/Text/Scanning.hs +++ /dev/null @@ -1,366 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A simple scanner with some configuration facilities --- ------------------------------------------------------------------------------ -module Text.Scanning - ( -- Data types - Pos(..), Token(..) - -- Token selectors - , isTokenConId, isTokenVarId, isTokenOpId, isTokenQConId - , isTokenQVarId, isTokenKeyword, isTokenSpecial - , isTokenString, isTokenInt, isTokenReal, tokenPosition - -- Scanner configuration - , Scanner(..), defaultScanner, specialSymbols - -- Scanning - , scan, scanWith, scanInt, scanNumber - -- Lexical analysis - , SyntaxError(..), checkParentheses, errorPositions - ) where - -import Control.Monad -import Data.List -import Data.Char -import qualified UU.Parsing as UU - ----------------------------------------------------------- --- * Data types - -data Pos = Pos { line :: !Int, column :: !Int } - deriving (Eq, Ord) - --- position field in last position, needed for ranged parsing -data Token - = TokenConId String Pos - | TokenVarId String Pos - | TokenOpId String Pos - | TokenQConId String String Pos - | TokenQVarId String String Pos - | TokenKeyword String Pos - | TokenSpecial Char Pos - | TokenString String Pos - | TokenInt Int Pos - | TokenReal Double Pos - deriving (Eq, Ord) - -instance UU.Symbol Token - -instance Show Pos where - show (Pos l c) = "(" ++ show l ++ "," ++ show c ++ ")" - -instance Show Token where - show token = - case token of - TokenConId s _ -> "identifier " ++ s - TokenVarId s _ -> "identifier " ++ s - TokenOpId s _ -> "operator " ++ s - TokenQConId q s _ -> "identifier " ++ q ++ "." ++ s - TokenQVarId q s _ -> "identifier " ++ q ++ "." ++ s - TokenKeyword s _ -> "keyword " ++ s - TokenSpecial c _ -> "symbol " ++ [c] - TokenString s _ -> "string " ++ show s - TokenInt i _ -> "integer " ++ show i - TokenReal d _ -> "floating-point number " ++ show d - ----------------------------------------------------------- --- * Token selectors - -isTokenConId :: Token -> Maybe String -isTokenConId (TokenConId s _) = Just s -isTokenConId _ = Nothing - -isTokenVarId :: Token -> Maybe String -isTokenVarId (TokenVarId s _) = Just s -isTokenVarId _ = Nothing - -isTokenOpId :: Token -> Maybe String -isTokenOpId (TokenOpId s _) = Just s -isTokenOpId _ = Nothing - -isTokenQConId :: Token -> Maybe (String, String) -isTokenQConId (TokenQConId q s _) = Just (q, s) -isTokenQConId _ = Nothing - -isTokenQVarId :: Token -> Maybe (String, String) -isTokenQVarId (TokenQVarId q s _) = Just (q, s) -isTokenQVarId _ = Nothing - -isTokenKeyword :: Token -> Maybe String -isTokenKeyword (TokenKeyword s _) = Just s -isTokenKeyword _ = Nothing - -isTokenSpecial :: Token -> Maybe Char -isTokenSpecial (TokenSpecial c _) = Just c -isTokenSpecial _ = Nothing - -isTokenString :: Token -> Maybe String -isTokenString (TokenString s _) = Just s -isTokenString _ = Nothing - -isTokenInt :: Token -> Maybe Int -isTokenInt (TokenInt i _) = Just i -isTokenInt _ = Nothing - -isTokenReal :: Token -> Maybe Double -isTokenReal (TokenReal d _) = Just d -isTokenReal _ = Nothing - -tokenPosition :: Token -> Pos -tokenPosition token = - case token of - TokenConId _ p -> p - TokenVarId _ p -> p - TokenOpId _ p -> p - TokenQConId _ _ p -> p - TokenQVarId _ _ p -> p - TokenKeyword _ p -> p - TokenSpecial _ p -> p - TokenString _ p -> p - TokenInt _ p -> p - TokenReal _ p -> p - ----------------------------------------------------------- --- * Scanner configuration - --- | Data type to configure a scanner -data Scanner = Scanner - { keywords :: [String] - , keywordOperators :: [String] - , isIdentifierCharacter :: Char -> Bool - , specialCharacters :: String - , operatorCharacters :: String - , unaryMinus :: Bool - , qualifiedIdentifiers :: Bool - } - --- | A default scanner configuration (using Haskell's special characters) -defaultScanner :: Scanner -defaultScanner = Scanner - { keywords = [] - , keywordOperators = [] - , isIdentifierCharacter = \c -> isAlphaNum c || c `elem` "_'" - , specialCharacters = "(),;[]`{}" -- Haskell's special characters - , operatorCharacters = "!#$%&*+./<=>?@\\^|-~" -- The non-special characters - , unaryMinus = False - , qualifiedIdentifiers = False - } - --- | Add characters to the list of special characters (and remove these from the list of operator characters) -specialSymbols :: String -> Scanner -> Scanner -specialSymbols cs scanner = scanner - { specialCharacters = specialCharacters scanner `union` cs } - ----------------------------------------------------------- --- * Scanning - --- | Scan an input string with the default scanner configuration -scan :: String -> [Token] -scan = scanWith defaultScanner - -scanWith :: Scanner -> String -> [Token] -scanWith scanner = rec (Pos 1 1) - where - rec :: Pos -> String -> [Token] - rec _ [] = [] - rec pos input@(x:rest) - | isSpace x = - let newp = advance [x] pos - in if x `elem` specialCharacters scanner - then TokenSpecial x pos : rec newp rest - else rec newp rest - | isAlpha x = - case scanIdentifier scanner input of - Just (Just q, s, xs) - | isLower (head s) -> make TokenQVarId - | otherwise -> make TokenQConId - where - make f = f q s pos : rec newp xs - newp = incr (length q + length s + 1) pos - Just (Nothing, s, xs) - | s `elem` keywords scanner -> make TokenKeyword - | isLower (head s) -> make TokenVarId - | otherwise -> make TokenConId - where - make f = f s pos : rec newp xs - newp = incr (length s) pos - _ -> error "unexpected case in scanner" - | isNum input = - case scanNumber pos input of - Just (Left i, newp, xs) -> TokenInt i pos : rec newp xs - Just (Right d, newp, xs) -> TokenReal d pos : rec newp xs - _ -> error "unexpected case in scanner" - | x == '"' = - case scanString pos rest of - Just (s, newp, xs) -> - TokenString s pos : rec newp xs - Nothing -> - TokenSpecial x pos : rec (incr 1 pos) rest - | x `elem` specialCharacters scanner = - let newp = incr 1 pos - in if [x] `elem` keywordOperators scanner - then TokenKeyword [x] pos : rec newp rest - else TokenSpecial x pos : rec newp rest - | x `elem` operatorCharacters scanner = - let (xs, ys) = break stop rest - newp = incr (length (x:xs)) pos - stop c = c `elem` specialCharacters scanner - || c `notElem` operatorCharacters scanner - in if (x:xs) `elem` keywordOperators scanner - then TokenKeyword (x:xs) pos : rec newp ys - else TokenOpId (x:xs) pos : rec newp ys - | otherwise = - let newp = incr 1 pos - in TokenSpecial x pos : rec newp rest - - isNum :: String -> Bool - isNum ('-':x:_) = isDigit x && unaryMinus scanner - isNum (x:_) = isDigit x - isNum _ = False - -scanIdentifier :: Scanner -> String -> Maybe (Maybe String, String, String) -scanIdentifier scanner (x:rest) | isAlpha x = - case span (isIdentifierCharacter scanner) rest of - (xs, '.':y:rest2) | qualifiedIdentifiers scanner && isAlpha y -> - let (ys, zs) = span (isIdentifierCharacter scanner) rest2 - in Just (Just (x:xs), y:ys, zs) - (xs, ys) -> - Just (Nothing, x:xs, ys) -scanIdentifier _ _ = Nothing - -scanNumber :: Pos -> String -> Maybe (Either Int Double, Pos, String) -scanNumber pos input = do - (i, p, xs) <- scanInt pos input - case fractionPart p xs of - Just (p1, ys) -> - case powerPart p1 ys of - Just (p2, zs) -> - let txt = take (column p2 - column pos) input - in return (Right (read txt), p2, zs) - Nothing -> - let txt = take (column p1 - column pos) input - in return (Right (read txt), p1, ys) - Nothing -> - case powerPart p xs of - Just (p1, ys) -> - let txt = take (column p1 - column pos) input - in return (Right (read txt), p1, ys) - Nothing -> - return (Left i, p, xs) - -fractionPart :: Pos -> String -> Maybe (Pos, String) -fractionPart pos ('.':rest) = do - (_, p, ys) <- scanNatural pos rest - return (incr 1 p, ys) -fractionPart _ _ = Nothing - -powerPart :: Pos -> String -> Maybe (Pos, String) -powerPart pos (s:rest) | s `elem` "eE" = do - (_, p, ys) <- scanInt pos rest - return (incr 1 p, ys) -powerPart _ _ = Nothing - -scanInt :: Pos -> String -> Maybe (Int, Pos, String) -scanInt pos ('-':xs) = - do (nat, p, rest) <- scanNatural pos xs - return (-nat, incr 1 p, rest) -scanInt pos xs = - scanNatural pos xs - -scanNatural :: Pos -> String -> Maybe (Int, Pos, String) -scanNatural pos input = do - let (xs, ys) = span isDigit input - guard (not (null xs)) - let nat = foldl' (\a b -> a*10+ord b-48) 0 xs - return (nat, incr (length xs) pos, ys) - -scanString :: Pos -> String -> Maybe (String, Pos, String) -scanString pos input = - case input of - [] -> Nothing - '\\':x:xs -> add x (scanString (incr 2 pos) xs) - '"':xs -> Just ("",incr 1 pos,xs) - x:xs -> add x (scanString (incr 1 pos) xs) - where - add c = fmap (\(s, np, t) -> (c:s, np, t)) - -advance :: String -> Pos -> Pos -advance [] = id -advance (x:xs) - | x == '\n' = advance xs . nextline - | otherwise = advance xs . incr 1 - -incr :: Int -> Pos -> Pos -incr i p = p { column = column p + i } - -nextline :: Pos -> Pos -nextline p = p { line = line p + 1, column = 1 } - ------------------------------------------------------------ ---- Lexical analysis - -data SyntaxError - = Unexpected Token - | ParNotClosed Token - | ParNoOpen Token - | ParMismatch Token Token - | ErrorMessage String - -instance Show SyntaxError where - show err = prefixPosition err ++ - case err of - Unexpected t -> "Unexpected " ++ show t - ParNotClosed t -> "Opening parenthesis " ++ show t ++ " is not closed" - ParNoOpen t -> "Closing parenthesis " ++ show t ++ " has no matching symbol" - ParMismatch t1 t2 -> "Opening parenthesis " ++ show t1 ++ " is closed with " ++ show t2 - ErrorMessage msg -> msg - -prefixPosition :: SyntaxError -> String -prefixPosition err - | null xs = "" - | otherwise = concat (intersperse "," xs) ++ ": " - where - xs = map show (errorPositions err) - -errorPositions :: SyntaxError -> [Pos] -errorPositions err = - case err of - Unexpected t -> [tokenPosition t] - ParNotClosed t -> [tokenPosition t] - ParNoOpen t -> [tokenPosition t] - ParMismatch t1 t2 -> [tokenPosition t1, tokenPosition t2] - ErrorMessage _ -> [] - -checkParentheses :: [Token] -> Maybe SyntaxError -checkParentheses = rec [] - where - rec [] [] = Nothing - rec (t:_) [] = Just (ParNotClosed t) - rec stack (t:ts) - | isOpening t = - rec (t:stack) ts - | isClosing t = - case stack of - [] -> Just (ParNoOpen t) - x:xs - | match x t -> rec xs ts - | otherwise -> Just (ParMismatch x t) - | otherwise = - rec stack ts - -isOpening, isClosing :: Token -> Bool -isOpening (TokenSpecial ('(') _) = True -isOpening _ = False -isClosing (TokenSpecial (')') _) = True -isClosing _ = False - -match :: Token -> Token -> Bool -match (TokenSpecial ('(') _) (TokenSpecial (')') _) = True -match _ _ = False diff --git a/src/Text/UTF8.hs b/src/Text/UTF8.hs --- a/src/Text/UTF8.hs +++ b/src/Text/UTF8.hs @@ -1,123 +1,123 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Support for the UTF8 encoding --- ------------------------------------------------------------------------------ -module Text.UTF8 - ( encode, encodeM, decode, decodeM - , isUTF8, allBytes, propEncoding - ) where - -import Data.Char -import Data.Maybe -import Control.Monad.Error -import Test.QuickCheck - ------------------------------------------------------------------- --- Interface - --- | Encode a string to UTF8 format -encode :: String -> String -encode = either error id . encodeM - --- | Decode an UTF8 format string to unicode points -decode :: String -> String -decode = either error id . decodeM - --- | Encode a string to UTF8 format (monadic) -encodeM :: Monad m => String -> m String -encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord) - --- | Decode an UTF8 format string to unicode points (monadic) -decodeM :: Monad m => String -> m String -decodeM = liftM (map chr) . fromUTF8 . map ord - --- | Test whether the argument is a proper UTF8 string -isUTF8 :: String -> Bool -isUTF8 = isJust . decodeM - --- | Test whether all characters are in the range 0-255 -allBytes :: String -> Bool -allBytes = all ((`between` (0, 255)) . ord) - ------------------------------------------------------------------- --- Helper functions - -toUTF8 :: Monad m => Int -> m [Int] -toUTF8 n - | n < 128 = -- one byte - return [n] - | n < 2048 = -- two bytes - let (a, d) = n `divMod` 64 - in return [a+192, d+128] - | n < 65536 = -- three bytes - let (a, d1) = n `divMod` 4096 - (b, d2) = d1 `divMod` 64 - in return [a+224, b+128, d2+128] - | n < 1114112 = -- four bytes - let (a, d1) = n `divMod` 262144 - (b, d2) = d1 `divMod` 4096 - (c, d3) = d2 `divMod` 64 - in return [a+240, b+128, c+128, d3+128] - | otherwise = - fail "invalid character in UTF8" - -fromUTF8 :: Monad m => [Int] -> m [Int] -fromUTF8 xs - | null xs = return [] - | otherwise = do - (i, rest) <- f xs - is <- fromUTF8 rest - return (i:is) - where - f (a:rest) | a < 128 = -- one byte - return (a, rest) - f (a:b:rest) | a `between` (192, 223) = do -- two bytes - unless (isHigh b) $ - fail "invalid UTF8 character (two bytes)" - return ((a-192)*64 + b-128, rest) - f (a:b:c:rest) | a `between` (224, 239) = do -- three bytes - unless (isHigh b && isHigh c) $ - fail "invalid UTF8 character (three bytes)" - return ((a-224)*4096 + (b-128)*64 + c-128, rest) - f (a:b:c:d:rest) | a >= 240 && a < 248 = do -- four bytes - let value = (a-240)*262144 + (b-128)*4096 + (c-128)*64 + d-128 - unless (isHigh b && isHigh c && isHigh d && value <= 1114111) $ - fail "invalid UTF8 character (four bytes)" - return (value, rest) - f _ = fail "invalid character in UTF8" - -isHigh :: Int -> Bool -isHigh i = i `between` (128, 191) - -between :: Ord a => a -> (a, a) -> Bool -between a (low, high) = low <= a && a <= high - ------------------------------------------------------------------- --- Test encoding - --- | QuickCheck internal encoding/decoding functions -propEncoding :: Property -propEncoding = forAll (sized gen) valid - where - gen n = replicateM n someChar - someChar = liftM chr $ oneof - -- To get a nice distribution over the number of bytes used - -- in the encoding - [ choose (0, 127), choose (128, 2047) - , choose (2048, 65535), choose (65536, 1114111) - ] - -valid :: String -> Bool -valid xs = fromMaybe False $ - do us <- encodeM xs - bs <- decodeM us +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for the UTF8 encoding +-- +----------------------------------------------------------------------------- +module Text.UTF8 + ( encode, encodeM, decode, decodeM + , isUTF8, allBytes, propEncoding + ) where + +import Control.Monad.Error +import Data.Char +import Data.Maybe +import Test.QuickCheck + +------------------------------------------------------------------ +-- Interface + +-- | Encode a string to UTF8 format +encode :: String -> String +encode = either error id . encodeM + +-- | Decode an UTF8 format string to unicode points +decode :: String -> String +decode = either error id . decodeM + +-- | Encode a string to UTF8 format (monadic) +encodeM :: Monad m => String -> m String +encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord) + +-- | Decode an UTF8 format string to unicode points (monadic) +decodeM :: Monad m => String -> m String +decodeM = liftM (map chr) . fromUTF8 . map ord + +-- | Test whether the argument is a proper UTF8 string +isUTF8 :: String -> Bool +isUTF8 = isJust . decodeM + +-- | Test whether all characters are in the range 0-255 +allBytes :: String -> Bool +allBytes = all ((`between` (0, 255)) . ord) + +------------------------------------------------------------------ +-- Helper functions + +toUTF8 :: Monad m => Int -> m [Int] +toUTF8 n + | n < 128 = -- one byte + return [n] + | n < 2048 = -- two bytes + let (a, d) = n `divMod` 64 + in return [a+192, d+128] + | n < 65536 = -- three bytes + let (a, d1) = n `divMod` 4096 + (b, d2) = d1 `divMod` 64 + in return [a+224, b+128, d2+128] + | n < 1114112 = -- four bytes + let (a, d1) = n `divMod` 262144 + (b, d2) = d1 `divMod` 4096 + (c, d3) = d2 `divMod` 64 + in return [a+240, b+128, c+128, d3+128] + | otherwise = + fail "invalid character in UTF8" + +fromUTF8 :: Monad m => [Int] -> m [Int] +fromUTF8 xs + | null xs = return [] + | otherwise = do + (i, rest) <- f xs + is <- fromUTF8 rest + return (i:is) + where + f (a:rest) | a < 128 = -- one byte + return (a, rest) + f (a:b:rest) | a `between` (192, 223) = do -- two bytes + unless (isHigh b) $ + fail "invalid UTF8 character (two bytes)" + return ((a-192)*64 + b-128, rest) + f (a:b:c:rest) | a `between` (224, 239) = do -- three bytes + unless (isHigh b && isHigh c) $ + fail "invalid UTF8 character (three bytes)" + return ((a-224)*4096 + (b-128)*64 + c-128, rest) + f (a:b:c:d:rest) | a >= 240 && a < 248 = do -- four bytes + let value = (a-240)*262144 + (b-128)*4096 + (c-128)*64 + d-128 + unless (isHigh b && isHigh c && isHigh d && value <= 1114111) $ + fail "invalid UTF8 character (four bytes)" + return (value, rest) + f _ = fail "invalid character in UTF8" + +isHigh :: Int -> Bool +isHigh i = i `between` (128, 191) + +between :: Ord a => a -> (a, a) -> Bool +between a (low, high) = low <= a && a <= high + +------------------------------------------------------------------ +-- Test encoding + +-- | QuickCheck internal encoding/decoding functions +propEncoding :: Property +propEncoding = forAll (sized gen) valid + where + gen n = replicateM n someChar + someChar = liftM chr $ oneof + -- To get a nice distribution over the number of bytes used + -- in the encoding + [ choose (0, 127), choose (128, 2047) + , choose (2048, 65535), choose (65536, 1114111) + ] + +valid :: String -> Bool +valid xs = fromMaybe False $ + do us <- encodeM xs + bs <- decodeM us return (xs == bs) diff --git a/src/Text/XML.hs b/src/Text/XML.hs --- a/src/Text/XML.hs +++ b/src/Text/XML.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- -- | @@ -15,14 +15,13 @@ module Text.XML ( XML, Attr, AttrList, InXML(..), Element(..) , XMLBuilder, makeXML, text, unescaped, element, tag, attribute - , parseXML, showXML, compactXML, (.=.), findAttribute + , parseXML, showXML, compactXML, (.=.), findAttribute, updateLast , children, Attribute(..), builder, findChild, getData ) where -import Control.Monad.Error () import Control.Monad.State +import Data.Char import Data.Monoid -import Text.XML.Document (trim) import Text.XML.Interface hiding (parseXML) import qualified Text.XML.Interface as I @@ -42,7 +41,8 @@ -- default definitions listToXML = Element "list" [] . map (Right . toXML) listFromXML xml - | name xml == "list" && noAttributes xml = mapM fromXML (children xml) + | name xml == "list" && null (attributes xml) = + mapM fromXML (children xml) | otherwise = fail "expecting a list tag" ---------------------------------------------------------------- @@ -54,21 +54,21 @@ return (ignoreLayout xml) ignoreLayout :: XML -> XML -ignoreLayout (Element n as xs) = +ignoreLayout (Element n as xs) = let f = either (Left . trim) (Right . ignoreLayout) in Element n as (map f xs) indentXML :: XML -> XML indentXML = rec 0 - where + where rec i (Element n as xs) = - let ipl = i+2 + let ipl = i+2 cd j = Left ('\n' : replicate j ' ') f = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)]) body | null xs = xs | otherwise = concatMap f xs ++ [cd i] in Element n as body - + showXML :: XML -> String showXML = (++"\n") . show . indentXML . ignoreLayout @@ -104,13 +104,23 @@ m >>= f = XMLBuilder (unBuild m >>= (unBuild . f)) makeXML :: String -> XMLBuilder -> XML -makeXML s m = +makeXML s m = let bs = execState (unBuild m) emptyBS in Element s (bsAttributes bs []) (bsElements bs []) text :: String -> XMLBuilder text = unescaped . escape +updateLast :: (Element -> Element) -> XMLBuilderM a -> XMLBuilderM a +updateLast f m = XMLBuilder $ do + a <- unBuild m + modify $ \s -> s {bsElements = (++) (rec (bsElements s []))} + return a + where + rec [] = [] + rec [x] = [fmap f x] + rec (x:xs) = x:rec xs + -- Should be used with care: the argument String is not escaped, and -- therefore may contain xml tags or xml entities unescaped :: String -> XMLBuilder @@ -139,50 +149,5 @@ f '&' = "&" f c = [c] ----------------------------------------------------------------- --- XML utility functions - -{- -children :: XML -> [XML] -children (Element _ _ xs) = xs - -extract :: Monad m => String -> XML -> m [XML] -extract n xml = - case filter (children xml) of -- [ xs | Tagged (Element m _ xs) <- children xml, n==m ] of - [hd] -> return hd - _ -> fail ("missing tag " ++ show n) - -extractText :: Monad m => String -> XML -> m String -extractText n xml = do - xs <- extract n xml - case xs of - [hd] -> maybe (fail "extract text") return (isText hd) - _ -> fail ("invalid content for tag " ++ show n) - -isTag :: XML -> Maybe (String, AttrList, [XML]) -isTag = -isTag (Tagged (Element n as xs)) = - let f (x := y) = (x, concatMap (either return g) y) - g (CharRef n) = [chr n] - g (EntityRef n) - | otherwise = [] - in Just (n, map f as, xs) -isTag _ = Nothing - -mkTag :: String -> AttrList -> Content -> XML -mkTag n as = Element n (map f as) - where - f (x, y) = x := y - -mkText :: String -> XML -mkText = -- CharData - -isText :: XML -> Maybe String -isText = -isText (CharData s) = Just s -isText (CDATA s) = Just s -isText _ = Nothing - -findChild :: Monad m => String -> XML -> m XML -findChild s e = maybe (fail "child not found") return . safeHead $ - [ c | c <- children e, Just (n, _, _) <- [isTag c], s==n ]-} +trim :: String -> String +trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse diff --git a/src/Text/XML/Document.hs b/src/Text/XML/Document.hs --- a/src/Text/XML/Document.hs +++ b/src/Text/XML/Document.hs @@ -1,259 +1,234 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Datatype for representing XML documents --- ------------------------------------------------------------------------------ -module Text.XML.Document where - -import Data.Char -import Data.List -import Data.Maybe - -type Name = String - -type Attributes = [Attribute] -data Attribute = Name := AttValue deriving Eq - -data Reference = CharRef Int | EntityRef String - deriving Eq - -data Parameter = Parameter String - deriving Eq - -data XMLDoc = XMLDoc - { versionInfo :: Maybe String - , encoding :: Maybe String - , standalone :: Maybe Bool - , dtd :: Maybe DTD - , externals :: [(String, External)] - , root :: Element - } - deriving Eq - -data XML = Tagged Element - | CharData String - | CDATA String - | Reference Reference - deriving Eq - -data Element = Element - { name :: Name - , attributes :: Attributes - , content :: Content - } - deriving Eq - -type Content = [XML] - -data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl] - deriving Eq - -data DocTypeDecl = ElementDecl Name ContentSpec - | AttListDecl Name [AttDef] - | EntityDecl Bool Name EntityDef - | NotationDecl Name (Either ExternalID PublicID) - | DTDParameter Parameter - | DTDConditional Conditional - deriving Eq - -data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP - deriving Eq - --- content particles -data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name - deriving Eq - -data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType - | StringType | EnumerationType [String] | NotationType [String] - deriving Eq - -data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue - deriving Eq - -type AttDef = (Name, AttType, DefaultDecl) -type EntityDef = Either EntityValue (ExternalID, Maybe String) -type AttValue = [Either Char Reference] -type EntityValue = [Either Char (Either Parameter Reference)] - -data ExternalID = System String | Public String String - deriving Eq - -type PublicID = String - -data Conditional = Include [DocTypeDecl] | Ignore [String] - deriving Eq - -type TextDecl = (Maybe String, String) - -type External = (Maybe TextDecl, Content) - ---- - -instance Show XMLDoc where - show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc) - -instance Show Attribute where - show (n := v) = n ++ "=" ++ showAttValue v - -instance Show Element where - show (Element n as c) - | null c = showOpenTag True n as - | otherwise = showOpenTag False n as ++ concatMap show c ++ showCloseTag n - -instance Show XML where - show xml = - case xml of - Tagged e -> show e - CharData s -> s - CDATA s -> "" - Reference r -> show r - -instance Show Reference where - show ref = - case ref of - CharRef n -> "&#" ++ show n ++ ";" - EntityRef s -> "&" ++ s ++ ";" - -instance Show Parameter where - show (Parameter s) = "%" ++ s ++ ";" - -instance Show DTD where - show (DTD n mid ds) = "" - where - list = n : catMaybes [fmap show mid, showDecls ds] - showDecls xs - | null xs = Nothing - | otherwise = Just $ "[" ++ concatMap show xs ++ "]" - -instance Show ExternalID where - show extID = - case extID of - System s -> "SYSTEM " ++ doubleQuote s - Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s] - -instance Show DocTypeDecl where - show decl = - case decl of - ElementDecl n c -> "" - AttListDecl n as -> "" - EntityDecl b n e -> - let xs = ["%" | not b] ++ [n, showEntityDef e] - in "" - NotationDecl n e -> - let f s = "PUBLIC " ++ doubleQuote s - in "" - DTDParameter r -> show r - DTDConditional c -> show c - -instance Show ContentSpec where - show cspec = - case cspec of - Empty -> "EMPTY" - Any -> "ANY" - Mixed b ns -> - let txt = concat (intersperse "|" ("#PCDATA":ns)) - in parenthesize txt ++ (if b then "*" else "") - Children cp -> show cp - -instance Show CP where - show cp = - case cp of - Choice xs -> parenthesize (concat (intersperse "|" (map show xs))) - Sequence xs -> parenthesize (concat (intersperse "," (map show xs))) - QuestionMark c -> show c ++ "?" - Star c -> show c ++ "*" - Plus c -> show c ++ "+" - CPName n -> n - -instance Show AttType where - show attType = - case attType of - IdType -> "ID" - IdRefType -> "IDREF" - IdRefsType -> "IDREFS" - EntityType -> "ENTITY" - EntitiesType -> "ENTITIES" - NmTokenType -> "NMTOKEN" - NmTokensType -> "NMTOKENS" - StringType -> "CDATA" - EnumerationType xs -> parenthesize (concat (intersperse "|" xs)) - NotationType xs -> "NOTATION " ++ parenthesize (concat (intersperse "|" xs)) - -instance Show DefaultDecl where - show defaultDecl = - case defaultDecl of - Required -> "#REQUIRED" - Implied -> "#IMPLIED" - Value v -> showAttValue v - Fixed v -> "#FIXED " ++ showAttValue v - -instance Show Conditional where - show conditional = - case conditional of - Include xs -> "" - Ignore _ -> "" -- ToDO undefined -- [String] - -showXMLDecl :: XMLDoc -> String -showXMLDecl doc - | isJust (versionInfo doc) = "" - | otherwise = "" - where - s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc) - s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc) - s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc) - -showOpenTag :: Bool -> Name -> Attributes -> String -showOpenTag close n as = "<" ++ unwords (n:map show as) ++ - (if close then "/>" else ">") - -showCloseTag :: Name -> String -showCloseTag n = "" - -showAttValue :: AttValue -> String -- TODO: no double quotes allowed (should be escaped) -showAttValue = doubleQuote . concatMap (either f show) - where - f '"' = [] - f c = [c] - -showEntityValue :: EntityValue -> String -showEntityValue = doubleQuote . concatMap (either f (either show show)) - where - f '"' = [] - f c = [c] - -showAttDef :: AttDef -> String -showAttDef (s, tp, dd) = unwords [s, show tp, show dd] - -showEntityDef :: EntityDef -> String -showEntityDef entityDef = - case entityDef of - Left ev -> showEntityValue ev - Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms - -doubleQuote :: String -> String -doubleQuote s = "\"" ++ s ++ "\"" - -parenthesize :: String -> String -parenthesize s = "(" ++ s ++ ")" - -trim :: String -> String -trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse - ---------------------------------------------------- - -type M = [Either String Element] - -refToString :: Reference -> String -refToString (CharRef c) = [chr c] -refToString (EntityRef _) = undefined - -attribute_ :: AttValue -> String -attribute_ = concatMap (either return refToString) +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Datatype for representing XML documents +-- +----------------------------------------------------------------------------- +module Text.XML.Document + ( Name, Attributes, Attribute(..), Reference(..), Parameter(..) + , XMLDoc(..), XML(..), Element(..), Content, DTD(..), DocTypeDecl(..) + , ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef + , EntityDef, AttValue, EntityValue, ExternalID(..), PublicID + , Conditional(..), TextDecl, External + ) where + +type Name = String + +type Attributes = [Attribute] +data Attribute = Name := AttValue + +data Reference = CharRef Int | EntityRef String + +data Parameter = Parameter String + +data XMLDoc = XMLDoc + { versionInfo :: Maybe String + , encoding :: Maybe String + , standalone :: Maybe Bool + , dtd :: Maybe DTD + , externals :: [(String, External)] + , root :: Element + } + +data XML = Tagged Element + | CharData String + | CDATA String + | Reference Reference + +data Element = Element + { name :: Name + , attributes :: Attributes + , content :: Content + } + +type Content = [XML] + +data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl] + +data DocTypeDecl = ElementDecl Name ContentSpec + | AttListDecl Name [AttDef] + | EntityDecl Bool Name EntityDef + | NotationDecl Name (Either ExternalID PublicID) + | DTDParameter Parameter + | DTDConditional Conditional + +data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP + +-- content particles +data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name + +data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType + | StringType | EnumerationType [String] | NotationType [String] + +data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue + +type AttDef = (Name, AttType, DefaultDecl) +type EntityDef = Either EntityValue (ExternalID, Maybe String) +type AttValue = [Either Char Reference] +type EntityValue = [Either Char (Either Parameter Reference)] + +data ExternalID = System String | Public String String + +type PublicID = String + +data Conditional = Include [DocTypeDecl] | Ignore [String] + +type TextDecl = (Maybe String, String) + +type External = (Maybe TextDecl, Content) + +--- +{- +instance Show XMLDoc where + show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc) +-} +instance Show Attribute where + show (n := v) = n ++ "=" ++ showAttValue v + +instance Show Element where + show (Element n as c) + | null c = showOpenTag True n as + | otherwise = showOpenTag False n as ++ concatMap show c ++ showCloseTag n + +instance Show XML where + show xml = + case xml of + Tagged e -> show e + CharData s -> s + CDATA s -> "" + Reference r -> show r + +instance Show Reference where + show ref = + case ref of + CharRef n -> "&#" ++ show n ++ ";" + EntityRef s -> "&" ++ s ++ ";" + +instance Show Parameter where + show (Parameter s) = "%" ++ s ++ ";" +{- +instance Show DTD where + show (DTD n mid ds) = "" + where + list = n : catMaybes [fmap show mid, showDecls ds] + showDecls xs + | null xs = Nothing + | otherwise = Just $ "[" ++ concatMap show xs ++ "]" + +instance Show ExternalID where + show extID = + case extID of + System s -> "SYSTEM " ++ doubleQuote s + Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s] + +instance Show DocTypeDecl where + show decl = + case decl of + ElementDecl n c -> "" + AttListDecl n as -> "" + EntityDecl b n e -> + let xs = ["%" | not b] ++ [n, showEntityDef e] + in "" + NotationDecl n e -> + let f s = "PUBLIC " ++ doubleQuote s + in "" + DTDParameter r -> show r + DTDConditional c -> show c + +instance Show ContentSpec where + show cspec = + case cspec of + Empty -> "EMPTY" + Any -> "ANY" + Mixed b ns -> + let txt = intercalate "|" ("#PCDATA":ns) + in parenthesize txt ++ (if b then "*" else "") + Children cp -> show cp + +instance Show CP where + show cp = + case cp of + Choice xs -> parenthesize (intercalate "|" (map show xs)) + Sequence xs -> parenthesize (intercalate "," (map show xs)) + QuestionMark c -> show c ++ "?" + Star c -> show c ++ "*" + Plus c -> show c ++ "+" + CPName n -> n + +instance Show AttType where + show attType = + case attType of + IdType -> "ID" + IdRefType -> "IDREF" + IdRefsType -> "IDREFS" + EntityType -> "ENTITY" + EntitiesType -> "ENTITIES" + NmTokenType -> "NMTOKEN" + NmTokensType -> "NMTOKENS" + StringType -> "CDATA" + EnumerationType xs -> parenthesize (intercalate "|" xs) + NotationType xs -> "NOTATION " ++ parenthesize (intercalate "|" xs) + +instance Show DefaultDecl where + show defaultDecl = + case defaultDecl of + Required -> "#REQUIRED" + Implied -> "#IMPLIED" + Value v -> showAttValue v + Fixed v -> "#FIXED " ++ showAttValue v + +instance Show Conditional where + show conditional = + case conditional of + Include xs -> "" + Ignore _ -> "" -- ToDO undefined -- [String] + +showXMLDecl :: XMLDoc -> String +showXMLDecl doc + | isJust (versionInfo doc) = "" + | otherwise = "" + where + s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc) + s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc) + s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc) +-} +showOpenTag :: Bool -> Name -> Attributes -> String +showOpenTag close n as = "<" ++ unwords (n:map show as) ++ + (if close then "/>" else ">") + +showCloseTag :: Name -> String +showCloseTag n = "" + +showAttValue :: AttValue -> String -- TODO: no double quotes allowed (should be escaped) +showAttValue = doubleQuote . concatMap (either f show) + where + f '"' = [] + f c = [c] +{- +showEntityValue :: EntityValue -> String +showEntityValue = doubleQuote . concatMap (either f (either show show)) + where + f '"' = [] + f c = [c] + +showAttDef :: AttDef -> String +showAttDef (s, tp, dd) = unwords [s, show tp, show dd] + +showEntityDef :: EntityDef -> String +showEntityDef entityDef = + case entityDef of + Left ev -> showEntityValue ev + Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms +-} +doubleQuote :: String -> String +doubleQuote s = "\"" ++ s ++ "\"" +{- +parenthesize :: String -> String +parenthesize s = "(" ++ s ++ ")" -} diff --git a/src/Text/XML/Interface.hs b/src/Text/XML/Interface.hs --- a/src/Text/XML/Interface.hs +++ b/src/Text/XML/Interface.hs @@ -1,193 +1,128 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Collection of common operation on XML documents --- ------------------------------------------------------------------------------ -module Text.XML.Interface where - -import Control.Arrow -import Text.XML.Document (Name) -import Text.XML.Unicode (decoding) -import Text.XML.Parser (document, extParsedEnt) -import Text.XML.ParseLib (parse) -import Control.Monad.Error () -import qualified Text.XML.Document as D -import System.FilePath (takeDirectory, pathSeparator) -import Data.Char (chr, ord) -import Data.Maybe - -data Element = Element - { name :: Name - , attributes :: Attributes - , content :: Content - } - -instance Show Element where - show = show . extend - -type Content = [Either String Element] - -type Attributes = [Attribute] -data Attribute = Name := String - -normalize :: D.XMLDoc -> Element -normalize doc = toElement (D.root doc) - where - toElement :: D.Element -> Element - toElement (D.Element n as c) = - Element n (map toAttribute as) (toContent c) - - toAttribute :: D.Attribute -> Attribute - toAttribute (n D.:= v) = - n := concatMap (either return refToString) v - - toContent :: D.Content -> Content - toContent = merge . concatMap f - where - f :: D.XML -> Content - f (D.Tagged e) = [Right (toElement e)] - f (D.CharData s) = [Left s] - f (D.CDATA s) = [Left s] - f (D.Reference r) = refToContent r - - refToString :: D.Reference -> String - refToString (D.CharRef i) = [chr i] - refToString (D.EntityRef _) = "" -- error - - refToContent :: D.Reference -> Content - refToContent (D.CharRef i) = [Left [chr i]] - refToContent (D.EntityRef s) = - fromJust (lookup s entities) - - entities :: [(String, Content)] - entities = - [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] ++ - -- predefined entities - map (second (return . Left . return)) - [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')] - - merge :: Content -> Content - merge (Left s:Left t:rest) = merge (Left (s++t) : rest) - merge (x:xs) = x:merge xs - merge [] = [] - -extend :: Element -> D.XMLDoc -extend e = D.XMLDoc - { D.versionInfo = Nothing - , D.encoding = Nothing - , D.standalone = Nothing - , D.dtd = Nothing - , D.externals = [] - , D.root = toElement e - } - where - toElement :: Element -> D.Element - toElement (Element n as c) = - D.Element n (map toAttribute as) (concatMap toXML c) - - toAttribute :: Attribute -> D.Attribute - toAttribute (n := s) = (D.:=) n (map Left s) - - toXML :: Either String Element -> [D.XML] - toXML = either fromString (return . D.Tagged . toElement) - - fromString :: String -> [D.XML] - fromString [] = [] - fromString xs@(hd:tl) - | null xs1 = D.Reference (D.CharRef (ord hd)) : fromString tl - | otherwise = D.CharData xs1 : fromString xs2 - where - (xs1, xs2) = break ((> 127) . ord) xs - ------------------------------------------------------ - -parseXML :: String -> Either String Element -parseXML xs = do - input <- decoding xs - doc <- parse document input - return (normalize doc) - -parseIO :: String -> IO Element -parseIO baseFile = do - -- putStrLn $ "Reading " ++ show baseFile - xs <- readFile baseFile - input <- decoding xs - case parse document input of - Left err -> fail err - Right doc -> do - let exts = getExternals doc - rs <- mapM (parseExternal . snd) exts - let new = doc { D.externals = zip (map fst exts) rs } - return (normalize new) - - where - getExternals :: D.XMLDoc -> [(String, String)] - getExternals doc = - case D.dtd doc of - Just (D.DTD _ _ decls) -> - [ (n, s) | D.EntityDecl True n (Right (D.System s, Nothing)) <- decls ] - Nothing -> [] - - parseExternal :: String -> IO D.External - parseExternal extFile = do - let full = takeDirectory baseFile ++ [pathSeparator] ++ extFile - -- putStrLn $ "Reading " ++ show full - xs <- readFile full - input <- decoding xs - case parse extParsedEnt input of - Right doc -> return doc - Left err -> fail err - ------------------------------------------------------ - -noAttributes :: Element -> Bool -noAttributes = null . attributes - -findAttribute :: Monad m => String -> Element -> m String -findAttribute s (Element _ as _) = - case [ t | n := t <- as, s==n ] of - [hd] -> return hd - _ -> fail $ "Invalid attribute: " ++ show s - -findChild :: Monad m => String -> Element -> m Element -findChild s e = - case filter ((==s) . name) (children e) of - [a] -> return a - _ -> fail $ "Child not found: " ++ show s - -children :: Element -> [Element] -children e = [ c | Right c <- content e ] - -getData :: Element -> String +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Collection of common operation on XML documents +-- +----------------------------------------------------------------------------- +module Text.XML.Interface + ( Element(..), Content, Attribute(..), Attributes + , normalize, parseXML + , children, findAttribute, findChild, getData + ) where + +import Control.Arrow +import Data.Char (chr, ord) +import Data.Maybe +import Text.Parsing (parseSimple) +import Text.XML.Document (Name) +import Text.XML.Parser (document) +import Text.XML.Unicode (decoding) +import qualified Text.XML.Document as D + +data Element = Element + { name :: Name + , attributes :: Attributes + , content :: Content + } + +instance Show Element where + show = show . extend + +type Content = [Either String Element] + +type Attributes = [Attribute] +data Attribute = Name := String + +normalize :: D.XMLDoc -> Element +normalize doc = toElement (D.root doc) + where + toElement :: D.Element -> Element + toElement (D.Element n as c) = + Element n (map toAttribute as) (toContent c) + + toAttribute :: D.Attribute -> Attribute + toAttribute (n D.:= v) = + n := concatMap (either return refToString) v + + toContent :: D.Content -> Content + toContent = merge . concatMap f + where + f :: D.XML -> Content + f (D.Tagged e) = [Right (toElement e)] + f (D.CharData s) = [Left s] + f (D.CDATA s) = [Left s] + f (D.Reference r) = refToContent r + + refToString :: D.Reference -> String + refToString (D.CharRef i) = [chr i] + refToString (D.EntityRef _) = "" -- error + + refToContent :: D.Reference -> Content + refToContent (D.CharRef i) = [Left [chr i]] + refToContent (D.EntityRef s) = + fromJust (lookup s entities) + + entities :: [(String, Content)] + entities = + [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] ++ + -- predefined entities + map (second (return . Left . return)) + [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')] + + merge :: Content -> Content + merge (Left s:Left t:rest) = merge (Left (s++t) : rest) + merge (x:xs) = x:merge xs + merge [] = [] + +extend :: Element -> D.Element +extend (Element n as c) = + D.Element n (map toAttribute as) (concatMap toXML c) + where + toAttribute :: Attribute -> D.Attribute + toAttribute (m := s) = (D.:=) m (map Left s) + + toXML :: Either String Element -> [D.XML] + toXML = either fromString (return . D.Tagged . extend) + + fromString :: String -> [D.XML] + fromString [] = [] + fromString xs@(hd:tl) + | null xs1 = D.Reference (D.CharRef (ord hd)) : fromString tl + | otherwise = D.CharData xs1 : fromString xs2 + where + (xs1, xs2) = break ((> 127) . ord) xs + +----------------------------------------------------- + +parseXML :: String -> Either String Element +parseXML xs = do + input <- decoding xs + doc <- parseSimple document input + return (normalize doc) + +----------------------------------------------------- + +findAttribute :: Monad m => String -> Element -> m String +findAttribute s (Element _ as _) = + case [ t | n := t <- as, s==n ] of + [hd] -> return hd + _ -> fail $ "Invalid attribute: " ++ show s + +findChild :: Monad m => String -> Element -> m Element +findChild s e = + case filter ((==s) . name) (children e) of + [a] -> return a + _ -> fail $ "Child not found: " ++ show s + +children :: Element -> [Element] +children e = [ c | Right c <- content e ] + +getData :: Element -> String getData e = concat [ s | Left s <- content e ] - -{- -children :: D.Element -> [D.Element] -children (D.Element _ _ c) = [ e | D.Tagged e <- c ] - -getAttributes :: D.Element -> [(String, String)] -getAttributes (D.Element _ as _) = - [ (n, concatMap f av) | n D.:= av <- as ] - where - f :: Either Char D.Reference -> String - f (Left c) = [c] - f (Right (D.CharRef n)) = [chr $ fromIntegral n] - f (Right (D.EntityRef _)) = [] - -findAttribute :: Monad m => String -> D.Element -> m String -findAttribute n e = - case lookup n (getAttributes e) of - Just a -> return a - Nothing -> fail $ "Attribute not found: " ++ show n - -getData :: D.Element -> String -getData (D.Element _ _ c) = concat [ s | D.CharData s <- c ] --} diff --git a/src/Text/XML/ParseLib.hs b/src/Text/XML/ParseLib.hs deleted file mode 100644 --- a/src/Text/XML/ParseLib.hs +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- An interface to a parsing library. The Parsec library is used because --- we need the back-tracking facilities (try combinator) in order not to --- have to rewrite the complete grammar for XML. In addition, the stopOn --- combinator is hard (or impossible?) to write using the UU library. This --- abstraction should make it easier to switch to a different parsing library --- in future, in case we want to. --- ------------------------------------------------------------------------------ -module Text.XML.ParseLib - ( Parser, (<|>), (<..>) - , symbol, string, optionM, option, oneOf, ranges, many, doubleQuoted, bracketed - , singleQuoted, stopOn, parenthesized, choice, many1, try - , noneOf, chainr1, sepBy1, parse, accept, packed, recognize - ) where - -import qualified Text.ParserCombinators.Parsec as P - -infix 6 <..> -infixr 4 <|> - -type Parser a = P.CharParser () a - -parse :: Parser a -> String -> Either String a -parse p = either (Left . show) Right . P.parse (p >>= \a -> P.eof >> return a) "" - -accept :: Parser a -> String -> Bool -accept p = either (const False) (const True) . parse p - -try :: Parser a -> Parser a -try = P.try - -noneOf :: String -> Parser Char -noneOf = P.noneOf - -(<|>) :: Parser a -> Parser a -> Parser a -(<|>) = (P.<|>) - -(<..>) :: Char -> Char -> Parser Char -x <..> y = P.satisfy (\c -> c >= x && c <= y) - -recognize :: Parser a -> Parser () -recognize p = p >> return () - -stopOn :: [String] -> Parser String -stopOn list = many (try (noneOf hds <|> foldr1 (<|>) ps)) - where - (hds, ps) = unzip [ (x, make x xs) | x:xs <- list ] - make x xs - | null xs = fail "make" - | otherwise = do - symbol x - P.notFollowedBy (P.try (string xs >> return ' ')) - return x - -symbol :: Char -> Parser () -symbol c = P.char c >> return () - -string :: String -> Parser () -string s = P.string s >> return () - -ranges :: [(Char, Char)] -> Parser Char -ranges xs = P.choice [ a <..> b | (a, b) <- xs ] - -oneOf :: String -> Parser Char -oneOf = P.oneOf - -many :: Parser a -> Parser [a] -many = P.many - -many1 :: Parser a -> Parser [a] -many1 = P.many1 - -sepBy1 :: Parser a -> Parser b -> Parser [a] -sepBy1 = P.sepBy1 - -chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a -chainr1 = P.chainr1 - -choice :: [Parser a] -> Parser a -choice = P.choice - -optionM :: Parser a -> Parser (Maybe a) -optionM = P.optionMaybe - -option :: a -> Parser a -> Parser a -option = P.option - -doubleQuoted :: Parser a -> Parser a -doubleQuoted p = packed (symbol '"') p (symbol '"') - -singleQuoted :: Parser a -> Parser a -singleQuoted p = packed (symbol '\'') p (symbol '\'') - -parenthesized :: Parser a -> Parser a -parenthesized p = packed (symbol '(') p (symbol ')') - -bracketed :: Parser a -> Parser a -bracketed p = packed (symbol '[') p (symbol ']') - -packed :: Parser a -> Parser b -> Parser c -> Parser b -packed l p r = l >> p >>= \a -> r >> return a diff --git a/src/Text/XML/Parser.hs b/src/Text/XML/Parser.hs --- a/src/Text/XML/Parser.hs +++ b/src/Text/XML/Parser.hs @@ -1,688 +1,694 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A parser for XML documents, directly derived from the specification: - --- http://www.w3.org/TR/2006/REC-xml-20060816 - ------------------------------------------------------------------------------ -module Text.XML.Parser (document, extParsedEnt, extSubset) where - -import Prelude hiding (seq) -import Control.Monad -import Data.Char (toUpper, ord, isSpace) -import Data.List (foldl') -- ' -import Data.Maybe (catMaybes) -import Text.XML.Unicode -import Text.XML.Document hiding (versionInfo, name, content) -import qualified Text.XML.Document as D -import Text.XML.ParseLib - -letter, digit, combiningChar, extender :: Parser Char -letter = ranges letterMap -digit = ranges digitMap -combiningChar = ranges combiningCharMap -extender = ranges extenderMap - --------------------------------------------------- --- * 2 Documents - --------------------------------------------------- --- ** 2.1 Well-Formed XML Documents - --- [1] document ::= prolog element Misc* -document :: Parser XMLDoc -document = do - (mxml, mdtd) <- prolog - rt <- element - miscs - let (ver, enc, sa) = - case mxml of - Just (a, b, c) -> (Just a, b, c) - Nothing -> (Nothing, Nothing, Nothing) - return $ XMLDoc - { D.versionInfo = ver - , D.encoding = enc - , D.standalone = sa - , D.dtd = mdtd - , D.externals = [] - , root = rt - } - --------------------------------------------------- --- ** 2.2 Characters - --- [2] Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] -{- -char :: Parser Char -char = ranges xs <|> oneOf "\x9\xA\xD" - where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')] --} - --------------------------------------------------- --- ** 2.3 Common Syntactic Constructs - --- [3] S ::= (#x20 | #x9 | #xD | #xA)+ -space :: Parser () -space = many1 (oneOf "\x20\x9\xA\xD") >> return () - -mspace :: Parser () -- for S? -mspace = many (oneOf "\x20\x9\xA\xD") >> return () - --- [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender -nameChar :: Parser Char -nameChar = letter <|> digit <|> combiningChar <|> extender <|> oneOf ".-_:" - --- [5] Name ::= (Letter | '_' | ':') (NameChar)* -name :: Parser String -name = do - c <- letter <|> oneOf "_:" - cs <- many nameChar - return (c:cs) - -{- --- [6] Names ::= Name (#x20 Name)* -names :: Parser [String] -names = sepBy1 name (symbol '\x20') --} - --- [7] Nmtoken ::= (NameChar)+ -nmtoken :: Parser String -nmtoken = many1 nameChar - -{- --- [8] Nmtokens ::= Nmtoken (#x20 Nmtoken)* -nmtokens :: Parser [String] -nmtokens = sepBy1 nmtoken (symbol '\x20') --} - --- [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' --- | "'" ([^%&'] | PEReference | Reference)* "'" -entityValue :: Parser EntityValue -entityValue = doubleQuoted (p "%&\"") <|> singleQuoted (p "%&'") - where - p s = many (fmap Left (noneOf s) - <|> fmap Right (fmap Left peReference <|> fmap Right reference)) - --- [10] AttValue ::= '"' ([^<&"] | Reference)* '"' --- | "'" ([^<&'] | Reference)* "'" -attValue :: Parser AttValue -attValue = doubleQuoted (p "<&\"") <|> singleQuoted (p "<&'") - where p s = many (fmap Left (noneOf s) <|> fmap Right reference) - --- [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") -systemLiteral :: Parser String -systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'") - where p s = many (noneOf s) - --- [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" -pubidLiteral :: Parser String -pubidLiteral = doubleQuoted (many (pubidChar True)) <|> singleQuoted (many (pubidChar False)) - --- [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%] -pubidChar :: Bool -> Parser Char -pubidChar withSingleQuote = - ranges xs <|> oneOf "\x20\xD\xA-()+,./:=?;!*#@$_%" <|> singleQuote - where - xs = [('a', 'z'), ('A', 'Z'), ('0', '9')] - singleQuote - | withSingleQuote = symbol '\'' >> return '\'' - | otherwise = fail "pubidChar" - --------------------------------------------------- --- ** 2.4 Character Data and Markup - --- [14] CharData ::= [^<&]* - ([^<&]* ']]>' [^<&]*) -charData :: Parser String -- This implementation is too liberal since it allows "]]>" -charData = stopOn ["<", "&", "]]>"] - - --------------------------------------------------- --- ** 2.5 Comments - --- [15] Comment ::= '' -comment :: Parser String -comment = packed (string "") - --------------------------------------------------- --- ** 2.6 Processing Instructions - --- [16] PI ::= '' Char*)))? '?>' -pInstr :: Parser String -pInstr = packed (string "") - where - p = piTarget >> option "" (space >> stopOn ["?>"]) - --- [17] PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) -piTarget :: Parser String -piTarget = do - n <- name - when (map toUpper n == "XML") $ fail "XML in piTarget" - return n - --------------------------------------------------- --- ** 2.7 CDATA Sections - --- [18] CDSect ::= CDStart CData CDEnd --- [19] CDStart ::= '' Char*)) --- [21] CDEnd ::= ']]>' -cdSect :: Parser XML -cdSect = packed (string "") - where - p = do - s <- stopOn ["]]>"] - return (CDATA s) - --------------------------------------------------- --- ** 2.8 Prolog and Document Type Declaration - -type XMLDecl = (String, Maybe String, Maybe Bool) - --- [22] prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? -prolog :: Parser (Maybe XMLDecl, Maybe DTD) -prolog = do - ma <- optionM (try xmlDecl) - miscs - mb <- optionM $ try $ do - mb <- doctypedecl - miscs - return mb - return (ma, mb) - --- [23] XMLDecl ::= '' -xmlDecl :: Parser XMLDecl -xmlDecl = do - string "" - return (x, y, z) - --- [24] VersionInfo ::= S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"') -versionInfo :: Parser String -versionInfo = space >> string "version" >> eq >> p - where p = singleQuoted versionNum <|> doubleQuoted versionNum - --- [25] Eq ::= S? '=' S? -eq :: Parser () -eq = recognize (mspace >> symbol '=' >> mspace) - --- [26] VersionNum ::= '1.0' -versionNum :: Parser String -versionNum = do - string "1.0" - return "1.0" - --- [27] Misc ::= Comment | PI | S -misc :: Parser () -misc = try (recognize comment) <|> try (recognize pInstr) <|> recognize space - -miscs :: Parser () -miscs = recognize (many misc) - --- [28] doctypedecl ::= '' -doctypedecl :: Parser DTD -doctypedecl = do - string "> externalID)) - mspace - z <- option [] $ do - z <- bracketed intSubset - mspace - return z - symbol '>' - return (DTD x y z) - --- [28a] DeclSep ::= PEReference | S -declSep :: Parser (Maybe DocTypeDecl) -declSep = fmap (Just . DTDParameter) peReference - <|> (space >> return Nothing) - --- [28b] intSubset ::= (markupdecl | DeclSep)* -intSubset :: Parser [DocTypeDecl] -intSubset = fmap catMaybes (many (markupdecl <|> declSep)) - --- [29] markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment -markupdecl :: Parser (Maybe DocTypeDecl) -markupdecl = fmap Just (choice (map try list)) - <|> ((try pInstr <|> comment) >> return Nothing) - where - list = [elementdecl, attlistDecl, entityDecl, notationDecl] - --- [30] extSubset ::= TextDecl? extSubsetDecl -extSubset :: Parser (Maybe TextDecl, [DocTypeDecl]) -extSubset = do - m <- optionM textDecl - e <- extSubsetDecl - return (m, e) - --- [31] extSubsetDecl ::= ( markupdecl | conditionalSect | DeclSep)* -extSubsetDecl :: Parser [DocTypeDecl] -extSubsetDecl = fmap catMaybes (many (choice [markupdecl, fmap (Just . DTDConditional) conditionalSect, declSep])) - --------------------------------------------------- --- ** 2.9 Standalone Document Declaration --- [32] SDDecl ::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) -sdDecl :: Parser Bool -sdDecl = space >> string "standalone" >> eq >> (singleQuoted bool <|> doubleQuoted bool) - where bool = (string "yes" >> return True) - <|> (string "no" >> return False) - --------------------------------------------------- --- ** 2.10 White Space Handling - --------------------------------------------------- --- * 3 Logical Structures - --- [39] element ::= EmptyElemTag | STag content ETag -element :: Parser Element -element = do - (s1, as, closed) <- sTag - if closed - then return (Element s1 as []) - else do - c <- content - s2 <- eTag - when (s1/=s2) $ fail "WFC: element" - return (Element s1 as c) - --------------------------------------------------- --- ** 3.1 Start-Tags, End-Tags, and Empty-Element Tags - --- [40] STag ::= '<' Name (S Attribute)* S? '>' --- [44] EmptyElemTag ::= '<' Name (S Attribute)* S? '/>' --- The boolean indicates whether the tag was closed immediately (an EmptyElemTag) -sTag :: Parser (Name, Attributes, Bool) -sTag = do - symbol '<' - n <- name - as <- many (try (space >> attribute)) - mspace - b <- (symbol '>' >> return False) <|> - (string "/>" >> return True) - return (n, as, b) - --- [41] Attribute ::= NSAttName Eq AttValue --- | Name Eq AttValue -attribute :: Parser Attribute -attribute = do - n <- name - eq - a <- attValue - return (n := a) - --- [42] ETag ::= '' -eTag :: Parser Name -eTag = do - string "' - return n - --- [43] content ::= CharData? ((element | Reference | CDSect | PI | Comment) CharData?)* --- Note: since CharData accepts epsilon, there is no need to make it optional -content :: Parser Content -content = chainr1 (fmap g charData) (fmap f ps) - where - f ma l r = l ++ maybe [] return ma ++ r - g s = [ CharData s | any (not . isSpace) s ] -- quick fix, ignores layout - ps = try (fmap Just (choice (map try [fmap Tagged element, fmap Reference reference, cdSect])) - <|> ((try pInstr <|> comment) >> return Nothing)) - --------------------------------------------------- --- ** 3.2 Element Type Declarations - --- [45] elementdecl ::= '' -elementdecl :: Parser DocTypeDecl -elementdecl = do - string "' - return (ElementDecl n cs) - --- [46] contentspec ::= 'EMPTY' | 'ANY' | Mixed | children -contentspec :: Parser ContentSpec -contentspec = choice - [ string "EMPTY" >> return Empty - , string "ANY" >> return Any - , try mixed - , children - ] - --- [47] children ::= (choice | seq) ('?' | '*' | '+')? -children :: Parser ContentSpec -children = do - a <- try cpChoice <|> cpSeq - f <- option id multi - return (Children (f a)) - -multi :: Parser (CP -> CP) -multi = (symbol '?' >> return QuestionMark) - <|> (symbol '*' >> return Star) - <|> (symbol '+' >> return Plus) - --- [48] cp ::= (Name | choice | seq) ('?' | '*' | '+')? -cp :: Parser CP -cp = do - a <- (fmap CPName name <|> try cpChoice <|> cpSeq) - f <- option id multi - return (f a) - --- [49] choice ::= '(' S? cp ( S? '|' S? cp )+ S? ')' -cpChoice :: Parser CP -cpChoice = parenthesized $ do - mspace - x <- cp - xs <- many1 (try (mspace >> symbol '|' >> mspace >> cp)) - mspace - return (Choice (x:xs)) - --- [50] seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' -cpSeq :: Parser CP -cpSeq = parenthesized $ do - mspace - x <- cp - xs <- many (try (mspace >> symbol ',' >> mspace >> cp)) - mspace - return (Sequence (x:xs)) - --- [51] Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' --- | '(' S? '#PCDATA' S? ')' -mixed :: Parser ContentSpec -mixed = symbol '(' >> mspace >> string "#PCDATA" >> (rest1 <|> rest2) - where - p = mspace >> symbol '|' >> mspace >> name - rest1 = try $ do - xs <- many (try p) - mspace - string ")*" - return (Mixed True xs) - rest2 = mspace >> symbol ')' >> return (Mixed False []) - --------------------------------------------------- --- ** 3.3 Attribute-List Declarations - --- [52] AttlistDecl ::= '' -attlistDecl :: Parser DocTypeDecl -attlistDecl = do - string "' - return (AttListDecl n ds) - --- [53] AttDef ::= S Name S AttType S DefaultDecl -attDef :: Parser AttDef -attDef = do - space - n <- name - space - tp <- attType - space - dd <- defaultDecl - return (n, tp, dd) - --- [54] AttType ::= StringType | TokenizedType | EnumeratedType -attType :: Parser AttType -attType = stringType <|> tokenizedType <|> enumeratedType - --- [55] StringType ::= 'CDATA' -stringType :: Parser AttType -stringType = string "CDATA" >> return StringType - --- [56] TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' -tokenizedType :: Parser AttType -tokenizedType = choice (map f xs) - where - f (tp, s) = try (string s) >> return tp - xs = [ (IdRefsType, "IDREFS"), (IdRefType, "IDREF"), (IdType, "ID"), (EntityType, "ENTITY") - , (EntitiesType, "ENTITIES"), (NmTokensType, "NMTOKENS"), (NmTokenType, "NMTOKEN") - ] - --- [57] EnumeratedType ::= NotationType | Enumeration -enumeratedType :: Parser AttType -enumeratedType = notationType <|> enumeration - --- [58] NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' -notationType :: Parser AttType -notationType = string "NOTATION" >> space >> parenthesized p - where - p = do - mspace - n <- name - ns <- many (try (mspace >> symbol '|' >> mspace >> name)) - mspace - return (NotationType (n:ns)) - --- [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' -enumeration :: Parser AttType -enumeration = parenthesized $ do - mspace - x <- nmtoken - xs <- many (try (mspace >> symbol '|' >> mspace >> nmtoken)) - mspace - return (EnumerationType (x:xs)) - --- [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) -defaultDecl :: Parser DefaultDecl -defaultDecl = try (string "#REQUIRED" >> return Required) - <|> try (string "#IMPLIED" >> return Implied) - <|> do f <- option Value (string "#FIXED" >> space >> return Fixed) - a <- attValue - return (f a) - --------------------------------------------------- --- ** 3.4 Conditional Sections - --- [61] conditionalSect ::= includeSect | ignoreSect -conditionalSect :: Parser Conditional -conditionalSect = try includeSect <|> ignoreSect - --- [62] includeSect ::= '' -includeSect :: Parser Conditional -includeSect = do - string "" - return (Include ds) - --- [63] ignoreSect ::= '' -ignoreSect :: Parser Conditional -ignoreSect = do - string "" - return (Ignore (concat xss)) - --- [64] ignoreSectContents ::= Ignore ('' Ignore)* -ignoreSectContents :: Parser [String] -ignoreSectContents = - do x <- ignore - xss <- many $ do - string "" - y <- ignore - return (ys++[y]) - return (x:concat xss) - --- [65] Ignore ::= Char* - (Char* ('') Char*) -ignore :: Parser String -ignore = stopOn [""] - --------------------------------------------------- --- * 4 Physical Structures - --------------------------------------------------- --- ** 4.1 Character and Entity References - --- [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';' -charRef :: Parser Reference -charRef = do - string "&#" - n <- p <|> (symbol 'x' >> q) - symbol ';' - return (CharRef n) - where - p = fmap (foldl' (\a b -> a*10+ord b-48) 0) (many1 ('0' <..> '9')) - q = fmap hexa (many1 (ranges [('0', '9'), ('a', 'f'), ('A', 'F')])) - -hexa :: String -> Int -hexa = rec 0 - where - rec n [] = n - rec n (x:xs) = rec (16*n + ord x - correct) xs - where - correct - | x <= '9' = ord '0' - | x <= 'F' = ord 'A' - 10 - | otherwise = ord 'a' - 10 - --- [67] Reference ::= EntityRef | CharRef -reference :: Parser Reference -reference = try entityRef <|> charRef - --- [68] EntityRef ::= '&' Name ';' -entityRef :: Parser Reference -entityRef = packed (symbol '&') (fmap EntityRef name) (symbol ';') - --- [69] PEReference ::= '%' Name ';' -peReference :: Parser Parameter -peReference = packed (symbol '%') (fmap Parameter name) (symbol ';') - --------------------------------------------------- --- ** 4.2 Entity Declarations - --- [70] EntityDecl ::= GEDecl | PEDecl -entityDecl :: Parser DocTypeDecl -entityDecl = try geDecl <|> peDecl - --- [71] GEDecl ::= '' -geDecl :: Parser DocTypeDecl -geDecl = do - string "' - return (EntityDecl True n ed) - --- [72] PEDecl ::= '' -peDecl :: Parser DocTypeDecl -peDecl = do - string "' - return (EntityDecl False n (either Left (\a -> Right (a, Nothing)) e)) - --- [73] EntityDef ::= EntityValue | (ExternalID NDataDecl?) -entityDef :: Parser EntityDef -entityDef = fmap Left entityValue <|> do - e <- externalID - ms <- optionM (try nDataDecl) - return (Right (e, ms)) - --- [74] PEDef ::= EntityValue | ExternalID -peDef :: Parser (Either EntityValue ExternalID) -peDef = fmap Left entityValue <|> fmap Right externalID - --- [75] ExternalID ::= 'SYSTEM' S SystemLiteral | 'PUBLIC' S PubidLiteral S SystemLiteral -externalID :: Parser ExternalID -externalID = (string "SYSTEM" >> space >> fmap System systemLiteral) <|> do - string "PUBLIC" - space - x <- pubidLiteral - space - y <- systemLiteral - return (Public x y) - --- [76] NDataDecl ::= S 'NDATA' S Name -nDataDecl :: Parser String -nDataDecl = space >> string "NDATA" >> space >> name - --------------------------------------------------- --- ** 4.3 Parsed Entities - --- [77] TextDecl ::= '' - -textDecl :: Parser TextDecl -textDecl = do - string "" - return (v, e) - --- [78] extParsedEnt ::= TextDecl? content -extParsedEnt :: Parser (Maybe TextDecl, Content) -extParsedEnt = do - td <- optionM (try textDecl) - c <- content - return (td, c) - --- [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" ) -encodingDecl :: Parser String -encodingDecl = space >> string "encoding" >> eq >> - (singleQuoted encName <|> doubleQuoted encName) - --- [81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')* -encName :: Parser String -encName = do - x <- ranges [('A', 'Z'), ('a', 'z')] - xs <- many (ranges [('A', 'Z'), ('a', 'z'), ('0', '9')] <|> oneOf "._-") - return (x:xs) - --------------------------------------------------- --- ** 4.7 Notation Declarations - --- [82] NotationDecl ::= '' -notationDecl :: Parser DocTypeDecl -notationDecl = do - string " fmap Right publicID - mspace - symbol '>' - return (NotationDecl n e) - --- [83] PublicID ::= 'PUBLIC' S PubidLiteral -publicID :: Parser PublicID +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A parser for XML documents, directly derived from the specification: + +-- http://www.w3.org/TR/2006/REC-xml-20060816 + +----------------------------------------------------------------------------- +module Text.XML.Parser (document, extParsedEnt, extSubset) where + +import Control.Monad +import Data.Char (toUpper, ord, isSpace) +import Data.List (foldl') -- ' +import Data.Maybe (catMaybes) +import Prelude hiding (seq) +import Text.Parsing hiding (digit, letter, space) +import Text.XML.Document hiding (versionInfo, name, content) +import Text.XML.Unicode +import qualified Text.XML.Document as D + +letter, digit, combiningChar, extender :: Parser Char +letter = ranges letterMap +digit = ranges digitMap +combiningChar = ranges combiningCharMap +extender = ranges extenderMap + +-- combinators without lexing (no spaces are consumed) +parens, brackets, singleQuoted, doubleQuoted :: Parser a -> Parser a +parens = between (char '(') (char ')') +brackets = between (char '[') (char ']') +singleQuoted = between (char '\'') (char '\'') +doubleQuoted = between (char '"') (char '"') + +-------------------------------------------------- +-- * 2 Documents + +-------------------------------------------------- +-- ** 2.1 Well-Formed XML Documents + +-- [1] document ::= prolog element Misc* +document :: Parser XMLDoc +document = do + (mxml, mdtd) <- prolog + rt <- element + miscs + let (ver, enc, sa) = + case mxml of + Just (a, b, c) -> (Just a, b, c) + Nothing -> (Nothing, Nothing, Nothing) + return XMLDoc + { D.versionInfo = ver + , D.encoding = enc + , D.standalone = sa + , D.dtd = mdtd + , D.externals = [] + , root = rt + } + +-------------------------------------------------- +-- ** 2.2 Characters + +-- [2] Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] +{- +char :: Parser Char +char = ranges xs <|> oneOf "\x9\xA\xD" + where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')] +-} + +-------------------------------------------------- +-- ** 2.3 Common Syntactic Constructs + +-- [3] S ::= (#x20 | #x9 | #xD | #xA)+ +space :: Parser () +space = many1 (oneOf "\x20\x9\xA\xD") >> return () + +mspace :: Parser () -- for S? +mspace = many (oneOf "\x20\x9\xA\xD") >> return () + +-- [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender +nameChar :: Parser Char +nameChar = letter <|> digit <|> combiningChar <|> extender <|> oneOf ".-_:" + +-- [5] Name ::= (Letter | '_' | ':') (NameChar)* +name :: Parser String +name = do + c <- letter <|> oneOf "_:" + cs <- many nameChar + return (c:cs) + +{- +-- [6] Names ::= Name (#x20 Name)* +names :: Parser [String] +names = sepBy1 name (char '\x20') +-} + +-- [7] Nmtoken ::= (NameChar)+ +nmtoken :: Parser String +nmtoken = many1 nameChar + +{- +-- [8] Nmtokens ::= Nmtoken (#x20 Nmtoken)* +nmtokens :: Parser [String] +nmtokens = sepBy1 nmtoken (char '\x20') +-} + +-- [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' +-- | "'" ([^%&'] | PEReference | Reference)* "'" +entityValue :: Parser EntityValue +entityValue = doubleQuoted (p "%&\"") <|> singleQuoted (p "%&'") + where + p s = many (fmap Left (noneOf s) + <|> fmap Right (fmap Left peReference <|> fmap Right reference)) + +-- [10] AttValue ::= '"' ([^<&"] | Reference)* '"' +-- | "'" ([^<&'] | Reference)* "'" +attValue :: Parser AttValue +attValue = doubleQuoted (p "<&\"") <|> singleQuoted (p "<&'") + where p s = many (fmap Left (noneOf s) <|> fmap Right reference) + +-- [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") +systemLiteral :: Parser String +systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'") + where p s = many (noneOf s) + +-- [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" +pubidLiteral :: Parser String +pubidLiteral = doubleQuoted (many (pubidChar True)) <|> singleQuoted (many (pubidChar False)) + +-- [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%] +pubidChar :: Bool -> Parser Char +pubidChar withSingleQuote = + ranges xs <|> oneOf "\x20\xD\xA-()+,./:=?;!*#@$_%" <|> singleQuote + where + xs = [('a', 'z'), ('A', 'Z'), ('0', '9')] + singleQuote + | withSingleQuote = char '\'' >> return '\'' + | otherwise = fail "pubidChar" + +-------------------------------------------------- +-- ** 2.4 Character Data and Markup + +-- [14] CharData ::= [^<&]* - ([^<&]* ']]>' [^<&]*) +charData :: Parser String -- This implementation is too liberal since it allows "]]>" +charData = stopOn ["<", "&", "]]>"] + +-------------------------------------------------- +-- ** 2.5 Comments + +-- [15] Comment ::= '' +comment :: Parser String +comment = between (string "") (stopOn ["--"]) + +-------------------------------------------------- +-- ** 2.6 Processing Instructions + +-- [16] PI ::= '' Char*)))? '?>' +pInstr :: Parser String +pInstr = between (string "") p + where + p = piTarget >> option "" (space >> stopOn ["?>"]) + +-- [17] PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) +piTarget :: Parser String +piTarget = do + n <- name + when (map toUpper n == "XML") $ fail "XML in piTarget" + return n + +-------------------------------------------------- +-- ** 2.7 CDATA Sections + +-- [18] CDSect ::= CDStart CData CDEnd +-- [19] CDStart ::= '' Char*)) +-- [21] CDEnd ::= ']]>' +cdSect :: Parser XML +cdSect = between (string "") p + where + p = do + s <- stopOn ["]]>"] + return (CDATA s) + +-------------------------------------------------- +-- ** 2.8 Prolog and Document Type Declaration + +type XMLDecl = (String, Maybe String, Maybe Bool) + +-- [22] prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? +prolog :: Parser (Maybe XMLDecl, Maybe DTD) +prolog = do + ma <- optionMaybe (try xmlDecl) + miscs + mb <- optionMaybe $ try $ do + mb <- doctypedecl + miscs + return mb + return (ma, mb) + +-- [23] XMLDecl ::= '' +xmlDecl :: Parser XMLDecl +xmlDecl = do + skip (string "") + return (x, y, z) + +-- [24] VersionInfo ::= S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"') +versionInfo :: Parser String +versionInfo = space >> string "version" >> eq >> p + where p = singleQuoted versionNum <|> doubleQuoted versionNum + +-- [25] Eq ::= S? '=' S? +eq :: Parser () +eq = skip (mspace >> char '=' >> mspace) + +-- [26] VersionNum ::= '1.0' +versionNum :: Parser String +versionNum = do + skip (string "1.0") + return "1.0" + +-- [27] Misc ::= Comment | PI | S +misc :: Parser () +misc = try (skip comment) <|> try (skip pInstr) <|> skip space + +miscs :: Parser () +miscs = skip (many misc) + +-- [28] doctypedecl ::= '' +doctypedecl :: Parser DTD +doctypedecl = do + skip (string "> externalID)) + mspace + z <- option [] $ do + z <- brackets intSubset + mspace + return z + skip (char '>') + return (DTD x y z) + +-- [28a] DeclSep ::= PEReference | S +declSep :: Parser (Maybe DocTypeDecl) +declSep = fmap (Just . DTDParameter) peReference + <|> (space >> return Nothing) + +-- [28b] intSubset ::= (markupdecl | DeclSep)* +intSubset :: Parser [DocTypeDecl] +intSubset = fmap catMaybes (many (markupdecl <|> declSep)) + +-- [29] markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment +markupdecl :: Parser (Maybe DocTypeDecl) +markupdecl = fmap Just (choice (map try list)) + <|> ((try pInstr <|> comment) >> return Nothing) + where + list = [elementdecl, attlistDecl, entityDecl, notationDecl] + +-- [30] extSubset ::= TextDecl? extSubsetDecl +extSubset :: Parser (Maybe TextDecl, [DocTypeDecl]) +extSubset = do + m <- optionMaybe textDecl + e <- extSubsetDecl + return (m, e) + +-- [31] extSubsetDecl ::= ( markupdecl | conditionalSect | DeclSep)* +extSubsetDecl :: Parser [DocTypeDecl] +extSubsetDecl = fmap catMaybes (many (choice [markupdecl, fmap (Just . DTDConditional) conditionalSect, declSep])) + +-------------------------------------------------- +-- ** 2.9 Standalone Document Declaration +-- [32] SDDecl ::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) +sdDecl :: Parser Bool +sdDecl = space >> string "standalone" >> eq >> (singleQuoted bool <|> doubleQuoted bool) + where bool = (string "yes" >> return True) + <|> (string "no" >> return False) + +-------------------------------------------------- +-- ** 2.10 White Space Handling + +-------------------------------------------------- +-- * 3 Logical Structures + +-- [39] element ::= EmptyElemTag | STag content ETag +element :: Parser Element +element = do + (s1, as, closed) <- sTag + if closed + then return (Element s1 as []) + else do + c <- content + s2 <- eTag + when (s1/=s2) $ fail "WFC: element" + return (Element s1 as c) + +-------------------------------------------------- +-- ** 3.1 Start-Tags, End-Tags, and Empty-Element Tags + +-- [40] STag ::= '<' Name (S Attribute)* S? '>' +-- [44] EmptyElemTag ::= '<' Name (S Attribute)* S? '/>' +-- The boolean indicates whether the tag was closed immediately (an EmptyElemTag) +sTag :: Parser (Name, Attributes, Bool) +sTag = do + skip (char '<') + n <- name + as <- many (try (space >> attribute)) + mspace + b <- (char '>' >> return False) <|> + (string "/>" >> return True) + return (n, as, b) + +-- [41] Attribute ::= NSAttName Eq AttValue +-- | Name Eq AttValue +attribute :: Parser Attribute +attribute = do + n <- name + eq + a <- attValue + return (n := a) + +-- [42] ETag ::= '' +eTag :: Parser Name +eTag = do + skip (string "') + return n + +-- [43] content ::= CharData? ((element | Reference | CDSect | PI | Comment) CharData?)* +-- Note: since CharData accepts epsilon, there is no need to make it optional +content :: Parser Content +content = chainr1 (fmap g charData) (fmap f ps) + where + f ma l r = l ++ maybe [] return ma ++ r + g s = [ CharData s | any (not . isSpace) s ] -- quick fix, ignores layout + ps = try (fmap Just (choice (map try [fmap Tagged element, fmap Reference reference, cdSect])) + <|> ((try pInstr <|> comment) >> return Nothing)) + +-------------------------------------------------- +-- ** 3.2 Element Type Declarations + +-- [45] elementdecl ::= '' +elementdecl :: Parser DocTypeDecl +elementdecl = do + skip (string "') + return (ElementDecl n cs) + +-- [46] contentspec ::= 'EMPTY' | 'ANY' | Mixed | children +contentspec :: Parser ContentSpec +contentspec = choice + [ string "EMPTY" >> return Empty + , string "ANY" >> return Any + , try mixed + , children + ] + +-- [47] children ::= (choice | seq) ('?' | '*' | '+')? +children :: Parser ContentSpec +children = do + a <- try cpChoice <|> cpSeq + f <- option id multi + return (Children (f a)) + +multi :: Parser (CP -> CP) +multi = (char '?' >> return QuestionMark) + <|> (char '*' >> return Star) + <|> (char '+' >> return Plus) + +-- [48] cp ::= (Name | choice | seq) ('?' | '*' | '+')? +cp :: Parser CP +cp = do + a <- fmap CPName name <|> try cpChoice <|> cpSeq + f <- option id multi + return (f a) + +-- [49] choice ::= '(' S? cp ( S? '|' S? cp )+ S? ')' +cpChoice :: Parser CP +cpChoice = parens $ do + mspace + x <- cp + xs <- many1 (try (mspace >> char '|' >> mspace >> cp)) + mspace + return (Choice (x:xs)) + +-- [50] seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' +cpSeq :: Parser CP +cpSeq = parens $ do + mspace + x <- cp + xs <- many (try (mspace >> char ',' >> mspace >> cp)) + mspace + return (Sequence (x:xs)) + +-- [51] Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' +-- | '(' S? '#PCDATA' S? ')' +mixed :: Parser ContentSpec +mixed = char '(' >> mspace >> string "#PCDATA" >> (rest1 <|> rest2) + where + p = mspace >> char '|' >> mspace >> name + rest1 = try $ do + xs <- many (try p) + mspace + skip (string ")*") + return (Mixed True xs) + rest2 = mspace >> char ')' >> return (Mixed False []) + +-------------------------------------------------- +-- ** 3.3 Attribute-List Declarations + +-- [52] AttlistDecl ::= '' +attlistDecl :: Parser DocTypeDecl +attlistDecl = do + skip (string "') + return (AttListDecl n ds) + +-- [53] AttDef ::= S Name S AttType S DefaultDecl +attDef :: Parser AttDef +attDef = do + space + n <- name + space + tp <- attType + space + dd <- defaultDecl + return (n, tp, dd) + +-- [54] AttType ::= StringType | TokenizedType | EnumeratedType +attType :: Parser AttType +attType = stringType <|> tokenizedType <|> enumeratedType + +-- [55] StringType ::= 'CDATA' +stringType :: Parser AttType +stringType = string "CDATA" >> return StringType + +-- [56] TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' +tokenizedType :: Parser AttType +tokenizedType = choice (map f xs) + where + f (tp, s) = try (string s) >> return tp + xs = [ (IdRefsType, "IDREFS"), (IdRefType, "IDREF"), (IdType, "ID"), (EntityType, "ENTITY") + , (EntitiesType, "ENTITIES"), (NmTokensType, "NMTOKENS"), (NmTokenType, "NMTOKEN") + ] + +-- [57] EnumeratedType ::= NotationType | Enumeration +enumeratedType :: Parser AttType +enumeratedType = notationType <|> enumeration + +-- [58] NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' +notationType :: Parser AttType +notationType = string "NOTATION" >> space >> parens p + where + p = do + mspace + n <- name + ns <- many (try (mspace >> char '|' >> mspace >> name)) + mspace + return (NotationType (n:ns)) + +-- [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' +enumeration :: Parser AttType +enumeration = parens $ do + mspace + x <- nmtoken + xs <- many (try (mspace >> char '|' >> mspace >> nmtoken)) + mspace + return (EnumerationType (x:xs)) + +-- [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) +defaultDecl :: Parser DefaultDecl +defaultDecl = try (string "#REQUIRED" >> return Required) + <|> try (string "#IMPLIED" >> return Implied) + <|> do f <- option Value (string "#FIXED" >> space >> return Fixed) + a <- attValue + return (f a) + +-------------------------------------------------- +-- ** 3.4 Conditional Sections + +-- [61] conditionalSect ::= includeSect | ignoreSect +conditionalSect :: Parser Conditional +conditionalSect = try includeSect <|> ignoreSect + +-- [62] includeSect ::= '' +includeSect :: Parser Conditional +includeSect = do + skip (string "") + return (Include ds) + +-- [63] ignoreSect ::= '' +ignoreSect :: Parser Conditional +ignoreSect = do + skip (string "") + return (Ignore (concat xss)) + +-- [64] ignoreSectContents ::= Ignore ('' Ignore)* +ignoreSectContents :: Parser [String] +ignoreSectContents = + do x <- ignore + xss <- many $ do + skip (string "") + y <- ignore + return (ys++[y]) + return (x:concat xss) + +-- [65] Ignore ::= Char* - (Char* ('') Char*) +ignore :: Parser String +ignore = stopOn [""] + +-------------------------------------------------- +-- * 4 Physical Structures + +-------------------------------------------------- +-- ** 4.1 Character and Entity References + +-- [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';' +charRef :: Parser Reference +charRef = do + skip (string "&#") + n <- p <|> (char 'x' >> q) + skip (char ';') + return (CharRef n) + where + p = fmap (foldl' (\a b -> a*10+ord b-48) 0) (many1 ('0' <..> '9')) + q = fmap hexa (many1 (ranges [('0', '9'), ('a', 'f'), ('A', 'F')])) + +hexa :: String -> Int +hexa = rec 0 + where + rec n [] = n + rec n (x:xs) = rec (16*n + ord x - correct) xs + where + correct + | x <= '9' = ord '0' + | x <= 'F' = ord 'A' - 10 + | otherwise = ord 'a' - 10 + +-- [67] Reference ::= EntityRef | CharRef +reference :: Parser Reference +reference = try entityRef <|> charRef + +-- [68] EntityRef ::= '&' Name ';' +entityRef :: Parser Reference +entityRef = between (char '&') (char ';') (fmap EntityRef name) + +-- [69] PEReference ::= '%' Name ';' +peReference :: Parser Parameter +peReference = between (char '%') (char ';') (fmap Parameter name) + +-------------------------------------------------- +-- ** 4.2 Entity Declarations + +-- [70] EntityDecl ::= GEDecl | PEDecl +entityDecl :: Parser DocTypeDecl +entityDecl = try geDecl <|> peDecl + +-- [71] GEDecl ::= '' +geDecl :: Parser DocTypeDecl +geDecl = do + skip (string "') + return (EntityDecl True n ed) + +-- [72] PEDecl ::= '' +peDecl :: Parser DocTypeDecl +peDecl = do + skip (string "') + return (EntityDecl False n (either Left (\a -> Right (a, Nothing)) e)) + +-- [73] EntityDef ::= EntityValue | (ExternalID NDataDecl?) +entityDef :: Parser EntityDef +entityDef = fmap Left entityValue <|> do + e <- externalID + ms <- optionMaybe (try nDataDecl) + return (Right (e, ms)) + +-- [74] PEDef ::= EntityValue | ExternalID +peDef :: Parser (Either EntityValue ExternalID) +peDef = fmap Left entityValue <|> fmap Right externalID + +-- [75] ExternalID ::= 'SYSTEM' S SystemLiteral | 'PUBLIC' S PubidLiteral S SystemLiteral +externalID :: Parser ExternalID +externalID = (string "SYSTEM" >> space >> fmap System systemLiteral) <|> do + skip (string "PUBLIC") + space + x <- pubidLiteral + space + y <- systemLiteral + return (Public x y) + +-- [76] NDataDecl ::= S 'NDATA' S Name +nDataDecl :: Parser String +nDataDecl = space >> string "NDATA" >> space >> name + +-------------------------------------------------- +-- ** 4.3 Parsed Entities + +-- [77] TextDecl ::= '' + +textDecl :: Parser TextDecl +textDecl = do + skip (string "") + return (v, e) + +-- [78] extParsedEnt ::= TextDecl? content +extParsedEnt :: Parser (Maybe TextDecl, Content) +extParsedEnt = do + td <- optionMaybe (try textDecl) + c <- content + return (td, c) + +-- [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" ) +encodingDecl :: Parser String +encodingDecl = space >> string "encoding" >> eq >> + (singleQuoted encName <|> doubleQuoted encName) + +-- [81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')* +encName :: Parser String +encName = do + x <- ranges [('A', 'Z'), ('a', 'z')] + xs <- many (ranges [('A', 'Z'), ('a', 'z'), ('0', '9')] <|> oneOf "._-") + return (x:xs) + +-------------------------------------------------- +-- ** 4.7 Notation Declarations + +-- [82] NotationDecl ::= '' +notationDecl :: Parser DocTypeDecl +notationDecl = do + skip (string " fmap Right publicID + mspace + skip (char '>') + return (NotationDecl n e) + +-- [83] PublicID ::= 'PUBLIC' S PubidLiteral +publicID :: Parser PublicID publicID = string "PUBLIC" >> space >> pubidLiteral diff --git a/src/Text/XML/TestSuite.hs b/src/Text/XML/TestSuite.hs deleted file mode 100644 --- a/src/Text/XML/TestSuite.hs +++ /dev/null @@ -1,95 +0,0 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- The XML specification comes with a test suite for testing the correctness --- of a parser. This module performs these tests. --- ------------------------------------------------------------------------------ -module Main (main) where - -import Text.XML.Interface -import Text.XML.Document (trim) -import Control.Monad.Error -import Data.Maybe - -{-testje = do - xs <- readFile "tmp.xml" >>= decoding - print xs - --print (take 3 $ drop 318 $ lines xs) - print (parse document xs) - print (map (\x -> (x, ord x)) xs) -} - -rootDir :: String -rootDir = "D:/xmlts20080827/xmlconf" - -main :: IO () -main = parseIO (rootDir ++ "/xmlconf.xml") >>= runTestSuite - -printProfile :: Element -> IO () -printProfile = - maybe (return ()) putStrLn . findAttribute "PROFILE" - -runTestSuite :: Element -> IO () -runTestSuite e - | name e /= "TESTSUITE" = fail "expected TESTSUITE" - | otherwise = do - printProfile e - is <- mapM (runTestCases ".") (children e) - putStrLn (replicate 40 '*') - putStrLn $ "Test cases failed: " ++ show (sum is) - -runTestCases :: String -> Element -> IO Int -runTestCases base e - | name e /= "TESTCASES" = fail "expected TESTCASES" - | otherwise = do - printProfile e - let newbase = fromMaybe base (findAttribute "xml:base" e) - is <- forM (children e) $ \x -> - if name x == "TESTCASES" - then runTestCases newbase x - else do b <- runTest newbase x - return (if b then 0 else 1) - return (sum is) - -runTest :: String -> Element -> IO Bool -runTest base e - | name e /= "TEST" = fail "expected TEST" - | otherwise = do - let filename = rootDir ++ "/" ++ base ++ "/" ++ uri - uri = fromMaybe "." (findAttribute "URI" e) - testtype = fromMaybe "" (findAttribute "TYPE" e) - reccom = findAttribute "RECOMMENDATION" e - {-case reccom of - Nothing -> return () - Just "XML1.1" -> return () - Just "XML1.0-errata2e" -> return () - Just "NS1.0" -> return () - Just "NS1.1" -> return () - Just "XML1.0-errata3e" -> return () - Just "XML1.0-errata4e" -> return () - Just "NS1.0-errata1e" -> return () -} - if reccom /= Nothing then return True else do - putChar '.' - mdoc <- (do a <- parseIO filename; return (Just a)) - `catch` (\_ -> return Nothing) - case mdoc of - Just _ - -- not (accept document (show doc)) -> error ("pretty-print error: " ++ show doc) - | testtype == "valid" -> return True - Nothing - | testtype == "not-wf" -> return True - | testtype == "error" -> return True - | testtype == "invalid" -> return True - _ | testtype /= "valid" {- && testtype /= "not-wf" -} -> return True - _ -> do - putStrLn $ "\nFilename: " ++ show filename - putStrLn $ "Test type: " ++ show testtype - putStrLn $ "Description: " ++ trim (getData e) - return False diff --git a/src/Text/XML/Unicode.hs b/src/Text/XML/Unicode.hs --- a/src/Text/XML/Unicode.hs +++ b/src/Text/XML/Unicode.hs @@ -1,193 +1,193 @@ ------------------------------------------------------------------------------ --- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Support for Unicode --- ------------------------------------------------------------------------------ -module Text.XML.Unicode - ( isExtender, isLetter, isDigit, isCombiningChar - , extenderMap, letterMap, digitMap, combiningCharMap - , decoding - ) where - -import Data.Char (chr, ord) -import qualified Text.UTF8 as UTF8 - -data Tree a = Node (Tree a) a (Tree a) | Leaf - -isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool -isLetter = checkTree $ makeTree letterMap -isExtender = checkTree $ makeTree extenderMap -isDigit = checkTree $ makeTree digitMap -isCombiningChar = checkTree $ makeTree combiningCharMap - -checkTree :: Tree (Char, Char) -> Char -> Bool -checkTree Leaf _ = False -checkTree (Node l (c1, c2) r) c = - case compare c1 c of - LT -> case compare c c2 of - LT -> True - EQ -> True - GT -> checkTree r c - EQ -> True - GT -> checkTree l c - -makeTree :: [a] -> Tree a -makeTree [] = Leaf -makeTree xs = Node (makeTree ys) z (makeTree zs) - where (ys, z:zs) = splitAt n xs - n = length xs `div` 2 - -f :: Char -> (Char, Char) -f c = (c, c) - -letterMap :: [(Char, Char)] -letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap - -merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)] -merge (x:xs) (y:ys) - | x <= y = x:merge xs (y:ys) - | otherwise = y:merge (x:xs) ys -merge xs ys = xs++ys - -extraMap :: [(Char, Char)] -extraMap = map f "\161\170\184\185" - -controlMap :: [(Char, Char)] -controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'), - ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'), - ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'), - ('\x7FFFE', '\x7FFFF'), ('\x8FFFE', '\x8FFFF'), ('\x9FFFE', '\x9FFFF'), - ('\xAFFFE', '\xAFFFF'), ('\xBFFFE', '\xBFFFF'), ('\xCFFFE', '\xCFFFF'), - ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'), - ('\x10FFFE', '\x10FFFF')] - -baseCharMap :: [(Char, Char)] -baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'), - ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'), - ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'), - ('\x0180','\x01C3'), ('\x01CD','\x01F0'), ('\x01F4','\x01F5'), - ('\x01FA','\x0217'), ('\x0250','\x02A8'), ('\x02BB','\x02C1'), f '\x0386' , - ('\x0388','\x038A'), f '\x038C' , ('\x038E','\x03A1'), ('\x03A3','\x03CE'), - ('\x03D0','\x03D6'), f '\x03DA' , f '\x03DC' , f '\x03DE' , f '\x03E0' , - ('\x03E2','\x03F3'), ('\x0401','\x040C'), ('\x040E','\x044F'), - ('\x0451','\x045C'), ('\x045E','\x0481'), ('\x0490','\x04C4'), - ('\x04C7','\x04C8'), ('\x04CB','\x04CC'), ('\x04D0','\x04EB'), - ('\x04EE','\x04F5'), ('\x04F8','\x04F9'), ('\x0531','\x0556'), f '\x0559' , - ('\x0561','\x0586'), ('\x05D0','\x05EA'), ('\x05F0','\x05F2'), - ('\x0621','\x063A'), ('\x0641','\x064A'), ('\x0671','\x06B7'), - ('\x06BA','\x06BE'), ('\x06C0','\x06CE'), ('\x06D0','\x06D3'), f '\x06D5' , - ('\x06E5','\x06E6'), ('\x0905','\x0939'), f '\x093D' , ('\x0958','\x0961'), - ('\x0985','\x098C'), ('\x098F','\x0990'), ('\x0993','\x09A8'), - ('\x09AA','\x09B0'), f '\x09B2' , ('\x09B6','\x09B9'), ('\x09DC','\x09DD'), - ('\x09DF','\x09E1'), ('\x09F0','\x09F1'), ('\x0A05','\x0A0A'), - ('\x0A0F','\x0A10'), ('\x0A13','\x0A28'), ('\x0A2A','\x0A30'), - ('\x0A32','\x0A33'), ('\x0A35','\x0A36'), ('\x0A38','\x0A39'), - ('\x0A59','\x0A5C'), f '\x0A5E' , ('\x0A72','\x0A74'), ('\x0A85','\x0A8B'), - f '\x0A8D' , ('\x0A8F','\x0A91'), ('\x0A93','\x0AA8'), ('\x0AAA','\x0AB0'), - ('\x0AB2','\x0AB3'), ('\x0AB5','\x0AB9'), f '\x0ABD' , f '\x0AE0' , - ('\x0B05','\x0B0C'), ('\x0B0F','\x0B10'), ('\x0B13','\x0B28'), - ('\x0B2A','\x0B30'), ('\x0B32','\x0B33'), ('\x0B36','\x0B39'), f '\x0B3D' , - ('\x0B5C','\x0B5D'), ('\x0B5F','\x0B61'), ('\x0B85','\x0B8A'), - ('\x0B8E','\x0B90'), ('\x0B92','\x0B95'), ('\x0B99','\x0B9A'), f '\x0B9C' , - ('\x0B9E','\x0B9F'), ('\x0BA3','\x0BA4'), ('\x0BA8','\x0BAA'), - ('\x0BAE','\x0BB5'), ('\x0BB7','\x0BB9'), ('\x0C05','\x0C0C'), - ('\x0C0E','\x0C10'), ('\x0C12','\x0C28'), ('\x0C2A','\x0C33'), - ('\x0C35','\x0C39'), ('\x0C60','\x0C61'), ('\x0C85','\x0C8C'), - ('\x0C8E','\x0C90'), ('\x0C92','\x0CA8'), ('\x0CAA','\x0CB3'), - ('\x0CB5','\x0CB9'), f '\x0CDE' , ('\x0CE0','\x0CE1'), ('\x0D05','\x0D0C'), - ('\x0D0E','\x0D10'), ('\x0D12','\x0D28'), ('\x0D2A','\x0D39'), - ('\x0D60','\x0D61'), ('\x0E01','\x0E2E'), f '\x0E30' , ('\x0E32','\x0E33'), - ('\x0E40','\x0E45'), ('\x0E81','\x0E82'), f '\x0E84' , ('\x0E87','\x0E88'), - f '\x0E8A' , f '\x0E8D' , ('\x0E94','\x0E97'), ('\x0E99','\x0E9F'), - ('\x0EA1','\x0EA3'), f '\x0EA5' , f '\x0EA7' , ('\x0EAA','\x0EAB'), - ('\x0EAD','\x0EAE'), f '\x0EB0' , ('\x0EB2','\x0EB3'), f '\x0EBD' , - ('\x0EC0','\x0EC4'), ('\x0F40','\x0F47'), ('\x0F49','\x0F69'), - ('\x10A0','\x10C5'), ('\x10D0','\x10F6'), f '\x1100' , ('\x1102','\x1103'), - ('\x1105','\x1107'), f '\x1109' , ('\x110B','\x110C'), ('\x110E','\x1112'), - f '\x113C' , f '\x113E' , f '\x1140' , f '\x114C' , f '\x114E' , f '\x1150' , ('\x1154','\x1155') , - f '\x1159' , ('\x115F','\x1161'), f '\x1163' , f '\x1165' , f '\x1167' , f '\x1169' , - ('\x116D','\x116E'), ('\x1172','\x1173'), f '\x1175' , f '\x119E' , f '\x11A8' , - f '\x11AB' , ('\x11AE','\x11AF'), ('\x11B7','\x11B8'), f '\x11BA' , - ('\x11BC','\x11C2'), f '\x11EB' , f '\x11F0' , f '\x11F9' , ('\x1E00','\x1E9B'), - ('\x1EA0','\x1EF9'), ('\x1F00','\x1F15'), ('\x1F18','\x1F1D'), - ('\x1F20','\x1F45'), ('\x1F48','\x1F4D'), ('\x1F50','\x1F57'), f '\x1F59' , - f '\x1F5B' , f '\x1F5D' , ('\x1F5F','\x1F7D'), ('\x1F80','\x1FB4'), - ('\x1FB6','\x1FBC'), f '\x1FBE' , ('\x1FC2','\x1FC4'), ('\x1FC6','\x1FCC'), - ('\x1FD0','\x1FD3'), ('\x1FD6','\x1FDB'), ('\x1FE0','\x1FEC'), - ('\x1FF2','\x1FF4'), ('\x1FF6','\x1FFC'), f '\x2126' , ('\x212A','\x212B'), - f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'), - ('\x3105','\x312C'), ('\xAC00','\xD7A3') ] - -ideographicMap :: [(Char, Char)] -ideographicMap = [ ('\x4E00','\x9FA5'), - f '\x3007' , ('\x3021','\x3029') ] - -combiningCharMap :: [(Char, Char)] -combiningCharMap = [('\x0300','\x0345'), - ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'), - ('\x05A3','\x05B9'), ('\x05BB','\x05BD'), f '\x05BF' , ('\x05C1','\x05C2'), - f '\x05C4' , ('\x064B','\x0652'), f '\x0670' , ('\x06D6','\x06DC'), - ('\x06DD','\x06DF'), ('\x06E0','\x06E4'), ('\x06E7','\x06E8'), - ('\x06EA','\x06ED'), ('\x0901','\x0903'), f '\x093C' , ('\x093E','\x094C'), - f '\x094D' , ('\x0951','\x0954'), ('\x0962','\x0963'), ('\x0981','\x0983'), - f '\x09BC' , f '\x09BE' , f '\x09BF' , ('\x09C0','\x09C4'), ('\x09C7','\x09C8'), - ('\x09CB','\x09CD'), f '\x09D7' , ('\x09E2','\x09E3'), f '\x0A02' , f '\x0A3C' , - f '\x0A3E' , f '\x0A3F' , ('\x0A40','\x0A42'), ('\x0A47','\x0A48'), - ('\x0A4B','\x0A4D'), ('\x0A70','\x0A71'), ('\x0A81','\x0A83'), f '\x0ABC' , - ('\x0ABE','\x0AC5'), ('\x0AC7','\x0AC9'), ('\x0ACB','\x0ACD'), - ('\x0B01','\x0B03'), f '\x0B3C' , ('\x0B3E','\x0B43'), ('\x0B47','\x0B48'), - ('\x0B4B','\x0B4D'), ('\x0B56','\x0B57'), ('\x0B82','\x0B83'), - ('\x0BBE','\x0BC2'), ('\x0BC6','\x0BC8'), ('\x0BCA','\x0BCD'), f '\x0BD7' , - ('\x0C01','\x0C03'), ('\x0C3E','\x0C44'), ('\x0C46','\x0C48'), - ('\x0C4A','\x0C4D'), ('\x0C55','\x0C56'), ('\x0C82','\x0C83'), - ('\x0CBE','\x0CC4'), ('\x0CC6','\x0CC8'), ('\x0CCA','\x0CCD'), - ('\x0CD5','\x0CD6'), ('\x0D02','\x0D03'), ('\x0D3E','\x0D43'), - ('\x0D46','\x0D48'), ('\x0D4A','\x0D4D'), f '\x0D57' , f '\x0E31' , - ('\x0E34','\x0E3A'), ('\x0E47','\x0E4E'), f '\x0EB1' , ('\x0EB4','\x0EB9'), - ('\x0EBB','\x0EBC'), ('\x0EC8','\x0ECD'), ('\x0F18','\x0F19'), f '\x0F35' , - f '\x0F37' , f '\x0F39' , f '\x0F3E' , f '\x0F3F' , ('\x0F71','\x0F84'), - ('\x0F86','\x0F8B'), ('\x0F90','\x0F95'), f '\x0F97' , ('\x0F99','\x0FAD'), - ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' , - ('\x302A','\x302F'), f '\x3099' , f '\x309A' ] - -digitMap :: [(Char, Char)] -digitMap = [ ('\x0030','\x0039'), - ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'), - ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'), - ('\x0B66','\x0B6F'), ('\x0BE7','\x0BEF'), ('\x0C66','\x0C6F'), - ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'), - ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')] - -extenderMap :: [(Char, Char)] -extenderMap = [f '\x00B7' , f '\x02D0' , - f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035') - , ('\x309D','\x309E'), ('\x30FC','\x30FE') ] - -decoding :: Monad m => String -> m String -decoding xs - | take 2 xs == "\255\254" = - return (decode16 $ drop 2 xs) - | take 2 xs == "\254\255" = - return (decode16X $ drop 2 xs) - | take 3 xs == "\239\187\191" = - UTF8.decodeM (drop 3 xs) - | otherwise = - UTF8.decodeM xs - -decode16 :: [Char] -> [Char] -decode16 [] = [] -decode16 [x] = [x] -decode16 (a:b:rest) = chr (ord b * 256 + ord a) : decode16 rest - -decode16X :: [Char] -> [Char] -decode16X [] = [] -decode16X [x] = [x] +----------------------------------------------------------------------------- +-- Copyright 2011, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for Unicode +-- +----------------------------------------------------------------------------- +module Text.XML.Unicode + ( isExtender, isLetter, isDigit, isCombiningChar + , extenderMap, letterMap, digitMap, combiningCharMap + , decoding + ) where + +import Data.Char (chr, ord) +import qualified Text.UTF8 as UTF8 + +data Tree a = Node (Tree a) a (Tree a) | Leaf + +isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool +isLetter = checkTree $ makeTree letterMap +isExtender = checkTree $ makeTree extenderMap +isDigit = checkTree $ makeTree digitMap +isCombiningChar = checkTree $ makeTree combiningCharMap + +checkTree :: Tree (Char, Char) -> Char -> Bool +checkTree Leaf _ = False +checkTree (Node l (c1, c2) r) c = + case compare c1 c of + LT -> case compare c c2 of + LT -> True + EQ -> True + GT -> checkTree r c + EQ -> True + GT -> checkTree l c + +makeTree :: [a] -> Tree a +makeTree [] = Leaf +makeTree xs = Node (makeTree ys) z (makeTree zs) + where (ys, z:zs) = splitAt n xs + n = length xs `div` 2 + +f :: Char -> (Char, Char) +f c = (c, c) + +letterMap :: [(Char, Char)] +letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap + +merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)] +merge (x:xs) (y:ys) + | x <= y = x:merge xs (y:ys) + | otherwise = y:merge (x:xs) ys +merge xs ys = xs++ys + +extraMap :: [(Char, Char)] +extraMap = map f "\161\170\184\185" + +controlMap :: [(Char, Char)] +controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'), + ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'), + ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'), + ('\x7FFFE', '\x7FFFF'), ('\x8FFFE', '\x8FFFF'), ('\x9FFFE', '\x9FFFF'), + ('\xAFFFE', '\xAFFFF'), ('\xBFFFE', '\xBFFFF'), ('\xCFFFE', '\xCFFFF'), + ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'), + ('\x10FFFE', '\x10FFFF')] + +baseCharMap :: [(Char, Char)] +baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'), + ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'), + ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'), + ('\x0180','\x01C3'), ('\x01CD','\x01F0'), ('\x01F4','\x01F5'), + ('\x01FA','\x0217'), ('\x0250','\x02A8'), ('\x02BB','\x02C1'), f '\x0386' , + ('\x0388','\x038A'), f '\x038C' , ('\x038E','\x03A1'), ('\x03A3','\x03CE'), + ('\x03D0','\x03D6'), f '\x03DA' , f '\x03DC' , f '\x03DE' , f '\x03E0' , + ('\x03E2','\x03F3'), ('\x0401','\x040C'), ('\x040E','\x044F'), + ('\x0451','\x045C'), ('\x045E','\x0481'), ('\x0490','\x04C4'), + ('\x04C7','\x04C8'), ('\x04CB','\x04CC'), ('\x04D0','\x04EB'), + ('\x04EE','\x04F5'), ('\x04F8','\x04F9'), ('\x0531','\x0556'), f '\x0559' , + ('\x0561','\x0586'), ('\x05D0','\x05EA'), ('\x05F0','\x05F2'), + ('\x0621','\x063A'), ('\x0641','\x064A'), ('\x0671','\x06B7'), + ('\x06BA','\x06BE'), ('\x06C0','\x06CE'), ('\x06D0','\x06D3'), f '\x06D5' , + ('\x06E5','\x06E6'), ('\x0905','\x0939'), f '\x093D' , ('\x0958','\x0961'), + ('\x0985','\x098C'), ('\x098F','\x0990'), ('\x0993','\x09A8'), + ('\x09AA','\x09B0'), f '\x09B2' , ('\x09B6','\x09B9'), ('\x09DC','\x09DD'), + ('\x09DF','\x09E1'), ('\x09F0','\x09F1'), ('\x0A05','\x0A0A'), + ('\x0A0F','\x0A10'), ('\x0A13','\x0A28'), ('\x0A2A','\x0A30'), + ('\x0A32','\x0A33'), ('\x0A35','\x0A36'), ('\x0A38','\x0A39'), + ('\x0A59','\x0A5C'), f '\x0A5E' , ('\x0A72','\x0A74'), ('\x0A85','\x0A8B'), + f '\x0A8D' , ('\x0A8F','\x0A91'), ('\x0A93','\x0AA8'), ('\x0AAA','\x0AB0'), + ('\x0AB2','\x0AB3'), ('\x0AB5','\x0AB9'), f '\x0ABD' , f '\x0AE0' , + ('\x0B05','\x0B0C'), ('\x0B0F','\x0B10'), ('\x0B13','\x0B28'), + ('\x0B2A','\x0B30'), ('\x0B32','\x0B33'), ('\x0B36','\x0B39'), f '\x0B3D' , + ('\x0B5C','\x0B5D'), ('\x0B5F','\x0B61'), ('\x0B85','\x0B8A'), + ('\x0B8E','\x0B90'), ('\x0B92','\x0B95'), ('\x0B99','\x0B9A'), f '\x0B9C' , + ('\x0B9E','\x0B9F'), ('\x0BA3','\x0BA4'), ('\x0BA8','\x0BAA'), + ('\x0BAE','\x0BB5'), ('\x0BB7','\x0BB9'), ('\x0C05','\x0C0C'), + ('\x0C0E','\x0C10'), ('\x0C12','\x0C28'), ('\x0C2A','\x0C33'), + ('\x0C35','\x0C39'), ('\x0C60','\x0C61'), ('\x0C85','\x0C8C'), + ('\x0C8E','\x0C90'), ('\x0C92','\x0CA8'), ('\x0CAA','\x0CB3'), + ('\x0CB5','\x0CB9'), f '\x0CDE' , ('\x0CE0','\x0CE1'), ('\x0D05','\x0D0C'), + ('\x0D0E','\x0D10'), ('\x0D12','\x0D28'), ('\x0D2A','\x0D39'), + ('\x0D60','\x0D61'), ('\x0E01','\x0E2E'), f '\x0E30' , ('\x0E32','\x0E33'), + ('\x0E40','\x0E45'), ('\x0E81','\x0E82'), f '\x0E84' , ('\x0E87','\x0E88'), + f '\x0E8A' , f '\x0E8D' , ('\x0E94','\x0E97'), ('\x0E99','\x0E9F'), + ('\x0EA1','\x0EA3'), f '\x0EA5' , f '\x0EA7' , ('\x0EAA','\x0EAB'), + ('\x0EAD','\x0EAE'), f '\x0EB0' , ('\x0EB2','\x0EB3'), f '\x0EBD' , + ('\x0EC0','\x0EC4'), ('\x0F40','\x0F47'), ('\x0F49','\x0F69'), + ('\x10A0','\x10C5'), ('\x10D0','\x10F6'), f '\x1100' , ('\x1102','\x1103'), + ('\x1105','\x1107'), f '\x1109' , ('\x110B','\x110C'), ('\x110E','\x1112'), + f '\x113C' , f '\x113E' , f '\x1140' , f '\x114C' , f '\x114E' , f '\x1150' , ('\x1154','\x1155') , + f '\x1159' , ('\x115F','\x1161'), f '\x1163' , f '\x1165' , f '\x1167' , f '\x1169' , + ('\x116D','\x116E'), ('\x1172','\x1173'), f '\x1175' , f '\x119E' , f '\x11A8' , + f '\x11AB' , ('\x11AE','\x11AF'), ('\x11B7','\x11B8'), f '\x11BA' , + ('\x11BC','\x11C2'), f '\x11EB' , f '\x11F0' , f '\x11F9' , ('\x1E00','\x1E9B'), + ('\x1EA0','\x1EF9'), ('\x1F00','\x1F15'), ('\x1F18','\x1F1D'), + ('\x1F20','\x1F45'), ('\x1F48','\x1F4D'), ('\x1F50','\x1F57'), f '\x1F59' , + f '\x1F5B' , f '\x1F5D' , ('\x1F5F','\x1F7D'), ('\x1F80','\x1FB4'), + ('\x1FB6','\x1FBC'), f '\x1FBE' , ('\x1FC2','\x1FC4'), ('\x1FC6','\x1FCC'), + ('\x1FD0','\x1FD3'), ('\x1FD6','\x1FDB'), ('\x1FE0','\x1FEC'), + ('\x1FF2','\x1FF4'), ('\x1FF6','\x1FFC'), f '\x2126' , ('\x212A','\x212B'), + f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'), + ('\x3105','\x312C'), ('\xAC00','\xD7A3') ] + +ideographicMap :: [(Char, Char)] +ideographicMap = [ ('\x4E00','\x9FA5'), + f '\x3007' , ('\x3021','\x3029') ] + +combiningCharMap :: [(Char, Char)] +combiningCharMap = [('\x0300','\x0345'), + ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'), + ('\x05A3','\x05B9'), ('\x05BB','\x05BD'), f '\x05BF' , ('\x05C1','\x05C2'), + f '\x05C4' , ('\x064B','\x0652'), f '\x0670' , ('\x06D6','\x06DC'), + ('\x06DD','\x06DF'), ('\x06E0','\x06E4'), ('\x06E7','\x06E8'), + ('\x06EA','\x06ED'), ('\x0901','\x0903'), f '\x093C' , ('\x093E','\x094C'), + f '\x094D' , ('\x0951','\x0954'), ('\x0962','\x0963'), ('\x0981','\x0983'), + f '\x09BC' , f '\x09BE' , f '\x09BF' , ('\x09C0','\x09C4'), ('\x09C7','\x09C8'), + ('\x09CB','\x09CD'), f '\x09D7' , ('\x09E2','\x09E3'), f '\x0A02' , f '\x0A3C' , + f '\x0A3E' , f '\x0A3F' , ('\x0A40','\x0A42'), ('\x0A47','\x0A48'), + ('\x0A4B','\x0A4D'), ('\x0A70','\x0A71'), ('\x0A81','\x0A83'), f '\x0ABC' , + ('\x0ABE','\x0AC5'), ('\x0AC7','\x0AC9'), ('\x0ACB','\x0ACD'), + ('\x0B01','\x0B03'), f '\x0B3C' , ('\x0B3E','\x0B43'), ('\x0B47','\x0B48'), + ('\x0B4B','\x0B4D'), ('\x0B56','\x0B57'), ('\x0B82','\x0B83'), + ('\x0BBE','\x0BC2'), ('\x0BC6','\x0BC8'), ('\x0BCA','\x0BCD'), f '\x0BD7' , + ('\x0C01','\x0C03'), ('\x0C3E','\x0C44'), ('\x0C46','\x0C48'), + ('\x0C4A','\x0C4D'), ('\x0C55','\x0C56'), ('\x0C82','\x0C83'), + ('\x0CBE','\x0CC4'), ('\x0CC6','\x0CC8'), ('\x0CCA','\x0CCD'), + ('\x0CD5','\x0CD6'), ('\x0D02','\x0D03'), ('\x0D3E','\x0D43'), + ('\x0D46','\x0D48'), ('\x0D4A','\x0D4D'), f '\x0D57' , f '\x0E31' , + ('\x0E34','\x0E3A'), ('\x0E47','\x0E4E'), f '\x0EB1' , ('\x0EB4','\x0EB9'), + ('\x0EBB','\x0EBC'), ('\x0EC8','\x0ECD'), ('\x0F18','\x0F19'), f '\x0F35' , + f '\x0F37' , f '\x0F39' , f '\x0F3E' , f '\x0F3F' , ('\x0F71','\x0F84'), + ('\x0F86','\x0F8B'), ('\x0F90','\x0F95'), f '\x0F97' , ('\x0F99','\x0FAD'), + ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' , + ('\x302A','\x302F'), f '\x3099' , f '\x309A' ] + +digitMap :: [(Char, Char)] +digitMap = [ ('\x0030','\x0039'), + ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'), + ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'), + ('\x0B66','\x0B6F'), ('\x0BE7','\x0BEF'), ('\x0C66','\x0C6F'), + ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'), + ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')] + +extenderMap :: [(Char, Char)] +extenderMap = [f '\x00B7' , f '\x02D0' , + f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035') + , ('\x309D','\x309E'), ('\x30FC','\x30FE') ] + +decoding :: Monad m => String -> m String +decoding xs + | take 2 xs == "\255\254" = + return (decode16 $ drop 2 xs) + | take 2 xs == "\254\255" = + return (decode16X $ drop 2 xs) + | take 3 xs == "\239\187\191" = + UTF8.decodeM (drop 3 xs) + | otherwise = + UTF8.decodeM xs + +decode16 :: [Char] -> [Char] +decode16 [] = [] +decode16 [x] = [x] +decode16 (a:b:rest) = chr (ord b * 256 + ord a) : decode16 rest + +decode16X :: [Char] -> [Char] +decode16X [] = [] +decode16X [x] = [x] decode16X (a:b:rest) = chr (ord b + ord a * 256) : decode16X rest