diff --git a/CAS/Dumb/Symbols.hs b/CAS/Dumb/Symbols.hs --- a/CAS/Dumb/Symbols.hs +++ b/CAS/Dumb/Symbols.hs @@ -30,6 +30,7 @@ import Data.String (IsString) import GHC.Exts (Constraint) +import GHC.Stack (HasCallStack) import Data.Ratio (denominator, numerator) import Numeric.Literals.Decimal @@ -47,10 +48,13 @@ instance Eq s => Eq (Infix s) where Infix _ o == Infix _ p = o==p +type family SpecialEncapsulation s + data Encapsulation s = Encapsulation { needInnerParens, haveOuterparens :: !Bool , leftEncaps, rightEncaps :: !s } + | SpecialEncapsulation (SpecialEncapsulation s) instance Eq (Encapsulation String) where Encapsulation _ _ l r == Encapsulation _ _ l' r' @@ -59,6 +63,8 @@ dropParens (' ':lr) rr = dropParens lr rr dropParens lr (' ':rr) = dropParens lr rr dropParens lr rr = (lr,rr) + SpecialEncapsulation e == SpecialEncapsulation e' = e==e' + _ == _ = False type AlgebraExpr σ l = CAS (Infix l) (Encapsulation l) (SymbolD σ l) type AlgebraExpr' γ σ l = CAS' γ (Infix l) (Encapsulation l) (SymbolD σ l) @@ -82,6 +88,14 @@ -> CAS' γ (Infix s²) (Encapsulation s¹) s⁰ symbolFunction f a = Function (Encapsulation True False f mempty) a + + +data AlgebraicInvEncapsulation + = Negation | Reciprocal + deriving (Eq, Show) + +type instance SpecialEncapsulation String = AlgebraicInvEncapsulation + instance ∀ σ γ . (SymbolClass σ, SCConstraint σ String) => Num (AlgebraExpr' γ σ String) where fromInteger n @@ -93,27 +107,23 @@ (*) = chainableInfixL (==mulOp) mulOp where fcs = fromCharSymbol ([]::[σ]) mulOp = Infix (Hs.Fixity 7 Hs.InfixL) $ fcs '*' - (-) = symbolInfix (Infix (Hs.Fixity 6 Hs.InfixL) $ fcs '-') - where fcs = fromCharSymbol ([]::[σ]) abs = symbolFunction "abs " signum = symbolFunction "signum " - negate = Operator (Infix (Hs.Fixity 6 Hs.InfixL) $ fcs '-') - . Symbol $ StringSymbol " " - where fcs = fromCharSymbol ([]::[σ]) + negate = Function $ SpecialEncapsulation Negation instance ∀ σ γ . (SymbolClass σ, SCConstraint σ String) => Fractional (AlgebraExpr' γ σ String) where fromRational n = case fromRational n of n:%d -> fromIntegral n / fromIntegral d nSci -> Symbol (StringSymbol $ show nSci) - (/) = symbolInfix (Infix (Hs.Fixity 7 Hs.InfixL) $ fcs '/') - where fcs = fromCharSymbol ([]::[σ]) + recip = Function $ SpecialEncapsulation Reciprocal instance ∀ σ γ . (SymbolClass σ, SCConstraint σ String) => Floating (AlgebraExpr' γ σ String) where pi = Symbol $ StringSymbol "pi" - (**) = symbolInfix (Infix (Hs.Fixity 6 Hs.InfixL) "**") + (**) = symbolInfix (Infix (Hs.Fixity 8 Hs.InfixL) "**") logBase = symbolInfix (Infix (Hs.Fixity 10 Hs.InfixL) "`logBase`") + sqrt = symbolFunction $ "sqrt " exp = symbolFunction $ "exp " log = symbolFunction $ "log " sin = symbolFunction $ "sin " @@ -138,6 +148,43 @@ toASCIISymbols = id +class Eq (SpecialEncapsulation c) => RenderableEncapsulations c where + fixateAlgebraEncaps :: (SymbolClass σ, SCConstraint σ c) + => CAS' γ (Infix c) (Encapsulation c) (SymbolD σ c) + -> CAS' γ (Infix c) (Encapsulation c) (SymbolD σ c) + +instance RenderableEncapsulations String where + fixateAlgebraEncaps (OperatorChain x + ((o,Function (SpecialEncapsulation ι) z):ys)) + | (Infix (Hs.Fixity 6 Hs.InfixL) "+", Negation) <- (o,ι) + = case fixateAlgebraEncaps $ OperatorChain x ys of + x' -> Operator (Infix (Hs.Fixity 6 Hs.InfixL) "-") x' z' + | (Infix (Hs.Fixity 7 Hs.InfixL) "*", Reciprocal) <- (o,ι) + = case fixateAlgebraEncaps $ OperatorChain x ys of + x' -> Operator (Infix (Hs.Fixity 7 Hs.InfixL) "/") x' z' + where z' = fixateAlgebraEncaps z + fixateAlgebraEncaps (OperatorChain x []) = fixateAlgebraEncaps x + fixateAlgebraEncaps (OperatorChain x ((o@(Infix (Hs.Fixity _ Hs.InfixL) _), z):ys)) + = Operator o (fixateAlgebraEncaps $ OperatorChain x ys) (fixateAlgebraEncaps z) + fixateAlgebraEncaps (Operator o x (Function (SpecialEncapsulation ι) y)) + | (Infix (Hs.Fixity 6 Hs.InfixL) "+", Negation) <- (o,ι) + = Operator (Infix (Hs.Fixity 6 Hs.InfixL) "-") x' y' + | (Infix (Hs.Fixity 7 Hs.InfixL) "*", Reciprocal) <- (o,ι) + = Operator (Infix (Hs.Fixity 7 Hs.InfixL) "/") x' y' + where [x',y'] = fixateAlgebraEncaps<$>[x,y] + fixateAlgebraEncaps (Function (SpecialEncapsulation Negation) e) + = Operator (Infix (Hs.Fixity 6 Hs.InfixL) "-") + (Symbol $ StringSymbol " ") $ fixateAlgebraEncaps e + fixateAlgebraEncaps (Function (SpecialEncapsulation Reciprocal) e) + = Operator (Infix (Hs.Fixity 7 Hs.InfixL) "/") + (Symbol $ NatSymbol 1) $ fixateAlgebraEncaps e + fixateAlgebraEncaps (Function f e) = Function f $ fixateAlgebraEncaps e + fixateAlgebraEncaps (Operator o x y) + = Operator o (fixateAlgebraEncaps x) (fixateAlgebraEncaps y) + fixateAlgebraEncaps (OperatorChain x₀ oys) + = OperatorChain (fixateAlgebraEncaps x₀) (second fixateAlgebraEncaps <$> oys) + fixateAlgebraEncaps e = e + type RenderingCombinator σ c r = Bool -- ^ Should the result be parenthesised? -> Maybe r -- ^ Left context @@ -158,7 +205,7 @@ expressionFixity (OperatorChain x₀ []) = expressionFixity x₀ expressionFixity (Gap _) = Nothing -renderSymbolExpression :: ∀ σ c r . (SymbolClass σ, SCConstraint σ c) +renderSymbolExpression :: ∀ σ c r . (SymbolClass σ, SCConstraint σ c, HasCallStack) => ContextFixity -> RenderingCombinator σ c r -> AlgebraExpr σ c -> r renderSymbolExpression _ ρ (Symbol s) = ρ False Nothing s Nothing @@ -201,6 +248,8 @@ AtRHS (Hs.Fixity pfxty _) | Hs.Fixity lfxty _ <- fxty , lfxty==pfxty -> True AtRHS _ -> False +renderSymbolExpression _ _ (Function (SpecialEncapsulation _) _) = error + "`renderSymbolExpression` cannot handle `SpecialEncapsulation`; please pre-process accordingly." showsPrecASCIISymbol :: (ASCIISymbols c, SymbolClass σ, SCConstraint σ c) @@ -264,11 +313,14 @@ -- @ -- (map succ%$> 𝑎+𝑝) * 𝑥 ≡ (𝑏+𝑞) * 𝑥 -- @ +-- +-- Note that this can /not/ be used with number literals. (%$>) :: ∀ σ c c' γ s² s¹ . (SymbolClass σ, SCConstraint σ c) => (c -> c') -> CAS' γ s² s¹ (SymbolD σ c) -> CAS' γ s² s¹ (SymbolD σ c') f %$> Symbol (PrimitiveSymbol c) = case fromCharSymbol ([]::[σ]) of fcs -> Symbol . StringSymbol . f $ fcs c f %$> Symbol (StringSymbol s) = Symbol . StringSymbol $ f s +_ %$> Symbol (NatSymbol _) = error "`%$>` cannot be used with number literals." f %$> Function g q = Function g $ f %$> q f %$> Operator o p q = Operator o (f%$>p) (f%$>q) f %$> OperatorChain p qs = OperatorChain (f%$>p) (second (f%$>)<$>qs) diff --git a/CAS/Dumb/Symbols/ASCII.hs b/CAS/Dumb/Symbols/ASCII.hs --- a/CAS/Dumb/Symbols/ASCII.hs +++ b/CAS/Dumb/Symbols/ASCII.hs @@ -57,6 +57,17 @@ type Expression c = Expression' Void (Infix c) (Encapsulation c) c type Pattern c = Expression' GapId (Infix c) (Encapsulation c) c + +instance Unwieldy c => Unwieldy (Symbol c) where + unwieldiness (NatSymbol i) = 0.24127 + fromInteger (abs i) + unwieldiness (PrimitiveSymbol c) + | c>='a' && c<='z' = 1.17236 + fromIntegral (fromEnum 'z' - ucp)/49.4530 + | c>='A' && c<='Z' = 1.17211 + fromIntegral (fromEnum 'Z' - ucp)/49.4571 + | otherwise = 1.24551 + fromIntegral ucp / 52792.42 + + fromIntegral (ucp`mod`136)/9722.3 + where ucp = fromEnum c + unwieldiness (StringSymbol s) = unwieldiness s + makeSymbols ''Expression' ['a'..'z'] _a,_b,_c,_d,_e,_f,_g,_h,_i,_j,_k,_l,_m,_n,_o,_p,_q,_r,_s,_t,_u,_v,_w,_x,_y,_z @@ -77,11 +88,13 @@ makeSymbols ''Expression' ['A'..'Z'] #endif -instance ASCIISymbols c => Show (CAS (Infix c) (Encapsulation c) (Symbol c)) where - showsPrec = showsPrecASCIISymbol -instance ∀ c . (ASCIISymbols c, Monoid c) +instance (ASCIISymbols c, RenderableEncapsulations c) + => Show (CAS (Infix c) (Encapsulation c) (Symbol c)) where + showsPrec p = showsPrecASCIISymbol p . fixateAlgebraEncaps + where +instance ∀ c . (ASCIISymbols c, RenderableEncapsulations c, Monoid c) => Show (CAS' GapId (Infix c) (Encapsulation c) (Symbol c)) where - showsPrec p = showsPrecASCIISymbol p . purgeGaps + showsPrec p = showsPrecASCIISymbol p . purgeGaps . fixateAlgebraEncaps where purgeGaps (Symbol s) = Symbol s purgeGaps (Function f e) = Function f $ purgeGaps e purgeGaps (Operator o x y) = Operator o (purgeGaps x) (purgeGaps y) diff --git a/CAS/Dumb/Symbols/Unicode/MathLatin_RomanGreek__BopomofoGaps.hs b/CAS/Dumb/Symbols/Unicode/MathLatin_RomanGreek__BopomofoGaps.hs --- a/CAS/Dumb/Symbols/Unicode/MathLatin_RomanGreek__BopomofoGaps.hs +++ b/CAS/Dumb/Symbols/Unicode/MathLatin_RomanGreek__BopomofoGaps.hs @@ -78,6 +78,27 @@ type SCConstraint Unicode_MathLatin_RomanGreek__BopomofoGaps = UnicodeSymbols fromCharSymbol _ = fromUnicodeSymbol +instance Unwieldy c => Unwieldy (Symbol c) where + unwieldiness (NatSymbol i) = 0.24127 + fromInteger (abs i) + unwieldiness (PrimitiveSymbol c) + | c>='a' && c<='z' = 1.17236 + fromIntegral (fromEnum 'z' - ucp)/49.4530 + | c>='𝑎' && c<='𝑧' = 1.17249 + fromIntegral (fromEnum '𝑧' - ucp)/49.4564 + | c=='ℎ' = 1.17249 + fromIntegral (fromEnum 'z' - fromEnum 'h')/49.4564 + | c>='A' && c<='Z' = 1.17211 + fromIntegral (fromEnum 'Z' - ucp)/49.4571 + | c>='𝐴' && c<='𝑍' = 1.17213 + fromIntegral (fromEnum '𝑍' - ucp)/49.4511 + | c>='𝐚' && c<='𝐳' = 1.17228 + fromIntegral (fromEnum '𝐳' - ucp)/49.4572 + | c>='𝐀' && c<='𝐙' = 1.17210 + fromIntegral (fromEnum '𝐙' - ucp)/49.4518 + | c>='𝓐' && c<='𝓩' = 1.17212 + fromIntegral (fromEnum '𝓩' - ucp)/49.4528 + | c>='α' && c<='ω' = 1.03627 + fromIntegral (fromEnum 'ω' - ucp)/342.637 + | c=='ϑ' = 1.03628 + fromIntegral (fromEnum 'ω' - fromEnum 'θ')/342.637 + | c=='ϕ' = 1.03628 + fromIntegral (fromEnum 'ω' - fromEnum 'φ')/342.637 + | c>='Α' && c<='Ω' = 1.03625 + fromIntegral (fromEnum 'Ω' - ucp)/342.642 + | otherwise = 1.24551 + fromIntegral ucp / 52792.42 + + fromIntegral (ucp`mod`136)/9722.3 + where ucp = fromEnum c + unwieldiness (StringSymbol s) = unwieldiness s + + type Symbol = SymbolD Unicode_MathLatin_RomanGreek__BopomofoGaps type Expression' γ s² s¹ c = CAS' γ s² s¹ (Symbol c) type Expression c = Expression' Void (Infix c) (Encapsulation c) c @@ -138,10 +159,11 @@ ,ㄠ,ㄡ,ㄢ,ㄣ,ㄤ,ㄥ,ㄦ,ㄧ,ㄨ,ㄩ,ㄪ,ㄫ,ㄬ] = Gap . fromEnum <$> ['ㄅ'..'ㄬ'] -instance UnicodeSymbols c => Show (Expression c) where - showsPrec = showsPrecUnicodeSymbol -instance ∀ c . UnicodeSymbols c => Show (Pattern c) where - showsPrec p = showsPrecUnicodeSymbol p . purgeGaps +instance (UnicodeSymbols c, RenderableEncapsulations c) => Show (Expression c) where + showsPrec p = showsPrecUnicodeSymbol p . fixateAlgebraEncaps +instance ∀ c . (UnicodeSymbols c, RenderableEncapsulations c) + => Show (Pattern c) where + showsPrec p = showsPrecUnicodeSymbol p . purgeGaps . fixateAlgebraEncaps where purgeGaps (Symbol s) = Symbol s purgeGaps (Function f e) = Function f $ purgeGaps e purgeGaps (Operator o x y) = Operator o (purgeGaps x) (purgeGaps y) diff --git a/CAS/Dumb/Tree.hs b/CAS/Dumb/Tree.hs --- a/CAS/Dumb/Tree.hs +++ b/CAS/Dumb/Tree.hs @@ -11,6 +11,7 @@ {-# LANGUAGE DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables, UnicodeSyntax #-} @@ -223,3 +224,24 @@ go (Operator _ x y) = ('(':) . go x . (")`υ`("++) . go y . (")"++) go (OperatorChain x ys) = ("χ ["++) . go x . flip (foldr $ ((", "++).) . go . snd) (reverse ys) . (']':) + + + +type Unwieldiness = Double + +class Unwieldy e where + unwieldiness :: e -> Unwieldiness + +instance (Unwieldy s², Unwieldy s¹, Unwieldy s⁰) => Unwieldy (CAS s² s¹ s⁰) where + unwieldiness (Symbol s) = unwieldiness s + unwieldiness (Function f x) = unwieldiness f + unwieldiness x + unwieldiness (Operator o x y) + = unwieldiness o + unwieldiness x + bigFirstPreference*unwieldiness y + unwieldiness (OperatorChain x ys) + = unwieldiness x + sum [ q * (unwieldiness o + unwieldiness y) + | (q,(o,y)) <- zip [1, bigFirstPreference ..] $ reverse ys ] + +-- | How much it is preferred to start an operator-chain with the most complex +-- subexpression (e.g. with the highest-order monomial). +bigFirstPreference :: Unwieldiness +bigFirstPreference = 1 + 1e-6 diff --git a/dumb-cas.cabal b/dumb-cas.cabal --- a/dumb-cas.cabal +++ b/dumb-cas.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dumb-cas -version: 0.1.2.0 +version: 0.2.0.0 synopsis: A computer “algebra” system that knows nothing about algebra, at the core. description: This is a framework for untyped, symbolic computations like a CAS does, without any baked-in rules whatsoever but the ability to @@ -32,7 +32,7 @@ other-modules: CAS.Dumb.Util.These CAS.Dumb.Symbols.PatternGenerator other-extensions: DeriveFunctor - build-depends: base >=4.8 && <4.11, hashable >=1.2 && <1.3 + build-depends: base >=4.8 && <4.14, hashable >=1.2 && <1.3 , containers , unordered-containers >=0.2 && <0.3 , decimal-literals >= 0.1 && < 0.2 diff --git a/test/tasty/test.hs b/test/tasty/test.hs --- a/test/tasty/test.hs +++ b/test/tasty/test.hs @@ -7,11 +7,13 @@ -- Stability : experimental -- Portability : portable -- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} module Main where @@ -31,17 +33,17 @@ tests = testGroup "Tests" [ testGroup "Explicit transformations" [ testCase "𝑎 + 𝑏 * 𝑐 &~: ㄖ+ㄈ :=: ㄈ+ㄖ" $ - (𝑎 + 𝑏 * 𝑐 &~: ㄖ+ㄈ :=: ㄈ+ㄖ) @?= (𝑏 * 𝑐 + 𝑎 :: Expr) + (𝑎 + 𝑏 * 𝑐 &~: ㄖ+ㄈ :=: ㄈ+ㄖ) %@?= (𝑏 * 𝑐 + 𝑎 :: Expr) , testCase "(𝑎+𝑏) * 𝑐 &~: ㄖ+ㄈ :=: ㄈ+ㄖ" $ - ((𝑎+𝑏) * 𝑐 &~: ㄖ+ㄈ :=: ㄈ+ㄖ) @?= ((𝑏+𝑎) * 𝑐 :: Expr) + ((𝑎+𝑏) * 𝑐 &~: ㄖ+ㄈ :=: ㄈ+ㄖ) %@?= ((𝑏+𝑎) * 𝑐 :: Expr) , testCase "𝑎*𝑏 - 𝑐*𝑑 &~: ㄖ*ㄈ :=: ㄈ*ㄖ" $ - (𝑎*𝑏 - 𝑐*𝑑 &~: ㄖ*ㄈ :=: ㄈ*ㄖ) @?= (𝑏*𝑎 - 𝑑*𝑐 :: Expr) + (𝑎*𝑏 - 𝑐*𝑑 &~: ㄖ*ㄈ :=: ㄈ*ㄖ) %@?= (𝑏*𝑎 - 𝑑*𝑐 :: Expr) , testCase "𝑎*𝑏 - 𝑐*𝑑 &~? ㄖ*ㄈ :=: ㄈ*ㄖ" $ (𝑎*𝑏 - 𝑐*𝑑 &~? ㄖ*ㄈ :=: ㄈ*ㄖ) @?= [𝑏*𝑎 - 𝑐*𝑑, 𝑎*𝑏 - 𝑑*𝑐 :: Expr] , testCase "𝑎 + 𝑏 + 𝑐 + 𝑑 &~: ㄜ+ㄑ :=: ㄑ+ㄜ" $ - (𝑎 + 𝑏 + 𝑐 + 𝑑 &~: ㄜ+ㄑ :=: ㄑ+ㄜ) @?= (𝑏 + 𝑎 + 𝑑 + 𝑐 :: Expr) + (𝑎 + 𝑏 + 𝑐 + 𝑑 &~: ㄜ+ㄑ :=: ㄑ+ㄜ) %@?= (𝑏 + 𝑎 + 𝑑 + 𝑐 :: Expr) , testCase "𝑎 + 𝑏 + 𝑐 + 𝑑 &~: 𝑏+𝑐 :=: 𝑐+𝑏" $ - (𝑎 + 𝑏 + 𝑐 + 𝑑 &~: 𝑏+𝑐 :=: 𝑐+𝑏) @?= (𝑎 + 𝑐 + 𝑏 + 𝑑 :: Expr) + (𝑎 + 𝑏 + 𝑐 + 𝑑 &~: 𝑏+𝑐 :=: 𝑐+𝑏) %@?= (𝑎 + 𝑐 + 𝑏 + 𝑑 :: Expr) , testCase "𝑎 + 𝑏 + 𝑐 + 𝑑 &~? ㄜ+ㄑ :=: ㄑ+ㄜ" $ (𝑎 + 𝑏 + 𝑐 + 𝑑 &~? ㄜ+ㄑ :=: ㄑ+ㄜ) @?= [ 𝑏 + 𝑎 + 𝑐 + 𝑑 , 𝑎 + 𝑐 + 𝑏 + 𝑑 @@ -52,39 +54,66 @@ ((𝑎 + 𝑏 + 𝑐 &~? 𝑏+𝑐:=:𝑐+𝑏) >>= (&~? 𝑎+𝑐:=:ξ) ) @?= [ ξ+𝑏 :: Expr] , testCase "𝑎*𝑥 + 𝑏*𝑥 + 𝑐 &~: ㄏ*ㄘ+ㄐ*ㄘ :=: (ㄏ+ㄐ)*ㄘ" $ - (𝑎*𝑥 + 𝑏*𝑥 + 𝑐 &~: ㄏ*ㄘ+ㄐ*ㄘ :=: (ㄏ+ㄐ)*ㄘ) @?= ((𝑎+𝑏)*𝑥 + 𝑐 :: Expr) + (𝑎*𝑥 + 𝑏*𝑥 + 𝑐 &~: ㄏ*ㄘ+ㄐ*ㄘ :=: (ㄏ+ㄐ)*ㄘ) %@?= ((𝑎+𝑏)*𝑥 + 𝑐 :: Expr) , testCase "(𝑎+𝑏)*𝑥 + 𝑐 &~: (ㄏ+ㄐ)*ㄘ :=: ㄏ*ㄘ+ㄐ*ㄘ" $ - ((𝑎+𝑏)*𝑥 + 𝑐 &~: (ㄏ+ㄐ)*ㄘ :=: ㄏ*ㄘ+ㄐ*ㄘ) @?= (𝑎*𝑥 + 𝑏*𝑥 + 𝑐 :: Expr) + ((𝑎+𝑏)*𝑥 + 𝑐 &~: (ㄏ+ㄐ)*ㄘ :=: ㄏ*ㄘ+ㄐ*ㄘ) %@?= (𝑎*𝑥 + 𝑏*𝑥 + 𝑐 :: Expr) + , testCase "𝑎*𝑏*𝑐*𝑑 &~: 𝑎*𝑏 :=: 𝑏*𝑎" $ + (𝑎*𝑏*𝑐*𝑑 &~: 𝑎*𝑏 :=: 𝑏*𝑎) %@?= (𝑏*𝑎*𝑐*𝑑 :: Expr) + , testCase "𝑎*𝑏*𝑐*𝑑 &~: 𝑏*𝑐 :=: 𝑐*𝑏" $ + (𝑎*𝑏*𝑐*𝑑 &~: 𝑏*𝑐 :=: 𝑐*𝑏) %@?= (𝑎*𝑐*𝑏*𝑑 :: Expr) + , testCase "𝑎*𝑏*𝑐*𝑑 &~: 𝑐*𝑑 :=: 𝑑*𝑐" $ + (𝑎*𝑏*𝑐*𝑑 &~: 𝑐*𝑑 :=: 𝑑*𝑐) %@?= (𝑎*𝑏*𝑑*𝑐 :: Expr) + , testCase "𝑎 + 𝑏 - 𝑐 &~: 𝑏-𝑐 :=: (-𝑐)+𝑏" $ + (𝑎 + 𝑏 - 𝑐 &~: 𝑏-𝑐 :=: (-𝑐)+𝑏) %@?= (𝑎 + (-𝑐) + 𝑏 :: Expr) , testCase "Rename local symbols" $ - (map succ%$> 𝑎+𝑝) * 𝑥 @?= ((𝑏+𝑞) * 𝑥 :: Expr) + (map succ%$> 𝑎+𝑝) * 𝑥 %@?= ((𝑏+𝑞) * 𝑥 :: Expr) ] , testGroup "Show instance" [ testCase "𝑎+𝑏+𝑐" $ - show (𝑎+𝑏+𝑐 :: Expr) @?= "𝑎+𝑏+𝑐" + 𝑎+𝑏+𝑐 %@?= "𝑎+𝑏+𝑐" + , testCase "𝑎-𝑏+𝑐" $ + 𝑎-𝑏+𝑐 %@?= "𝑎-𝑏+𝑐" , testCase "𝑎+(𝑏+𝑐)" $ - show (𝑎+(𝑏+𝑐) :: Expr) @?= "𝑎+(𝑏+𝑐)" + 𝑎+(𝑏+𝑐) %@?= "𝑎+(𝑏+𝑐)" , testCase "𝑎+𝑏*𝑐" $ - show (𝑎+𝑏*𝑐 :: Expr) @?= "𝑎+𝑏*𝑐" + 𝑎+𝑏*𝑐 %@?= "𝑎+𝑏*𝑐" + , testCase "3*𝑧-1" $ + 3*𝑧-1 %@?= "3*𝑧-1" , testCase "(𝑎+𝑏)*𝑐" $ - show ((𝑎+𝑏)*𝑐 :: Expr) @?= "(𝑎+𝑏)*𝑐" + (𝑎+𝑏)*𝑐 %@?= "(𝑎+𝑏)*𝑐" , testCase "abs (𝑎+𝑏)" $ - show (abs (𝑎+𝑏) :: Expr) @?= "abs (𝑎+𝑏)" + abs (𝑎+𝑏) %@?= "abs (𝑎+𝑏)" , testCase "abs 3" $ - show (abs 3 :: Expr) @?= "abs 3" + abs 3 %@?= "abs 3" , testCase "𝑎 + -3" $ - show (𝑎+(-3) :: Expr) @?= "𝑎+( -3)" + 𝑎+(-3) %@?= "𝑎-3" , testCase "𝑎 / signum π" $ - show (𝑎/signum π :: Expr) @?= "𝑎/signum π" + 𝑎/signum π %@?= "𝑎/signum π" , testCase "logBase 2 32 ** atan pi" $ - show (logBase 2 32 ** atan pi :: Expr) @?= "2`logBase`32**atan pi" + logBase 2 32 ** atan pi %@?= "2`logBase`32**atan pi" , testCase "37.84" $ - show (37.84 :: Expr) @?= "37.84" + 37.84 %@?= "37.84" , testCase "5e-23" $ - show (5e-23 :: Expr) @?= "5e-23" + 5e-23 %@?= "5e-23" , testCase "-5.3e7" $ - show (-5.3e8 :: Expr) @?= " -5.3e8" + -5.3e8 %@?= " -5.3e8" ] ] +infix 1 %@?= +class ComparableExpressions e f | f -> e where + (%@?=) :: HasCallStack => e -> f -> Assertion + +instance ComparableExpressions Expr Expr where + e %@?= f + | e==f = return () + | otherwise = assertFailure + $ "Expected "++show f++" 『structure: "++showStructure f++"』," + ++ "\nbut got " ++show e++" 『structure: "++showStructure e++"』," +instance ComparableExpressions Expr String where + e %@?= f + | show e==f = return () + | otherwise = assertFailure $ "Expected \""++f++"\"" + ++ "\nbut got \"" ++show e++"\" 『structure: "++showStructure e++"』,"