Skip to content

Instantly share code, notes, and snippets.

@nikhedonia
Created April 18, 2020 14:31
Show Gist options
  • Save nikhedonia/0e67d14c678c14966cc625face301e8a to your computer and use it in GitHub Desktop.
Save nikhedonia/0e67d14c678c14966cc625face301e8a to your computer and use it in GitHub Desktop.
// Type definitions
type BinaryOP =
| Add
| Sub
| Div
| Mult
type Expr< ^T> =
| Binary of BinaryOP * Expr< ^T> * Expr< ^T>
| Value of ^T
| Var of string
// binary operations to combine expressions
static member inline (+) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Add, lhs, rhs)
static member inline (-) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Sub, lhs, rhs)
static member inline (*) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Mult, lhs, rhs)
static member inline (/) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Div, lhs, rhs)
// convinience operations describing operations between base type and expressions
static member inline (+) (lhs: Expr< ^T>, rhs: ^T) = Binary (Add, lhs, Value rhs)
static member inline (-) (lhs: Expr< ^T>, rhs: ^T) = Binary (Sub, lhs, Value rhs)
static member inline (*) (lhs: Expr< ^T>, rhs: ^T) = Binary (Mult, lhs, Value rhs)
static member inline (/) (lhs: Expr< ^T>, rhs: ^T) = Binary (Div, lhs, Value rhs)
static member inline (+) (lhs: ^T, rhs: Expr< ^T>) = Binary (Add, Value lhs, rhs)
static member inline (-) (lhs: ^T, rhs: Expr< ^T>) = Binary (Sub, Value lhs, rhs)
static member inline (*) (lhs: ^T, rhs: Expr< ^T>) = Binary (Mult, Value lhs, rhs)
static member inline (/) (lhs: ^T, rhs: Expr< ^T>) = Binary (Div, Value lhs, rhs)
// implementation
let rec toString (ast: ^T Expr) =
match ast with // pattern match on tree elements
| Value x -> (string x)
| Var x -> x
| Binary (Add, x, y) -> "(" + (toString x) + "+" + (toString y) + ")"
| Binary (Sub, x, y) -> "(" + (toString x) + "-" + (toString y) + ")"
| Binary (Mult, x, y) -> "(" + (toString x) + "*" + (toString y) + ")"
| Binary (Div, x, y) -> "(" + (toString x) + "/" + (toString y) + ")"
let rec eval (ast: ^T Expr) (m: Map<string, ^T Expr>) =
// the expression interpreter
// match on patterns and evaluate
match ast with
| Binary (Add, Value x, Value y) -> Value (x + y)
| Binary (Sub, Value x, Value y) -> Value (x - y)
| Binary (Mult, Value x, Value y) -> Value (x * y)
| Binary (Div, Value x, Value y) -> Value (x / y)
| Binary (Add, x, y) -> (eval x m) + (eval y m)
| Binary (Sub, x, y) -> (eval x m) - (eval y m)
| Binary (Mult, x, y) -> (eval x m) * (eval y m)
| Binary (Div, x, y) -> (eval x m) / (eval y m)
| Value x -> Value x
| Var x ->
match m |> Map.tryFind x with
| Some x -> x
| None -> Var x
// rules to simplify
let rec simplify (ast: ^T Expr) =
match ast with
| Binary (Mult, Value 0, _) -> Value 0 // 0 * x = 0
| Binary (Mult, _, Value 0) -> Value 0 // x * 0 = 0
| Binary (Mult, Value 1, expr) -> simplify expr // simplify and recurse
| Binary (Mult, expr, Value 1) -> simplify expr
| Binary (Add, Value 0, expr) -> simplify expr
| Binary (OP, Var x, Value y) -> Binary(OP, Value y, Var x)
| Binary (Add, Var x, Var y) when x = y -> // X + X = 2X
Binary (Mult, Value 2, Var x)
| Binary (OP, Value x, rhs) -> // 1 * (2 * x) -> (1 * 2) * x
match rhs with
| Binary (OP, Value y, rhs2) ->
let lhs = (Binary (OP, Value x, Value y))
Binary (OP, lhs, simplify rhs2)
| _ -> Binary (OP, Value x, simplify rhs)
| Binary (OP, lhs, rhs) -> // (1 * x) * (2 * x) -> (1 * 2) * (x * x)
let m1 =
match lhs with
| Binary (OP, Value v, Var x) ->
Some (Value v, Var x)
| _ -> None
let m2 =
match rhs with
| Binary (OP, Value v, Var x) ->
Some (Value v, Var x)
| _ -> None
match m1, m2 with
| Some (a, b), Some (c, d) ->
Binary (
OP,
Binary (OP, a, c),
Binary (OP, b, d))
| _ -> Binary (OP, simplify lhs, simplify rhs)
| x -> x
let rec evalAll (ast: ^T Expr) (m: Map<string, ^T Expr>) =
let next = eval ast m
if next <> ast
then evalAll next m
else next
let rec simplifyAll (ast: ^T Expr) =
let next = eval ast Map.empty |> simplify
if next <> ast
then simplifyAll next
else next
// compute derivative
let rec deriv (ast: ^T Expr) (var: string) =
match ast with
| Value _ -> Value 0
| Var x when x = var -> Value 1
| Var x when x <> var -> Value 0
| Binary (Mult, l, r) -> (deriv l var) * r + l * (deriv r var)
| Binary (OP, l, r) -> Binary (OP, (deriv l var), (deriv r var))
// helper function for printing
let printSimplified expr =
let s1 = toString expr
let s2 = toString (simplifyAll expr)
if s1 = s2
then System.Console.WriteLine (s1)
else System.Console.WriteLine (s1 + " = " + s2)
let inline f c x = c * x * x
System.Console.WriteLine (f 2 2)
let X = Var "x"
let expr = f 2 X
let sub = Value 2 * Var("X")
let params1 = Map.ofList ["x", sub]
let partial = evalAll expr params1
printSimplified expr
System.Console.WriteLine("Computing derivative:")
let derived = (deriv expr "x")
printSimplified derived
System.Console.WriteLine("substituting x -> " + (toString sub) + " in: ")
printSimplified partial
let params2 = Map.ofList ["X", Value 2]
let result = evalAll partial params2
System.Console.WriteLine("substituting x -> 2 in partial")
printSimplified result
@nikhedonia
Copy link
Author

https://fable.io/repl/#?code=PTAEBUE8AcFNQCawGYEsB2qAuqD26BnAWACgsZ4AhDAQwCdIB5ABVAF5TRQAfUAQQQJOPUAGUArgCNhvACKoAbjNABZcQBsspUuTigAogA9odADygAeuAB87ZdXT1IoXMlAOnLUACoDxs5Y2Pn4m5lbWygBqNOri8K6BUfQubgRYdBgA5sLCIKCStAwucHQ0OPgEoFi4oADGuAC2BejwsP6wBAR4hMJpZai1oA2wTbB0oBjqGPAAFADUAJSgM+oAFgQAXCEB4QA0oHTrW0ahgdZLbO6FzjMCCPtrBPuHBAu9WP2Dw6Pjk9PLAFolisjtswjZnqCTjsbBcro4ijMJJIHutIa93p8hiNJGMJugpi1lt5gY9jv5wdZ0eTTuE4R5EWpNKingd1m8SFw+jgvji8X8iTNgKSoRSztSwWd6ddlvIFCz0RzcmB6ugFBhULB0LV4iV+hVEB1ahlmplimN9YR8rAsAB3WBa-I0AjwXTwGjoBCgNomDpdCqYnnYn74wmzRbLMmSvZszaBaUIm53BWgaKxeAvDlcj5B76434E-4zIGR0W0iGxrZWBNOZbIlNpuKxrOgbkDYP50NFkmluPQykS6vseG1mZMrANmJNzOB9t5-mFwXC3s0mFUyvx4cMm5yyfp5vaTmtnNzvkFsPLCMguNWCX9qVbmW3QT7RvwR6K2e8kMC2Yl69VuAd5inSj6JnWUivlO75ogeR5tt+na-sSIo3kBG73qBlzbss45QfuH5wdmWLzueRbLgBgTAeW5xgaOu6ptBoCETOJCHnkqANNA6gjFqJ74IePFYAcsCDNUojpFkyzOlggHbBcwgNGUtSrKAMmgLa2CqXk0BlFgYzoEMymqfgVR0A63o8cM6BYMQR68G+oCGKAAK2DMaQZOgZqGC2DnJM5rlOfYT7Jk5+yQEsgUAEQzFFoBzMs4mSV5TlLAlUVzHFCUzElnlmhF8WgFFCxRcF4FIpBYWgAV0WxYVOW4BJeWpYVUUAlliWNcl+VpUVJVlaOeFVTVtgxR1DVNVJPmtd4425VJBXpf19kjoiDGGOFkWjXV2XzSl03pcAc1dc1i19aVbGXUJImDLACgxNJaRydCwINFsKg0NApgeVk+xWNstGXMqVSrK07SdN0+L6XQvrQ8DSlYCpLiGbpWDQ1aHpendU5lLAinGWpaQaVph5cFwvA4c+9yMfuG0002I307MzkJRFwjk6tNz1kzVWOYzjkzAF1UthzlNDY5dN81tPOC8EbNHqLT4MRL+EM9LAvOWA8vsyIlOhXTjMzNj6hOUMvVG-dJvOA0Sw6xTT7cwb0sWw9zk2y5yzG9VZugHbnO4RoE7Dc7Xtu0svgu1bPt+5T62bS5bmhz7YCR977uk2Tfm0wnPPOX70TjAFtg61wCNIw0PC2B90AAHTpJAABiGBes5mlYKsJciKIjTwEXpud7wABy+DwIFBdBZdpB5HQGgdFUNRdFxUzIJApDXeZgyL9xqAr49smBPJdhHmXqnqW3HcrWLgeq-AAAM+wAPrq0xt+gHkr++M5ly3wNjLX6AD8b6gFvs-fcr88jOV8K-b+v8bjiyYgARn2D6Og0st7L2cCgt+YB0E72cJjG64g6AulgQHZk3p-BAIQWgzi29d4oNIVTIB98KEmBoUvPBrC6CMJYFBQuQDGbbhmLwnmkA+GpUYaFcektkgFVtKDQyX9vaBTyAADUKuoy4AAmVROsr7kMclo8RPkeHMCAXTTMOc8gIOCDMLRwRpqBRmDY3wWjw4TzJkZRGqkXjE3bgPf2wizGiPRG4hOncuDXUeMOGYlMREq1EQsEWnjAkiMIrg3eLw3EBIfjnOJwSEkZOcKxRW5U0mwUsSolOLiWoR3sZ-Z2NSwkR0gRIhWzEbRDBsUDdppcCbRPPgE-JQD5SMULtLCJYge7LEcqM6RySOa5MCsPFoGdImdIaPYjgvSvFI18YMnZ9sykFKYnM-yEydlcG7sMGZpzjELJEEs2wKy8aXU8SfLp+xNl+Ivp43g1zZg0H2JIBY+wAXLFqPsBAFyUmBMmbwyZwy1L7FqKCxFT4REokQEkv2TzUnBKKcxWChKSkiD7oYQ8a9Okb29JbPg6gTYzBks9fwr13qfW+t1P64AAYKSPNdFohhhKXC9upBowgd6gEFcJUwtgZLCHbo6Y29KTbSqGMIWA6gXRSraMJQS1LRKtloRglVe8WVsKPus4SaqRWW0JsJauNcRjQHIJXI1HCV4SrcGq2V9qFUKPdXQyAprpUaq1fANV7EVSNGgOIfShoMj3RwAoV569DVIETWag+L1lj3ToFsH6Xk+V9O8fan5SR9x4scj-Fa0iNIBqUXmnOjkEFJELvWx0zlfVNrHi-RhQ11DPGdhmxQzFQB5vceMBKJsI4joUAccd9BfL4oeEOvJGLgkzDnWOid+wt1jFHeMCdSpLp5FBuoEooBkDiG1OUQyyBcDjBMBgHAXkqXCWfTZUQxqd6aixv4S1HThIEG6fPSaKUGH8s6QQLZYHurLCKaalBLZJUgeHDB-1jpRCQDSCMGuABhCouAeI1wAOoZH0gAGSLCB22R5NXauw7hhoBGiMkfI9gWA1HBRofSsODqMGT3vq7ESNwgwlGDE-g4w8TH9IscI4QYjsAyMUa40WNw9jslXU6ZosZRVDAXWulgy4GnQC6O08BqQw5DHBALrFVRxVhO6VKA0NDlxHWuGo0TAA2lFAz+wCBSAALpOfoDgB6tqYhIYA85mgrnW2T0up+rA36PV-q4aQWTeGFMECUypzj3HYCxUI1xONUk539BTRsRzJBrpztgF6S4yxt1YL8zV5LqW6Hpfq0IS6WX5NseUxxqj0xYqBckGkbAZX9o52OuBs043epxQwFsdrnkUs-rQA10AznwvqH1R++gcWYPDg88gLzwlfMOaAVokLtWDWBc0MOZVDKdthdQA9WLrmtEyZw3J1jin2OqcK2NqQk2sDTe8jnexGA3t0D22tl9nXl7pfMo9rAQA&html=Q&css=Q

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment