/
episode_012.clj
121 lines (106 loc) · 3.42 KB
/
episode_012.clj
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
(ns episode-012
(:use lib.sfd.pred-utils))
;;-------------------
;; From episode 11
;;-------------------
(defn newton
"Creates a newton iterator. If start is not provided, zero is assumed."
([f f-prime] (newton f f-prime 0))
([f f-prime start]
(iterate (fn[x]
(- x
(/ (f x)
(f-prime x))))
start)))
(defn -sqr [a b] (let [d (- a b)] (* d d)))
(defn -norm [a b] (Math/sqrt (-sqr a b)))
(defn simple-converge
"Finds the first element of coll where the norm of two consecutive
elements is less than epsilon."
([epsilon coll] (simple-converge epsilon -norm coll))
([epsilon norm coll]
(ffirst
(drop-while
(fn [[a b] & more] (< epsilon (norm a b)))
(partition 2 1 coll)))))
(defn richardson
"Creates a closure that computes the derivative using a Richardson
interpolation"
[f delta]
(fn[x](/
(reduce +
(map * [1 -8 8 -1] (map #(f (+ x (* delta %))) [-2 -1 1 2])))
(* 12 delta))))
;;-------------------------
;; A convenience fn to solve equations
;;-------------------------
(defn solve-equation
"This solves a constraint fn with respect to free-var (a keyword).
Typically constraints end with a * suffix."
[constraint free-var a-map]
(let [target-fn (fn [x] (constraint (assoc a-map free-var x)))
target-prime (richardson target-fn 0.01)]
(simple-converge 0.01 (newton target-fn target-prime))))
;;-------------------------
;; Helper fns to determine which variable is free
;;-------------------------
(defn find-all-free-keys
"This is a utility fn to determine which keys are free in a map.
It is used to determine which variable to solve for."
[source-keys a-map]
(let [frozen-keys (map first (filter (every-pred?
second
(comp (set source-keys) first))
a-map))
remaining-keys (remove (set frozen-keys) source-keys)]
remaining-keys))
(defn find-free-key
"This is a utility fn to determine which keys are free in a map.
It is used to determine which variable to solve for."
[source-keys a-map]
(let [remaining-keys (find-all-free-keys source-keys a-map)]
(if (= (count remaining-keys) 1)
(first remaining-keys))))
;;---------------------------
;; Our equation solving macro
;;---------------------------
(defmacro defequation
"Creates an equation. This macro defines three functions.
* name*, which is the actual equation. It should be equal to zero.
* name-val, a closure to determine the actual value of the free fn.
* name, which returns a map. The result of sym-val is assoc'd with
the free vairable."
([name binding left right]
(let [name* (symbol (str name "*"))
name-val (symbol (str name "-val"))
keywords (vec (map keyword binding))
binding-map (zipmap binding keywords)
free-key (gensym "free-key_")]
`(do
(defn ~name* [~binding-map]
(- ~left ~right))
(defn ~name-val [~'constraints-map]
(let [~free-key (find-free-key ~keywords ~'constraints-map)]
(if ~free-key (solve-equation ~name* ~free-key ~'constraints-map))))
(defn ~name [~'constraints-map]
(let [~free-key (find-free-key ~keywords ~'constraints-map)]
(if ~free-key (assoc ~'constraints-map ~free-key (~name-val ~'constraints-map)))))
))))
;;---------------------
;; Temperature fns
;;---------------------
(defn c->f [c]
(-> c
(* 1.8)
(+ 32)
))
(defn f->c [f]
(-> f
(- 32)
(/ 1.8)
))
(defequation f<->c
[f c]
f
(-> c (* 1.8) (+ 32))
)