├── .gitignore ├── Main.hs ├── Derivative.hs ├── Expr.hs ├── Functions.hs ├── README.md └── Simplify.hs /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Expr 4 | import Derivative 5 | import Simplify 6 | import Functions 7 | 8 | expr :: Expr 9 | expr = (Apply ufsin X :/ (Apply ufcos X)) 10 | 11 | main :: IO () 12 | main = print (fullSimplify $ expr) 13 | -------------------------------------------------------------------------------- /Derivative.hs: -------------------------------------------------------------------------------- 1 | module Derivative where 2 | 3 | import Expr 4 | import Functions 5 | import Simplify 6 | 7 | deriv :: Expr -> Expr 8 | deriv (Const _) = Const 0 9 | 10 | deriv (X) = Const 1 11 | 12 | deriv (a :+ b) = fullSimplify $ (deriv a) :+ (deriv b) 13 | 14 | deriv (a :- b) = fullSimplify $ (deriv a) :- (deriv b) 15 | 16 | deriv (a :* b) = fullSimplify $ a :* (deriv b) :+ (deriv a) :* b 17 | 18 | deriv (a :/ b) = fullSimplify $ (b :* (deriv a) :- a :* (deriv b)) :/ (b :* b) 19 | 20 | deriv (a :^ b) = fullSimplify $ (a :^ b) :* (deriv (b :* (Apply uflog a))) 21 | 22 | deriv ((:%) a) = (Const (-1)) :* (fullSimplify $ deriv a) 23 | 24 | deriv (Apply u e) = fullSimplify $ (u' e) :* (deriv e) 25 | where (UnaryFunc f n) = u 26 | u' = 27 | case lookup u derivsList of 28 | (Just g) -> g 29 | Nothing -> error $ "I don't know how to differentiate " ++ n 30 | 31 | 32 | -- | Calculate the derivative of a function and simplify it. 33 | derivative :: Expr -> Expr 34 | derivative = fullSimplify . deriv 35 | 36 | -- | Calculate the nth derivative of a function. 37 | nderiv :: Int -> Expr -> Expr 38 | nderiv n = foldr1 (.) (replicate n derivative) 39 | -------------------------------------------------------------------------------- /Expr.hs: -------------------------------------------------------------------------------- 1 | module Expr where 2 | 3 | import Data.List 4 | 5 | infixl 3 :% 6 | infixl 4 :+, :- 7 | infixl 5 :*, :/ 8 | infixr 6 :^ 9 | 10 | data UnaryFunc = 11 | UnaryFunc (Double -> Double) String 12 | 13 | instance Eq UnaryFunc where 14 | (UnaryFunc f n1) == (UnaryFunc g n2) = (n1 == n2) 15 | 16 | instance Show UnaryFunc where 17 | show (UnaryFunc f n) = n 18 | 19 | -- | a is the number type here. 20 | data Expr 21 | = X 22 | | Const Double 23 | | (:%) Expr -- unary minus, I know it's ugly 24 | | Expr :+ Expr 25 | | Expr :- Expr 26 | | Expr :* Expr 27 | | Expr :/ Expr 28 | | Expr :^ Expr 29 | | Apply UnaryFunc Expr 30 | deriving Eq 31 | 32 | instance Show Expr where 33 | show X = "x" 34 | show (Const x) = show x 35 | show ((:%) x) = "(-" ++ show x ++ ")" 36 | show (a :+ b) = wrapShow $ show a ++ " + " ++ show b 37 | show (a :- b) = wrapShow $ show a ++ " - " ++ show b 38 | show (a :* b) = wrapShow $ show a ++ " * " ++ show b 39 | show (a :/ b) = wrapShow $ show a ++ " / " ++ show b 40 | show (a :^ b) = wrapShow $ show a ++ " ^ " ++ show b 41 | show (Apply uf e) = "(" ++ show uf ++ " " ++ show e ++ ")" 42 | 43 | isWrapped :: String -> Bool 44 | isWrapped [] = False 45 | isWrapped [_] = False 46 | isWrapped [x,y] = (x == '(') && (y == ')') 47 | isWrapped lst = 48 | noBrackets (init $ tail lst) && isWrapped [head lst,last lst] 49 | where noBrackets xs = 50 | 0 == (length $ filter (== '(') xs) -- assuming matched parens 51 | 52 | wrapShow :: String -> String 53 | wrapShow str 54 | | isWrapped str = str 55 | | otherwise = "(" ++ str ++ ")" 56 | -------------------------------------------------------------------------------- /Functions.hs: -------------------------------------------------------------------------------- 1 | module Functions where 2 | 3 | import Data.Maybe 4 | 5 | import Expr 6 | 7 | csc x = 1 / sin x 8 | sec x = 1 / cos x 9 | cot x = cos x / sin x 10 | 11 | ufsin = UnaryFunc sin "sin" 12 | ufcos = UnaryFunc cos "cos" 13 | uftan = UnaryFunc tan "tan" 14 | ufsec = UnaryFunc sec "sec" 15 | ufcsc = UnaryFunc csc "csc" 16 | ufcot = UnaryFunc cot "cot" 17 | uflog = UnaryFunc log "log" 18 | ufexp = UnaryFunc exp "exp" 19 | 20 | ufsin' = Apply ufcos 21 | ufcos' = (:%) . Apply ufsin 22 | uftan' = (:^ (Const 2)) . Apply ufsec 23 | ufcot' = (:* (Const (-1))) . (:^ (Const 2)) . Apply ufcsc 24 | ufsec' e = ((Apply ufsec e) :* (Apply uftan e)) 25 | ufcsc' e = ((Const (-1)) :* ((Apply ufsec e) :* (Apply uftan e))) 26 | ufexp' = Apply ufexp 27 | ufrecip' = (Const 1 :/) 28 | 29 | derivsList :: [(UnaryFunc, Expr -> Expr)] 30 | derivsList = 31 | [(ufsin,ufsin') 32 | ,(ufcos,ufcos') 33 | ,(uftan,uftan') 34 | ,(ufcot,ufcot') 35 | ,(ufsec,ufsec') 36 | ,(ufcsc,ufcsc') 37 | ,(uflog,ufrecip') 38 | ,(ufexp,ufexp')] 39 | 40 | inv :: UnaryFunc -> UnaryFunc 41 | inv func 42 | | isJust inverse = func' 43 | where inverse = lookup func lst'' 44 | (Just func') = inverse 45 | 46 | invsList :: [(UnaryFunc, Expr -> Expr)] 47 | invsList = map (\(x,y) -> (x,Apply y)) lst'' 48 | lst = [(ufsin,ufcsc),(ufcos,ufsec),(uftan,ufcot)] 49 | lst' = map (uncurry $ flip (,)) lst 50 | lst'' = lst ++ lst' 51 | 52 | prodList :: [((UnaryFunc, UnaryFunc), Expr -> Expr)] 53 | prodList = 54 | map (\(x,y,z) -> ((x,y),z)) $ prods ++ flipProds ++ consts 55 | where prods = 56 | [(ufsin,ufsec,Apply uftan),(ufcos,ufcsc,Apply ufcot)] 57 | flipProds = 58 | map (\(x,y,z) -> (y,x,z)) prods 59 | consts = 60 | map (\(x,y) -> (x,y,const (Const 1))) lst'' 61 | 62 | quotList :: [((UnaryFunc, UnaryFunc), Expr -> Expr)] 63 | quotList = [((ufsin, ufcos), Apply uftan)] 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # What's this? 2 | 3 | A toy Haskell library for symbolic algebra, especially derivatives. I wrote it to learn to do a bunch of things, mainly. 4 | 5 | I got a lot of the ideas and some of the code (I almost copied the `simplify` function from him) from [5outh's tutorial](http://kovach.me/posts/2013-05-01-symbolic-calculus.html), although I rewrote the code for derivatives on my own without looking at his. 6 | 7 | I've implemented: 8 | 9 | * Polynomials 10 | * Trigonometric functions 11 | * `exp` and `log` 12 | * Four fundamental operations and exponentiation 13 | * Symbolic derivatives 14 | * Simplification of expressions, using: 15 | * A few trigonometric identities (stuff like `sin x sec x = tan x`) 16 | * Basic algebraic identities (`a^0 = 1` etc.) 17 | 18 | To use it, clone the repo into a folder and run `Main.hs` in `ghci`: 19 | 20 | $ git clone https://github.com/mrkgnao/pebble.git 21 | $ cd pebble 22 | $ ghci Main.hs 23 | 24 | # Syntax (for now) 25 | 26 | * `:+`, `:-`, `:*`, `:/` and `:^` are what you think they are 27 | * The same goes for `X` 28 | * Unary functions are given their Prelude names with an `uf` prefix, and you apply them to an expression with `(Apply uffunc expr)`, where `uffunc` is something like `ufsin`. 29 | * Operators have precedence, so you don't have to wrap everything in parens 30 | 31 | ## Syntax examples 32 | 33 | * `X :^ X` is `x^x` 34 | * `Apply ufsin (Apply uflog X)` is `sin (log x)` 35 | * `(Apply ufsin (2 :+ X)) :* (Apply ufcot X)` is `sin (2+x) cot x` 36 | 37 | ## Differentiation examples 38 | 39 | The `derivative` function computes the derivative of an expression, simplifies it as best as it can and pretty-prints it. 40 | 41 | The bane of every eleventh-grader: 42 | 43 | λ> derivative (X :^ X) 44 | ((x ^ x) * (1.0 + (log x))) 45 | 46 | A composition of two functions: 47 | 48 | λ> derivative ((Apply ufsin (Apply ufcos X))) 49 | ((cos (cos x)) * (-(sin x))) 50 | 51 | This pushes the, uh, Synergized Algebraic Simplification Engine™ to its limit: 52 | 53 | λ> derivative (Apply uflog (Apply ufsin X)) 54 | (cot x) 55 | 56 | Uh, why the hipster name? 57 | ------------------------- 58 | 59 | What do you think ['calculus' originally meant](http://www.etymonline.com/index.php?term=calculus)? 60 | -------------------------------------------------------------------------------- /Simplify.hs: -------------------------------------------------------------------------------- 1 | module Simplify where 2 | 3 | import Data.List 4 | import Data.Maybe 5 | 6 | import Expr 7 | import qualified Functions as F 8 | 9 | -- | Cleans up nonsense like X :^ X :* (X :* ((Const 1.0 :/ X) :* Const 1.0) :+ 10 | -- | Const 1.0 :* Apply "log" X) into (hopefully) nicer expressions like 11 | -- | X :^ X ((Const 1.0) :+ Apply "log" X), 12 | 13 | simplify :: Expr -> Expr 14 | simplify (Const a :+ Const b) = Const (a + b) 15 | simplify (a :+ Const 0) = simplify a 16 | simplify (Const 0 :+ a) = simplify a 17 | 18 | simplify (Const a :* Const b) = Const (a * b) 19 | simplify (a :* Const 1) = simplify a 20 | simplify (Const 1 :* a) = simplify a 21 | simplify (a :* Const 0) = Const 0 22 | simplify (Const 0 :* a) = Const 0 23 | 24 | simplify (Const a :^ Const b) = Const (a ** b) 25 | simplify (a :^ Const 1) = simplify a 26 | simplify (a :^ Const 0) = Const 1 27 | simplify ((c :^ Const b) :^ Const a) = 28 | c :^ (Const (a * b)) 29 | 30 | -- | Multiplication 31 | 32 | -- m * (n * f) = (m * n) * f 33 | simplify (Const a :* (Const b :* expr)) = 34 | (Const $ a * b) :* (simplify expr) 35 | 36 | -- mfn = mnf 37 | simplify (Const a :* expr :* Const b) = 38 | (Const $ a * b) :* (simplify expr) 39 | 40 | -- fmn = mnf 41 | simplify (expr :* Const a :* Const b) = 42 | (Const $ a * b) :* (simplify expr) 43 | 44 | -- m(f+g) = mf+mg 45 | simplify (Const a :* (b :+ c)) = 46 | (Const a :* (simplify b)) :+ (Const a :* (simplify c)) 47 | 48 | simplify (Const 0 :/ a) = Const 0 49 | simplify (Const a :/ Const 0) = 50 | error "Division by zero!" 51 | simplify (Const a :/ Const b) = Const (a / b) 52 | simplify (a :/ Const 1) = simplify a 53 | simplify (a :/ b) | a == b = Const 1 54 | simplify (a :* (Const b :/ c)) = Const b :* simplify (a :/ c) 55 | 56 | -- | Trigonometric inverses 57 | simplify (k@(Const _) :/ (Apply b e)) 58 | | isJust lk = k :* val (simplify e) 59 | where lk = lookup b F.invsList 60 | (Just val) = lk 61 | 62 | simplify ((Apply f e1) :* (Apply g e2)) 63 | | e1 == e2 && isJust lk = 64 | fg $ simplify e1 65 | where lk = lookup (f,g) F.prodList 66 | (Just fg) = lk 67 | 68 | simplify ((Apply f e1) :/ (Apply g e2)) 69 | | e1 == e2 && isJust lk = 70 | fg $ simplify e1 71 | where lk = lookup (f,g) F.quotList 72 | (Just fg) = lk 73 | 74 | simplify ((Apply f x) :* (Apply g y)) 75 | | f == g && x == y = ((Apply f x) :^ (Const 2)) 76 | 77 | simplify (a :/ b) = (simplify a) :/ (simplify b) 78 | simplify (a :^ b) = (simplify a) :^ (simplify b) 79 | simplify (a :* b) = (simplify a) :* (simplify b) 80 | simplify (a :+ b) = (simplify a) :+ (simplify b) 81 | simplify x = x 82 | 83 | fullSimplify expr = 84 | fullSimplify' expr 85 | (Const 0) -- placeholder 86 | where fullSimplify' cur last 87 | | cur == last = cur 88 | | otherwise = 89 | let cur' = simplify cur 90 | in fullSimplify' cur' cur 91 | --------------------------------------------------------------------------------