module Domain.Math.Fraction.Rules where import Control.Monad import Domain.Math.Expr import Domain.Math.Expr.Clipboard import Domain.Math.Numeric.Rules (calcPlusWith, calcMinusWith, calcTimesWith, calcDivisionWith) import Domain.Math.Numeric.Views import Ideas.Common.Library expandFractionSymbol :: Symbol expandFractionSymbol = newSymbol "elementary.expand_fraction" reduceFractionSymbol :: Symbol reduceFractionSymbol = newSymbol "elementary.reduce_fraction" -- Matching, borrowing from "Canonical forms..." MKM additionView :: View Expr (Expr, Expr) additionView = makeView f g where f (a :+: b) = Just (a,b) f _ = Nothing g (a, b) = a :+: b fractionView :: View Expr (Expr, Expr) fractionView = makeView f g where f (a :/: b) = Just (a,b) f _ = Nothing g (a, b) = a :/: b -- Find LCM, store it in the context findLCM :: Rule (Context Expr) findLCM = makeRule "findLCM" \$ \ctx -> do expr <- currentInContext ctx (e1,e2) <- match additionView expr (Nat _,Nat b) <- match fractionView e1 (Nat _,Nat d) <- match fractionView e2 guard (b/=d) return \$ addToClipboard "lcm" (Nat (lcm b d)) ctx -- expand unlike fractions to lcm if necessary expandToLCM :: Rule (Context Expr) expandToLCM = makeRule "expandToLCM" \$ \ctx -> do expr <- currentInContext ctx (Nat a,Nat b) <- match fractionView expr lcm <- lookupClipboardG "lcm" ctx guard (b /= lcm && lcm `mod` b == 0) return \$ replaceInContext (Nat(a * lcm `div` b) :/: Nat lcm) ctx addLikeFractions :: Rule (Context Expr) addLikeFractions = makeRule "addLikeFractions" \$ \ctx -> do expr <- currentInContext ctx (e1,e2) <- match additionView expr (Nat a,Nat b) <- match fractionView e1 (Nat c,Nat d) <- match fractionView e2 guard (b == d) return \$ replaceInContext (Nat(a + c) :/: Nat b) ctx -- Extra rules for diagnostics gcdRule :: Rule Expr gcdRule = makeRule "gcd" f where f (Sym gs [Nat a , Nat b]) | gs == gcdSymbol = Just (Nat (gcd a b)) f _ = Nothing lcmRule :: Rule Expr lcmRule = makeRule "lcm" f where f (Sym ls [Nat a, Nat b]) | ls == lcmSymbol = Just (Nat (lcm a b)) f _ = Nothing expandRule :: Rule Expr expandRule = makeRule "expand" f where f (Sym efs [Nat a :/: Nat b, Nat c]) | efs == expandFractionSymbol = Just (Nat (a*c) :/:Nat (b*c)) f _ = Nothing reduceRule :: Rule Expr reduceRule = makeRule "reduce" f where f (Sym cfs [Nat a :/: Nat b, Nat c]) | a `mod` c == 0 && b `mod`c == 0 && cfs == reduceFractionSymbol = Just (Nat (a `div` c) :/: Nat (b `div` c)) f _ = Nothing