dumb-cas 0.1.2.0 → 0.2.0.0
raw patch · 6 files changed
+182/−44 lines, 6 filesdep ~basedep ~hashablePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, hashable
API changes (from Hackage documentation)
- CAS.Dumb.Symbols.ASCII: instance (CAS.Dumb.Symbols.ASCIISymbols c, GHC.Base.Monoid c) => GHC.Show.Show (CAS.Dumb.Tree.CAS' CAS.Dumb.Tree.GapId (CAS.Dumb.Symbols.Infix c) (CAS.Dumb.Symbols.Encapsulation c) (CAS.Dumb.Symbols.ASCII.Symbol c))
- CAS.Dumb.Symbols.ASCII: instance CAS.Dumb.Symbols.ASCIISymbols c => GHC.Show.Show (CAS.Dumb.Tree.CAS (CAS.Dumb.Symbols.Infix c) (CAS.Dumb.Symbols.Encapsulation c) (CAS.Dumb.Symbols.ASCII.Symbol c))
- CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps: instance CAS.Dumb.Symbols.UnicodeSymbols c => GHC.Show.Show (CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps.Expression c)
- CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps: instance CAS.Dumb.Symbols.UnicodeSymbols c => GHC.Show.Show (CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps.Pattern c)
+ CAS.Dumb: SpecialEncapsulation :: (SpecialEncapsulation s) -> Encapsulation s
+ CAS.Dumb.Symbols: Negation :: AlgebraicInvEncapsulation
+ CAS.Dumb.Symbols: Reciprocal :: AlgebraicInvEncapsulation
+ CAS.Dumb.Symbols: SpecialEncapsulation :: (SpecialEncapsulation s) -> Encapsulation s
+ CAS.Dumb.Symbols: class Eq (SpecialEncapsulation c) => RenderableEncapsulations c
+ CAS.Dumb.Symbols: data AlgebraicInvEncapsulation
+ CAS.Dumb.Symbols: fixateAlgebraEncaps :: (RenderableEncapsulations c, SymbolClass σ, SCConstraint σ c) => CAS' γ (Infix c) (Encapsulation c) (SymbolD σ c) -> CAS' γ (Infix c) (Encapsulation c) (SymbolD σ c)
+ CAS.Dumb.Symbols: instance CAS.Dumb.Symbols.RenderableEncapsulations GHC.Base.String
+ CAS.Dumb.Symbols: instance GHC.Classes.Eq CAS.Dumb.Symbols.AlgebraicInvEncapsulation
+ CAS.Dumb.Symbols: instance GHC.Show.Show CAS.Dumb.Symbols.AlgebraicInvEncapsulation
+ CAS.Dumb.Symbols.ASCII: instance (CAS.Dumb.Symbols.ASCIISymbols c, CAS.Dumb.Symbols.RenderableEncapsulations c) => GHC.Show.Show (CAS.Dumb.Tree.CAS (CAS.Dumb.Symbols.Infix c) (CAS.Dumb.Symbols.Encapsulation c) (CAS.Dumb.Symbols.ASCII.Symbol c))
+ CAS.Dumb.Symbols.ASCII: instance (CAS.Dumb.Symbols.ASCIISymbols c, CAS.Dumb.Symbols.RenderableEncapsulations c, GHC.Base.Monoid c) => GHC.Show.Show (CAS.Dumb.Tree.CAS' CAS.Dumb.Tree.GapId (CAS.Dumb.Symbols.Infix c) (CAS.Dumb.Symbols.Encapsulation c) (CAS.Dumb.Symbols.ASCII.Symbol c))
+ CAS.Dumb.Symbols.ASCII: instance CAS.Dumb.Tree.Unwieldy c => CAS.Dumb.Tree.Unwieldy (CAS.Dumb.Symbols.ASCII.Symbol c)
+ CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps: instance (CAS.Dumb.Symbols.UnicodeSymbols c, CAS.Dumb.Symbols.RenderableEncapsulations c) => GHC.Show.Show (CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps.Expression c)
+ CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps: instance (CAS.Dumb.Symbols.UnicodeSymbols c, CAS.Dumb.Symbols.RenderableEncapsulations c) => GHC.Show.Show (CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps.Pattern c)
+ CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps: instance CAS.Dumb.Tree.Unwieldy c => CAS.Dumb.Tree.Unwieldy (CAS.Dumb.Symbols.Unicode.MathLatin_RomanGreek__BopomofoGaps.Symbol c)
+ CAS.Dumb.Tree: bigFirstPreference :: Unwieldiness
+ CAS.Dumb.Tree: class Unwieldy e
+ CAS.Dumb.Tree: instance (CAS.Dumb.Tree.Unwieldy s², CAS.Dumb.Tree.Unwieldy s¹, CAS.Dumb.Tree.Unwieldy s⁰) => CAS.Dumb.Tree.Unwieldy (CAS.Dumb.Tree.CAS s² s¹ s⁰)
+ CAS.Dumb.Tree: type Unwieldiness = Double
+ CAS.Dumb.Tree: unwieldiness :: Unwieldy e => e -> Unwieldiness
- CAS.Dumb.Symbols: class SymbolClass σ where type SCConstraint σ :: * -> Constraint where {
+ CAS.Dumb.Symbols: class SymbolClass σ where {
- CAS.Dumb.Symbols: renderSymbolExpression :: forall σ c r. (SymbolClass σ, SCConstraint σ c) => ContextFixity -> RenderingCombinator σ c r -> AlgebraExpr σ c -> r
+ CAS.Dumb.Symbols: renderSymbolExpression :: forall σ c r. (SymbolClass σ, SCConstraint σ c, HasCallStack) => ContextFixity -> RenderingCombinator σ c r -> AlgebraExpr σ c -> r
Files
- CAS/Dumb/Symbols.hs +61/−9
- CAS/Dumb/Symbols/ASCII.hs +17/−4
- CAS/Dumb/Symbols/Unicode/MathLatin_RomanGreek__BopomofoGaps.hs +26/−4
- CAS/Dumb/Tree.hs +22/−0
- dumb-cas.cabal +2/−2
- test/tasty/test.hs +54/−25
CAS/Dumb/Symbols.hs view
@@ -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)
CAS/Dumb/Symbols/ASCII.hs view
@@ -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)
CAS/Dumb/Symbols/Unicode/MathLatin_RomanGreek__BopomofoGaps.hs view
@@ -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)
CAS/Dumb/Tree.hs view
@@ -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
dumb-cas.cabal view
@@ -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
test/tasty/test.hs view
@@ -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++"』,"