├── .DS_Store ├── .gitignore ├── LICENSE ├── README.md ├── Structure and Interpretation of Computer Programs - Harold Abelson.epub ├── doc ├── Structure and Interpretation of Computer Programs - Harold Abelson.epub └── intro.md ├── project.clj ├── src └── sicp │ ├── chapter-1.clj │ ├── chapter-2.clj │ ├── chapter-3.clj │ ├── core.clj │ ├── temp-2-82.clj │ └── tmp.clj └── test └── sicp ├── .DS_Store └── core_test.clj /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/frankiesardo/sicp-in-clojure/dc341617c2ab8eb34ac316175a56141a0c605421/.DS_Store -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | *.jar 5 | *.class 6 | /.lein-* 7 | /.nrepl-port 8 | .DS_Store 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of Washington and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sicp in clojure -------------------------------------------------------------------------------- /Structure and Interpretation of Computer Programs - Harold Abelson.epub: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/frankiesardo/sicp-in-clojure/dc341617c2ab8eb34ac316175a56141a0c605421/Structure and Interpretation of Computer Programs - Harold Abelson.epub -------------------------------------------------------------------------------- /doc/Structure and Interpretation of Computer Programs - Harold Abelson.epub: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/frankiesardo/sicp-in-clojure/dc341617c2ab8eb34ac316175a56141a0c605421/doc/Structure and Interpretation of Computer Programs - Harold Abelson.epub -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to sicp 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) 4 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject sicp "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.5.1"]]) 7 | -------------------------------------------------------------------------------- /src/sicp/chapter-1.clj: -------------------------------------------------------------------------------- 1 | (ns sicp.ch1) 2 | 3 | ;; Exercise 1.3. 4 | ;; Define a procedure that takes three numbers as arguments and returns the sum of the of the two larger numbers 5 | 6 | (defn square [x] (* x x)) 7 | 8 | (defn sum-squares [x y] 9 | (+ (square x) (square y))) 10 | 11 | (defn sum-largest-squares [x y z] 12 | (cond 13 | (and (< x y) (< x z)) (sum-squares y z) 14 | (and (< y x) (< y z)) (sum-squares x z) 15 | (and (< z x) (< z y)) (sum-squares x y))) 16 | 17 | ;; Exercise 1.5 18 | 19 | (defn p [] p) 20 | 21 | (defn testForZero [x y] 22 | (if (= x 0) 0 y)) 23 | 24 | (testForZero 0 p) ;; Clojure uses normal-order evaluation, thus parameters are lazily evaluated. Schema doesn't. 25 | 26 | ;; Exercise 1.6 27 | 28 | (def tolerance 0.001) 29 | 30 | (defn average [x y] 31 | (/ (+ x y) 2)) 32 | 33 | (defn good-enough? [guess x] 34 | (< (Math/abs (- (square guess) x)) tolerance)) 35 | 36 | (defn improve [guess x] 37 | (average guess (/ x guess))) 38 | 39 | (defn sqrt-iter [guess x] 40 | (if (good-enough? guess x) 41 | guess 42 | (sqrt-iter (improve guess x) x))) 43 | 44 | (defn sqrt [x] 45 | (sqrt-iter 1.0 x)) 46 | 47 | (sqrt 9) 48 | 49 | ;; -- 50 | 51 | (defn new-if [predicate then-clause else-clause] 52 | (cond 53 | predicate then-clause 54 | :else else-clause)) 55 | 56 | (defn new-sqrt-iter [guess x] 57 | (new-if (good-enough? guess x) 58 | guess 59 | (sqrt-iter (improve guess x) x))) 60 | 61 | (defn new-sqrt [x] 62 | (new-sqrt-iter 1.0 x)) 63 | 64 | (new-sqrt 16) ;; Clojure uses normal-order evaluation, thus parameters are lazily evaluated. Schema doesn't. 65 | 66 | ;; Exercise 1.7 67 | 68 | (defn new-good-enough? [guess x] 69 | (< (/ (abs (- (square guess) x)) guess) (* guess tolerance))) 70 | 71 | (defn new-good-enough2? [guess x] 72 | (< (abs ( / (- (improve guess x) guess) guess)) tolerance)) 73 | 74 | (new-good-enough? 0.002236 0.000005) 75 | 76 | (new-good-enough2? 3.9 16) 77 | 78 | ;; Exercise 1.8 79 | 80 | (defn cube [x] 81 | (* x x x)) 82 | 83 | (defn improve-cube [guess x] 84 | (/ (+ (/ x (square guess)) (* 2 guess)) 3)) 85 | 86 | (defn good-enough-cube? [guess x] 87 | (< (/ (abs (- (cube guess) x)) guess) (* guess tolerance))) 88 | 89 | (defn cube-root-iter [guess x] 90 | (if (good-enough-cube? guess x) 91 | guess 92 | (cube-root-iter (improve-cube guess x) x))) 93 | 94 | (defn cube-root [x] 95 | (cube-root-iter 1.0 x)) 96 | 97 | (cube-root 8) 98 | 99 | ;; Exercise 1.9 100 | 101 | (defn plus-rec [a b] 102 | (if ( = 0 a) 103 | b 104 | (inc (plus-rec (dec a) b) ))) 105 | 106 | (defn plus-iter [a b] 107 | (if (= a 0) 108 | b 109 | (plus-iter (dec a) (inc b)))) 110 | 111 | ;; Exercise 1.10 112 | 113 | (defn A [x y] 114 | (cond 115 | (= y 0) 0 116 | (= x 0) (* 2 y) 117 | (= y 1) 2 118 | :else (A (dec x) (A x (dec y))))) 119 | 120 | (defn f [n] (A 0 n)) ;; 2 * n 121 | 122 | (defn g [n] (A 1 n)) ;; 2 ^ n 123 | 124 | (defn h [n] (A 2 n)) ;; 2 ^ h(n - 1) 125 | 126 | 127 | ;; Exercise 1.11 128 | 129 | (defn fun-rec [n] 130 | (if (< n 3) n 131 | (+ (fun-rec (dec n)) (* 2 (fun-rec (- n 2))) (* 3 (fun-rec (- n 3)))))) 132 | 133 | (defn fun-iter [n] 134 | ((fn acc [n n-1 n-2 counter] 135 | (if (= 0 counter) n-2 136 | (acc ( + n (* 2 n-1) (* 3 n-2) ) n n-1 (dec counter)))) 2 1 0 n)) 137 | 138 | ;; Exercise 1.12 139 | 140 | (defn pascal-element-at [row column] 141 | (cond (= row column) 1 142 | (= column 0) 1 143 | :else (+ (pascal-element-at (dec row) (dec column)) (pascal-element-at (dec row) column)))) 144 | 145 | (defn pascal-row [n] 146 | (map #(pascal-element-at n %) (range (inc n)))) 147 | 148 | ;; Exercise 1.13 149 | 150 | (def phi (/ (+ 1 (Math/sqrt 5)) 2)) 151 | 152 | (defn phi-fib [n] 153 | (/ (Math/pow phi n) (Math/sqrt 5))) 154 | 155 | (defn fib [n] 156 | (fib-iter 1 0 n)) 157 | 158 | (defn fib-iter [a b counter] 159 | (if (= 0 counter) b 160 | (fib-iter (+ a b) a (dec counter)))) 161 | 162 | (defn phi-aprox-fib? [n] 163 | (< (abs (- (phi-fib n) (fib n))) 0.5)) 164 | 165 | (def phi-aprox-fib-for-every-n? 166 | (->> 167 | (range 1 11) 168 | (map phi-aprox-fib?) 169 | (every? true?))) 170 | 171 | phi-aprox-fib-for-every-n? 172 | 173 | 174 | ;; Exercise 1.15 175 | 176 | (defn sin [angle] 177 | (do (println "angle " angle) 178 | (if-not (> (abs angle) 0.1) 179 | angle 180 | (p (sin (/ angle 3.0)))))) 181 | 182 | (defn p [x] 183 | (- (* 3 x) (* 4 (cube x)))) 184 | 185 | (sin 90) 186 | 187 | ;; Exercise 1.16 188 | 189 | 190 | (defn exp-iter [b n a] 191 | (cond (= n 0) a 192 | (odd? n) (exp-iter b (dec n) (* a b)) 193 | (even? n) (exp-iter (square b) (/ n 2) a))) 194 | 195 | 196 | ;; Exercise 1.17 197 | 198 | (defn mult [a b] 199 | (if (= b 0) 0 200 | (+ a (mult a (dec b))))) 201 | 202 | (defn doubl [x] (* 2 x)) 203 | 204 | (defn fast-mult-rec [a b] 205 | (cond 206 | (= b 0) 0 207 | (even? b) (doubl (fast-mult-rec a (/ b 2))) 208 | (odd? b) (+ a (fast-mult-rec a (dec b))))) 209 | 210 | ;; Exercise 1.18 211 | 212 | (defn fast-mult-iter [a b acc] 213 | (cond 214 | (= b 0) acc 215 | (even? b) (fast-mult-iter (doubl a) (/ b 2) acc) 216 | (odd? b) (fast-mult-iter a (dec b) (+ a acc)))) 217 | 218 | ;; Exercise 1.19 219 | 220 | (defn clever-fib [n] 221 | (clever-fib-iter 1 0 0 1 n)) 222 | 223 | (defn clever-fib-iter [a b p q counter] 224 | (cond 225 | (= counter 0) b 226 | (even? counter) (clever-fib-iter a 227 | b 228 | (+ (* p p) (* q q)) ; compute p' 229 | (+ (* 2 p q) (* q q)) ; compute q' 230 | (/ counter 2)) 231 | :else (clever-fib-iter (+ (* b q) (* a q) (* a p)) 232 | (+ (* b p) (* a q)) 233 | p 234 | q 235 | (dec counter)))) 236 | 237 | ;; Exercise 1.21. 238 | ;; Use the smallest-divisor procedure to find the smallest divisor of each of the following numbers: 199, 1999, 19999. 239 | 240 | (defn smallest-divisor [n] 241 | (find-divisor n 2)) 242 | 243 | (defn find-divisor [n test-divisor] 244 | (cond (> (square test-divisor) n) n 245 | (divides? test-divisor n) test-divisor 246 | :else (find-divisor n (+ test-divisor 1)))) 247 | 248 | (defn divides? [a b] 249 | (= (rem b a) 0)) 250 | 251 | (smallest-divisor 199) 252 | 253 | (smallest-divisor 1999) 254 | 255 | (smallest-divisor 19999) ; -> 7 256 | 257 | ;; Exercise 1.22. 258 | ;; Most Lisp implementations include a primitive called runtime that returns an integer that specifies the amount of time the system has been running (measured, for example, in microseconds). 259 | ;; The following timed-prime-test procedure, when called with an integer n, prints n and checks to see if n is prime. 260 | ;; If n is prime, the procedure prints three asterisks followed by the amount of time used in performing the test. 261 | 262 | 263 | (defn timed-prime-test [n] 264 | (println "New test with" n) 265 | (start-prime-test n (System/currentTimeMillis))) 266 | 267 | 268 | (defn start-prime-test [n start-time] 269 | (if (prime? n) 270 | (report-prime (- (System/currentTimeMillis) start-time)))) 271 | 272 | (defn report-prime [elapsed-time] 273 | (println "Prime found:" elapsed-time "milliseconds")) 274 | 275 | (defn prime? [n] 276 | (slow-prime? n)) 277 | 278 | (defn slow-prime? [n] 279 | (= n (smallest-divisor n))) 280 | 281 | (defn smallest-divisor [n] 282 | (find-divisor n 2)) 283 | 284 | (defn find-divisor [n test-divisor] 285 | (cond (> (square test-divisor) n) n 286 | (divides? test-divisor n) test-divisor 287 | :else (find-divisor n (+ test-divisor 1)))) 288 | 289 | (defn check-all-primes [coll] 290 | (if-not (empty? coll) 291 | (do 292 | (timed-prime-test (first coll)) 293 | (check-all-primes (rest coll))))) 294 | 295 | 296 | (def larger-than-1k 297 | (->> 298 | (range 1000 1100) 299 | (filter odd?) 300 | )) 301 | 302 | (def larger-than-10k 303 | (->> 304 | (range 10000 10100) 305 | (filter odd?) 306 | )) 307 | 308 | (def larger-than-100k 309 | (->> 310 | (range 100000 100100) 311 | (filter odd?) 312 | )) 313 | 314 | (def larger-than-1m 315 | (->> 316 | (range 1000000 1000100) 317 | (filter odd?) 318 | )) 319 | 320 | (check-all-primes larger-than-1m) 321 | 322 | 323 | ;; Exercise 1.23. The smallest-divisor procedure shown at the start of this section does lots of needless testing: After it checks to see if the number is divisible by 2 there is no point in checking to see if it is divisible by any 324 | 325 | (defn find-divisor [n test-divisor] 326 | (cond (> (square test-divisor) n) n 327 | (divides? test-divisor n) test-divisor 328 | :else (find-divisor n (next-divisor test-divisor)))) 329 | 330 | (defn next-divisor [divisor] 331 | (if (= divisor 2) 3 (+ divisor 2))) 332 | 333 | 334 | 335 | (smallest-divisor 1011) 336 | 337 | ;; Exercise 1.24. 338 | 339 | (defn fast-prime? [n times] 340 | (cond (= times 0) true 341 | (fermat-test n) (fast-prime? n (- times 1)) 342 | :else false)) 343 | 344 | (defn fermat-test [n] 345 | (defn try-it [a] 346 | (= (expmod a n n) a)) 347 | (try-it (+ 1 (rand-int (- n 1))))) 348 | 349 | 350 | (defn expmod [base exp m] 351 | (cond (= exp 0) 1 352 | (even? exp) 353 | (rem (square (expmod base (/ exp 2) m)) 354 | m) 355 | :else 356 | (rem (* base (expmod base (- exp 1) m)) 357 | m))) 358 | 359 | ;; Exercise 1.25 360 | 361 | (defn expmod [base exp m] 362 | (rem (exp-iter base exp) m)) ;; Jumps in the territory of big integers 363 | 364 | 365 | ;; Exercise 1.27 366 | 367 | 368 | (defn expmod [base exp m] 369 | (cond 370 | (= exp 0) 1 371 | (even? exp) (rem (square (expmod base (/ exp 2) m)) 372 | m) 373 | :else (rem (* base (expmod base (dec exp) m)) 374 | m))) 375 | 376 | (defn fermat-test [n a] 377 | (= (expmod a n n) a)) 378 | 379 | (defn fermat-full [n] 380 | (defn iter [a] 381 | (cond 382 | (= a 1) true 383 | (not (fermat-test n a)) false 384 | :else (iter (dec a)))) 385 | (iter (dec n))) 386 | 387 | (fermat-full 561) 388 | 389 | (fermat-full 1105) 390 | 391 | (fermat-full 1729) 392 | 393 | (fermat-full 2465) 394 | 395 | (fermat-full 2821) 396 | 397 | 398 | ;; Exercise 1.28 399 | 400 | (defn square-check [x m] 401 | (if 402 | (and (not (or (= x 1) (= x (- m 1)))) (= (rem (* x x) m) 1)) 403 | 0 404 | (rem (* x x) m))) 405 | 406 | (defn expmod [base exp m] 407 | (cond 408 | (= exp 0) 1 409 | (even? exp) (square-check (expmod base (/ exp 2) m) m) 410 | :else (rem (* base (expmod base (- exp 1) m)) 411 | m))) 412 | 413 | (defn miller-rabin-test [n] 414 | (defn try-it [a] 415 | (= (expmod a (- n 1) n) 1)) 416 | (try-it (+ 2 (rand-int (- n 2))))) 417 | 418 | (miller-rabin-test 561) 419 | 420 | (miller-rabin-test 1105) 421 | 422 | (miller-rabin-test 1729) 423 | 424 | (miller-rabin-test 2465) 425 | 426 | (miller-rabin-test 2821) 427 | 428 | (miller-rabin-test 6601) 429 | 430 | ;; Exercise 1.29 431 | 432 | (defn sum [term a nex b] 433 | (if (> a b) 434 | 0 435 | (+ (term a) 436 | (sum term (nex a) nex b)))) 437 | 438 | (defn integral [f a b dx] 439 | (defn add-dx [x] (+ x dx)) 440 | (* (sum f (+ a (/ dx 2.0)) add-dx b) 441 | dx)) 442 | 443 | 444 | (defn simpson [f a b n] 445 | (def h (/ (- b a) n)) 446 | (defn y [k] 447 | (f (+ a (* k h)))) 448 | (defn term [k] 449 | (* (cond (odd? k) 4 450 | (or (= k 0) (= k n)) 1 451 | (even? k) 2) 452 | (y k))) 453 | (/ (* h (sum term 0 inc n)) 3)) 454 | 455 | 456 | (defn cube [x] (* x x x)) 457 | 458 | (integral cube 0 1 0.01) 459 | 460 | (simpson cube 0 1 100.0) 461 | 462 | (integral cube 0 1 0.001) 463 | 464 | (simpson cube 0 1 1000.0) 465 | 466 | 467 | ;; Exercise 1.30 468 | 469 | (defn sum [term a nex b] 470 | (defn iter [a result] 471 | (if (> a b) result 472 | (iter (nex a) (+ result (term a))))) 473 | (iter a 0)) 474 | 475 | ;; Exercise 1.31 476 | 477 | 478 | (defn product [term a nex b] 479 | (if (> a b) 480 | 1 481 | (* (term a) 482 | (product term (nex a) nex b)))) 483 | 484 | (defn product-iter [term a nex b] 485 | (defn iter [a result] 486 | (if (> a b) result 487 | (iter (nex a) (* result (term a))))) 488 | (iter a 1)) 489 | 490 | (defn factorial [x] 491 | (product-iter identity 1 inc x)) 492 | 493 | (factorial 10) 494 | 495 | (defn pi-term [k] 496 | (if (even? k) 497 | (/ (+ 2 k) (+ 3 k)) 498 | (/ (+ 3 k) (+ 2 k)))) 499 | 500 | (def pi ( * 4.0 (product pi-term 0 inc 1000))) 501 | 502 | pi 503 | 504 | ;; Exercise 1.32 505 | 506 | (defn accumulate [combiner null-value term a next b] 507 | (if (> a b) null-value 508 | (combiner (term a) 509 | (accumulate combiner null-value term (next a) next b)))) 510 | 511 | (defn accum-iter [combiner null-value term a next b] 512 | (defn iter [a result] 513 | (if (> a b) result 514 | (iter (next a) (combiner (term a) result)))) 515 | (iter a null-value)) 516 | 517 | ;; Exercise 1.33 518 | 519 | (defn filtered-accumulate [combiner null-value term a next b valid?] 520 | (cond 521 | (> a b) null-value 522 | (valid? a) (combiner (term a) (filtered-accumulate combiner null-value term (next a) next b valid?)) 523 | :else (filtered-accumulate combiner null-value term (next a) next b valid?))) 524 | 525 | (defn sum-squares-prime-numbers [a b] 526 | (filtered-accumulate + 0 square a inc b prime?)) 527 | 528 | (defn product-relative-primes-with [n] 529 | (defn relative-prime? [a] 530 | (= 1 (gcd a n))) 531 | (filtered-accumulate * 1 identity 2 inc (dec n) relative-prime?)) 532 | 533 | (defn gcd [a b] 534 | (if (= b 0) 535 | a 536 | (gcd b (rem a b)))) 537 | 538 | ;; Exercise 1.34 539 | 540 | (defn f [g] 541 | (g 2)) 542 | 543 | (f f) ; evaluates to (2 2) 544 | 545 | ;; Exercise 1.35 546 | 547 | (def tolerance 0.00001) 548 | 549 | (defn average [a b] (/ (+ a b) 2)) 550 | 551 | (defn average-damp [f] 552 | (fn [x] (average x (f x)))) 553 | 554 | (defn fixed-point [f first-guess] 555 | (defn close-enough? [v1 v2] 556 | (< (Math/abs (- v1 v2)) tolerance)) 557 | (defn try-it [guess] 558 | (println guess) 559 | (let [next (f guess)] 560 | (if (close-enough? guess next) 561 | next 562 | (try-it next)))) 563 | (try-it first-guess)) 564 | 565 | (defn sqrt [x] 566 | (fixed-point (average-damp (fn [y] (/ x y))) 1.0)) 567 | 568 | (sqrt 16) 569 | 570 | (def golden-ratio (fixed-point (fn [x] (+ 1 (/ 1 x))) 1.0)) 571 | 572 | 573 | ;; Exercise 1.36 574 | 575 | (def x-to-the-x (fixed-point (fn [x] (/ (Math/log 1000) (Math/log x))) 2)) 576 | 577 | (def x-to-the-x-ad (fixed-point (fn [x] (average-damping (Math/log 1000) (Math/log x)))) 2) 578 | 579 | ;; Exercise 1.37 580 | 581 | (defn cont-frac [n d k] 582 | (defn frac [i] 583 | (if (< i k) 584 | (/ (n i) (+ (d i) (frac (+ i 1)))) 585 | (/ (n i) (d i)))) 586 | (frac 1)) 587 | 588 | (defn cont-frac-iter [n d k] 589 | (defn frac-iter [i acc] 590 | (if (zero? i) 591 | acc 592 | (frac-iter (dec i) (/ (n i) (+ (d i) acc))))) 593 | (frac-iter (dec k) (/ (n k) (d k)))) 594 | 595 | (cont-frac (fn [n] 1.0) (fn [d] 1.0) 11) 596 | 597 | 598 | ;; Exercise 1.38 599 | 600 | (def e (+ 2 (cont-frac (fn [n] 1.0) euler-sequence 100))) 601 | 602 | (defn euler-sequence [x] 603 | (if (not (= 0 (rem (+ x 1) 3))) 604 | 1 605 | (* 2 (/ (+ x 1) 3)))) 606 | 607 | ;; Exercise 1.39 608 | 609 | (defn tan-cf [x k] (cont-frac (fn [n] (if (= 1 n) x (* x x))) (fn [d] (- (* 2 d) 1)) k)) 610 | 611 | (tan-cf 3.0 100) 612 | 613 | ;; Exercise 1.40 614 | 615 | (def dx 0.00001) 616 | 617 | (defn deriv [g] 618 | (fn [x] (/ (- (g (+ x dx)) (g x)) dx))) 619 | 620 | (defn cube [x] (* x x x)) 621 | 622 | ((deriv cube) 5) 623 | 624 | (defn newton-transform [g] 625 | (fn [x] 626 | (- x (/ (g x) ((deriv g) x))))) 627 | 628 | (defn newtons-method [g guess] 629 | (fixed-point (newton-transform g) guess)) 630 | 631 | 632 | (defn sqrt [x] 633 | (newtons-method (fn [y] (- (square y) x)) 634 | 1.0)) 635 | 636 | (sqrt 36) 637 | 638 | 639 | (defn fixed-point-of-transform [g transform guess] 640 | (fixed-point (transform g) guess)) 641 | 642 | (defn sqrt [x] 643 | (fixed-point-of-transform (fn [y] (/ x y)) 644 | average-damp 645 | 1.0)) 646 | 647 | (sqrt 25) 648 | 649 | (defn sqrt [x] 650 | (fixed-point-of-transform (fn [y] (- (square y) x)) 651 | newton-transform 652 | 1.0)) 653 | 654 | (sqrt 49) 655 | 656 | 657 | (defn cubic [a b c] (fn [x] (+ (cube x) (* a (square x)) (* b x) c))) 658 | 659 | (newtons-method (cubic 2 3 4) 1) ; -1.6506291914330982 660 | 661 | ;; Exercise 1.41 662 | 663 | (defn double [f] (fn [x] (f (f x)))) 664 | 665 | (((double (double double)) inc) 5) 666 | 667 | ;; Exercise 1.42 668 | 669 | (defn compose [f g] (fn [x] (f (g x)))) 670 | 671 | ((compose square inc) 6) 672 | 673 | ;; Exercise 1.43 674 | 675 | (defn repeated [f n] 676 | (if (= n 1) f 677 | (compose f (repeated f (dec n))))) 678 | 679 | ((repeated square 2) 5) 680 | 681 | ;; Exercise 1.44 682 | 683 | (defn smooth [f] 684 | (fn [x] 685 | (/ (+ (f (+ x dx)) (f x) (f (- x dx))) 3))) 686 | 687 | ((smooth square) 4.0) 688 | 689 | (defn n-fold-smooth [f n] 690 | ((repeated smooth n) f)) 691 | 692 | ((n-fold-smooth square 3) 4.0) 693 | 694 | ;; Exercise 1.45 695 | 696 | (defn fourth-root [x] 697 | (fixed-point ((repeated average-damp 2) (fn [y] (/ x (cube y)))) 1.0)) 698 | 699 | (fourth-root 256) 700 | 701 | (Math/pow 2 10) 702 | 703 | (defn log2 [x] 704 | (/ (Math/log x) (Math/log 2))) 705 | 706 | (defn nth-avg-damp [n] (int (Math/floor (log2 n)))) 707 | 708 | (nth-avg-damp 4294967296) 709 | 710 | (defn nth-root [x n] 711 | (fixed-point ((repeated average-damp (nth-avg-damp n)) (fn [y] (/ x (Math/pow y (dec n))))) 1.0)) 712 | 713 | (nth-root 4294967296 32) 714 | 715 | ;; Exercise 1.46 716 | 717 | (defn iterative-improve [good-enough? improve] 718 | (defn try-it [guess] 719 | (if (good-enough? guess) guess 720 | (try-it (improve guess))))) 721 | 722 | (defn sqrt [x] 723 | ((iterative-improve (fn [guess] (good-enough? guess x)) (fn [guess] (improve guess x))) 1.0)) 724 | 725 | (sqrt 16) 726 | 727 | (defn fixed-point [f first-guess] 728 | ((iterative-improve (fn [guess] (close-enough? guess (f guess))) f) first-guess)) 729 | 730 | (defn cube-root [x] 731 | (fixed-point (average-damp (fn [y] (/ x (square y)))) 1.0)) 732 | 733 | (cube-root 64) 734 | -------------------------------------------------------------------------------- /src/sicp/chapter-2.clj: -------------------------------------------------------------------------------- 1 | (ns sicp.ch2) 2 | 3 | ;; Exercise 2.1. 4 | ;; Define a better version of make-rat that handles both positive and negative arguments. 5 | ;; Make-rat should normalize the sign so that if the rational number is positive, both the numerator and denominator are positive, and if the rational number is negative, only the numerator is negative. 6 | 7 | (defn add-rat [x y] 8 | (make-rat (+ (* (numer x) (denom y)) 9 | (* (numer y) (denom x))) 10 | (* (denom x) (denom y)))) 11 | (defn sub-rat [x y] 12 | (make-rat (- (* (numer x) (denom y)) 13 | (* (numer y) (denom x))) 14 | (* (denom x) (denom y)))) 15 | (defn mul-rat [x y] 16 | (make-rat (* (numer x) (numer y)) 17 | (* (denom x) (denom y)))) 18 | (defn div-rat [x y] 19 | (make-rat (* (numer x) (denom y)) 20 | (* (denom x) (numer y)))) 21 | (defn equal-rat? [x y] 22 | (= (* (numer x) (denom y)) 23 | (* (numer y) (denom x)))) 24 | 25 | (defn make-rat [n d] 26 | [n d]) 27 | 28 | (defn numer [r] (first r)) 29 | 30 | (defn denom [r] (second r)) 31 | 32 | (defn print-rat [r] 33 | (println-str (numer r) "/" (denom r))) 34 | 35 | (def one-half (make-rat 1 2)) 36 | 37 | (print-rat one-half) 38 | 39 | (def one-third (make-rat 1 3)) 40 | 41 | (print-rat (add-rat one-half one-third)) 42 | 43 | (print-rat (mul-rat one-half one-third)) 44 | 45 | (print-rat (add-rat one-third one-third)) 46 | 47 | (defn gcd [a b] 48 | (if (= b 0) 49 | a 50 | (gcd b (rem a b)))) 51 | 52 | (defn make-rat [n d] 53 | (let [g (gcd n d)] 54 | [(/ n g) (/ d g)])) 55 | 56 | (print-rat (add-rat one-third one-third)) 57 | 58 | (defn make-rat-better [n d] 59 | (if (< d 0) (make-rat (* -1 n) (* -1 d)) 60 | (make-rat n d))) 61 | 62 | (make-rat-better 6 -7) 63 | 64 | ;; Exercise 2.2 65 | 66 | (defn make-segment [a b] [a b]) 67 | 68 | (defn start-segment [s] (first s)) 69 | 70 | (defn end-segment [s] (second s)) 71 | 72 | (defn make-point [x y] [x y]) 73 | 74 | (defn x-point [p] (first p)) 75 | 76 | (defn y-point [p] (second p)) 77 | 78 | (defn print-point [p] (println-str "(" (x-point p) "," (y-point p) ")")) 79 | 80 | (defn midpoint-segment [s] 81 | (make-point 82 | (/ (+ (x-point (start-segment s)) (x-point (end-segment s))) 2) 83 | (/ (+ (y-point (start-segment s)) (y-point (end-segment s))) 2) 84 | )) 85 | 86 | (def segment (make-segment (make-point -3 4) (make-point 1 2))) 87 | 88 | (print-point (midpoint-segment segment)) 89 | 90 | 91 | ;; Exercise 2.3 92 | 93 | (defn make-rect [left-right-diagonal] left-right-diagonal) 94 | 95 | (defn rec-width [r] (Math/abs (- (x-point (start-segment r)) (x-point (end-segment r))))) 96 | 97 | (defn rec-height [r] (Math/abs (- (y-point (end-segment r)) (y-point (start-segment r))))) 98 | 99 | (defn rec-perimeter [r] (+ (* 2 (rec-height r)) (* 2 (rec-width r)))) 100 | 101 | (defn rec-area [r] (* (rec-height r) (rec-width r))) 102 | 103 | (rec-perimeter (make-rect segment)) 104 | 105 | (rec-area (make-rect segment)) 106 | 107 | (defn make-rect [width height top-left-point] [width height top-left-point]) 108 | 109 | (defn rec-width [r] (first r)) 110 | 111 | (defn rec-height [r] (second r)) 112 | 113 | (rec-perimeter (make-rect 4 2 :top-left-point)) 114 | 115 | (rec-area (make-rect 4 2 :top-left-point)) 116 | 117 | ;; Exercise 2.4 118 | 119 | (defn cons' [x y] 120 | (fn [m] (m x y))) 121 | 122 | (defn car' [z] 123 | (z (fn [p q] p))) 124 | 125 | (defn cdr' [z] 126 | (z (fn [p q] q))) 127 | 128 | (def pair (cons' :a :b)) 129 | 130 | (car' pair) 131 | 132 | (cdr' pair) 133 | 134 | ;; Exercise 2.5 135 | 136 | (defn cons' [a b] (* (Math/pow 2 a) (Math/pow 3 b))) 137 | 138 | (defn car' [x] (if (zero? (rem x 2)) (+ 1 (car' (/ x 2))) 0)) 139 | 140 | (defn cdr' [x] (if (zero? (rem x 3)) (+ 1 (cdr' (/ x 3))) 0)) 141 | 142 | (car' (cons' 3 4)) 143 | 144 | (cdr' (cons' 3 4)) 145 | 146 | ;; Exercise 2.6 147 | 148 | (def zero (fn [f] (fn [x] x))) 149 | 150 | ((zero inc) 0) 151 | 152 | (defn add-1 [n] 153 | (fn [f] (fn [x] (f ((n f) x))))) 154 | 155 | (def one (fn [f] (fn [x] (f x)))) 156 | 157 | ((one inc) 0) 158 | 159 | (def two 160 | (fn [f] 161 | (fn [x] (f (f x))))) 162 | 163 | (defn plus [a b] 164 | (fn [f] 165 | (fn [x] 166 | ((a f)((b f) x))))) 167 | 168 | (def three (plus two one)) 169 | 170 | ((three inc) 0) 171 | 172 | (defn mult [a b] 173 | (fn [f] 174 | (fn [x] 175 | ((a (b f)) x)))) 176 | 177 | (def six (mult three two)) 178 | 179 | ((six inc) 0) 180 | 181 | (defn exp [a b] 182 | (fn [f] 183 | (fn [x] 184 | (((b a) f) x)))) 185 | 186 | (def sixty-four (exp two six)) 187 | 188 | ((sixty-four inc) 0) 189 | 190 | ;; Exercise 2.7 191 | 192 | (defn make-interval [a b] [a b]) 193 | 194 | (defn lower-bound [i] (first i)) 195 | 196 | (defn upper-bound [i] (second i)) 197 | 198 | (defn add-interval [x y] 199 | (make-interval (+ (lower-bound x) (lower-bound y)) 200 | (+ (upper-bound x) (upper-bound y)))) 201 | 202 | (defn mul-interval [x y] 203 | (let [p1 (* (lower-bound x) (lower-bound y)) 204 | p2 (* (lower-bound x) (upper-bound y)) 205 | p3 (* (upper-bound x) (lower-bound y)) 206 | p4 (* (upper-bound x) (upper-bound y))] 207 | (make-interval (min p1 p2 p3 p4) 208 | (max p1 p2 p3 p4)))) 209 | 210 | (defn div-interval [x y] 211 | (mul-interval x 212 | (make-interval (/ 1.0 (upper-bound y)) 213 | (/ 1.0 (lower-bound y))))) 214 | 215 | ;; Exercise 2.8 216 | 217 | (defn sub-interval [x y] 218 | (make-interval (- (lower-bound x) (upper-bound y)) 219 | (- (upper-bound x) (lower-bound y)))) 220 | 221 | ;; Exercise 2.9 222 | 223 | (defn width-interval [i] (- (upper-bound i) (lower-bound i))) 224 | 225 | (def interval1 (make-interval 9.5 12)) 226 | 227 | (def interval2 (make-interval 3.5 7.5)) 228 | 229 | (def interval3 (make-interval 0.5 4.5)) 230 | 231 | (= (width-interval (add-interval interval1 interval2)) (width-interval (add-interval interval1 interval3))) 232 | 233 | (= (width-interval (sub-interval interval1 interval2)) (width-interval (sub-interval interval1 interval3))) 234 | 235 | (not= (width-interval (mul-interval interval1 interval2)) (width-interval (mul-interval interval1 interval3))) 236 | 237 | (not= (width-interval (div-interval interval1 interval2)) (width-interval (div-interval interval1 interval3))) 238 | 239 | ;; Exercise 2.10 240 | 241 | (defn includes-zero? [interval] 242 | (and (<= (lower-bound interval) 0) (>= (upper-bound interval) 0))) 243 | 244 | (defn div-interval [x y] 245 | (if (includes-zero? y) 246 | (throw (ArithmeticException. "Divide by zero")) 247 | (mul-interval x 248 | (make-interval (/ 1.0 (upper-bound y)) 249 | (/ 1.0 (lower-bound y)))))) 250 | 251 | ;; Exercise 2.11 252 | 253 | (defn mul-interval [x y] 254 | (let [xlo (lower-bound x) 255 | xup (upper-bound x) 256 | ylo (lower-bound y) 257 | yup (upper-bound y)] 258 | (cond (and (>= xlo 0) (>= xup 0) (>= ylo 0) (>= yup 0)) ; [+, +] * [+, +] 259 | (make-interval (* xlo ylo) (* xup yup)) 260 | 261 | (and (>= xlo 0) (>= xup 0) (<= ylo 0) (>= yup 0)) ; [+, +] * [-, +] 262 | (make-interval (* xup ylo) (* xup yup)) 263 | 264 | (and (>= xlo 0) (>= xup 0) (<= ylo 0) (<= yup 0)) ; [+, +] * [-, -] 265 | (make-interval (* xup ylo) (* xlo yup)) 266 | 267 | (and (<= xlo 0) (>= xup 0) (>= ylo 0) (>= yup 0)) ; [-, +] * [+, +] 268 | (make-interval (* xlo yup) (* xup yup)) 269 | 270 | (and (<= xlo 0) (>= xup 0) (<= ylo 0) (>= yup 0)) ; [-, +] * [-, +] 271 | (make-interval (min (* xup ylo) (* xlo yup)) 272 | (max (* xlo ylo) (* xup yup))) 273 | 274 | (and (<= xlo 0) (>= xup 0) (<= ylo 0) (<= yup 0)) ; [-, +] * [-, -] 275 | (make-interval (* xup ylo) (* xlo ylo)) 276 | 277 | (and (<= xlo 0) (<= xup 0) (>= ylo 0) (>= yup 0)) ; [-, -] * [+, +] 278 | (make-interval (* xlo yup) (* xup ylo)) 279 | 280 | (and (<= xlo 0) (<= xup 0) (<= ylo 0) (>= yup 0)) ; [-, -] * [-, +] 281 | (make-interval (* xlo yup) (* xlo ylo)) 282 | 283 | (and (<= xlo 0) (<= xup 0) (<= ylo 0) (<= yup 0)) ; [-, -] * [-, -] 284 | (make-interval (* xup yup) (* xlo ylo))))) 285 | 286 | (mul-interval interval1 interval2) 287 | 288 | ;; Exercise 2.12 289 | 290 | (defn make-center-width [c w] 291 | (make-interval (- c w) (+ c w))) 292 | 293 | (defn center [i] 294 | (/ (+ (lower-bound i) (upper-bound i)) 2)) 295 | 296 | (defn width [i] 297 | (/ (- (upper-bound i) (lower-bound i)) 2)) 298 | 299 | (defn make-center-percent [c p] 300 | (let [w (* c (/ p 100.0))] 301 | (make-center-width c w))) 302 | 303 | (defn percent [i] 304 | (* (/ (width i) (center i)) 100.0)) 305 | 306 | (make-center-width 100 15) 307 | 308 | (make-center-percent 100 15) 309 | 310 | ;; Exercise 2.13 311 | 312 | (def small-perc1 (make-center-percent 10 2)) 313 | (def small-perc2 (make-center-percent 30 7)) 314 | (percent (mul-interval small-perc1 small-perc2)) ;; ~ 9 315 | 316 | ;; Exercise 2.14 317 | 318 | (defn par1 [r1 r2] 319 | (div-interval (mul-interval r1 r2) 320 | (add-interval r1 r2))) 321 | 322 | (defn par2 [r1 r2] 323 | (let [one (make-interval 1 1)] 324 | (div-interval one 325 | (add-interval (div-interval one r1) 326 | (div-interval one r2))))) 327 | 328 | (par1 interval1 interval2) 329 | (par2 interval1 interval2) 330 | 331 | (def should-be-one (div-interval interval1 interval1)) 332 | (center should-be-one) 333 | (percent interval1) 334 | 335 | ;; Exercise 2.15 336 | 337 | ;> Because diving an interval by itself does not yield one, so repeating the same iterval in the formula introduces errors when you simplify it. 338 | 339 | ;; Exercise 2.16 340 | 341 | ;> http://en.wikipedia.org/wiki/Interval_arithmetic#Dependency_problem 342 | 343 | ;; Exercise 2.17 344 | 345 | (defn last-pair [l] 346 | (if (empty? (rest l)) (first l) (last-pair (rest l)))) 347 | 348 | (last-pair [1 2 3 4]) 349 | 350 | ;; Exercise 2.18 351 | 352 | (defn append [l1 l2] 353 | (if (empty? l1) [l2] (cons (first l1) (append (rest l1) l2)))) 354 | 355 | (append [1 2] [3 4]) 356 | 357 | (defn reverse' [l] 358 | (if (empty? l) l (append (reverse' (rest l)) (first l)))) 359 | 360 | (reverse' [1 2 3 4 5]) 361 | 362 | ;; Exercise 2.19 363 | 364 | (def us-coins (list 50 25 10 5 1)) 365 | (def uk-coins (list 100 50 20 10 5 2 1)) 366 | 367 | (defn no-more? [coin-values] (empty? coin-values)) 368 | 369 | (defn first-denomination [coin-values] (first coin-values)) 370 | 371 | (defn except-first-denomination [coin-values] (rest coin-values)) 372 | 373 | (defn cc [amount coin-values] 374 | (cond (= amount 0) 1 375 | (or (< amount 0) (no-more? coin-values)) 0 376 | :else (+ (cc amount (except-first-denomination coin-values)) 377 | (cc (- amount (first-denomination coin-values)) 378 | coin-values)))) 379 | 380 | (cc 100 us-coins) 381 | (cc 100 uk-coins) 382 | 383 | (cc 100 (reverse uk-coins)) 384 | (cc 100 (reverse us-coins)) 385 | 386 | ; Order does not matter because the execution is a decision tree 387 | 388 | ;; Exercise 2.20 389 | 390 | (defn same-parity [pivot & more] 391 | (cons pivot (same-parity' pivot more))) 392 | 393 | (defn same-parity' [pivot candidates] 394 | (if-let [candidate (first candidates)] 395 | (if (= (rem pivot 2) (rem candidate 2)) 396 | (cons candidate (same-parity' pivot (rest candidates))) 397 | (same-parity' pivot (rest candidates))))) 398 | 399 | (same-parity 1) 400 | 401 | (same-parity 1 2 3 4 5 6 7 8 9 ) 402 | 403 | ;; Exercise 2.21 404 | 405 | (defn square-list [items] 406 | (if (empty? items) 407 | [] 408 | (cons (* (first items) (first items)) (square-list (rest items))))) 409 | 410 | (square-list [1 23 4 5]) 411 | 412 | (defn square-list [items] 413 | (map #(* % %) items)) 414 | 415 | (square-list [1 23 4 5]) 416 | 417 | ;; Exercise 2.22 418 | 419 | (defn square-list [items] 420 | (defn iter [things answer] 421 | (if (empty? things) 422 | answer 423 | (iter (rest things) 424 | (cons (#(* % %) (first things)) 425 | answer)))) 426 | (iter items [])) 427 | 428 | (square-list [1 2 3 4]) 429 | 430 | ; cons insert element to first position 431 | 432 | (defn square-list [items] 433 | (defn iter [things answer] 434 | (if (empty? things) 435 | answer 436 | (iter (rest things) 437 | (cons answer 438 | (#(* % %) (first things)))))) 439 | (iter items nil)) 440 | 441 | ; This should fail 442 | (square-list [1 2 3 4]) 443 | 444 | ; cons takes an element and a list. In that example we should use append 445 | 446 | ;; Exercise 2.23 447 | 448 | (defn for-each [f items] 449 | (let [head (first items)] 450 | (when head (f head) (for-each f (rest items))))) 451 | 452 | (for-each println [1 2 3]) 453 | 454 | ;; Exercise 2.24 455 | 456 | (list 1 (list 2 (list 3 4))) 457 | 458 | ;; Exercise 2.25 459 | 460 | (first (rest (first (rest (rest '(1 3 (5 7) 9)))))) 461 | 462 | (first (first '((7)))) 463 | 464 | (first (rest (first (rest (first (rest (first (rest (first (rest (first (rest '(1 (2 (3 (4 (5 (6 7)))))))))))))))))) 465 | 466 | ;; Exercise 2.26 467 | 468 | (def x (list 1 2 3)) 469 | (def y (list 4 5 6)) 470 | 471 | (append x y) ;> (1 2 3 4 5 6) 472 | 473 | (cons x y) ;> ((1 2 3) 4 5 6) 474 | 475 | (list x y) ;> ((1 2 3) (4 5 6)) 476 | 477 | ;; Exercise 2.27 478 | 479 | (defn deep-reverse [l] 480 | (when-let [head (first l)] 481 | (append (deep-reverse (rest l)) (if (coll? head) (deep-reverse head) head)))) 482 | 483 | (deep-reverse [1 2 3 [1 2 3 [4 5 6]]]) 484 | 485 | ;; Exercise 2.28 486 | 487 | (defn fringe [tree] 488 | (cond (nil? tree) [] 489 | (not (coll? tree)) [tree] 490 | :else (concat (fringe (first tree)) 491 | (fringe (next tree))))) 492 | 493 | (fringe [1 2 3 [1 2 3 [4 5 6]]]) 494 | 495 | ;; Exercise 2.29 496 | 497 | (defn make-mobile [left right] [left right]) 498 | (defn make-branch [length structure] [length structure]) 499 | (defn left-branch [mobile] (mobile 0)) 500 | (defn right-branch [mobile] (mobile 1)) 501 | (defn branch-length [branch] (branch 0)) 502 | (defn branch-structure [branch] (branch 1)) 503 | 504 | (defn branch-weight [branch] 505 | (let [structure (branch-structure branch)] 506 | (if (number? structure) structure (total-weight structure)))) 507 | 508 | (defn total-weight [mobile] (+ (branch-weight (left-branch mobile)) (branch-weight (right-branch mobile)))) 509 | 510 | (def unbalanced-mobile 511 | (make-mobile 512 | (make-branch 1 513 | (make-mobile 514 | (make-branch 2 3) 515 | (make-branch 4 5) 516 | ) 517 | ) 518 | (make-branch 3 519 | (make-mobile 520 | (make-branch 4 5) 521 | (make-branch 6 7) 522 | ) 523 | ) 524 | ) 525 | ) 526 | 527 | (total-weight unbalanced-mobile) 528 | 529 | (defn balanced-branch? [branch] 530 | (let [structure (branch-structure branch)] 531 | (if (number? structure) true (balanced? structure)))) 532 | 533 | (defn balanced? [mobile] 534 | (let [lb (left-branch mobile) rb (right-branch mobile)] 535 | (and 536 | (balanced-branch? lb) 537 | (balanced-branch? rb) 538 | (= (* (branch-length lb) (branch-weight lb)) (* (branch-length rb) (branch-weight rb)))))) 539 | 540 | 541 | (balanced? unbalanced-mobile) 542 | 543 | (def balanced-mobile 544 | (make-mobile 545 | (make-branch 2 546 | (make-mobile 547 | (make-branch 6 7) 548 | (make-branch 14 3) 549 | ) 550 | ) 551 | (make-branch 5 4) 552 | ) 553 | ) 554 | 555 | (balanced? balanced-mobile) 556 | 557 | ;; Exercise 2.30 558 | 559 | (defn square-tree [tree] 560 | (cond (not (coll? tree)) (* tree tree) 561 | (empty? tree) nil 562 | :else (cons (square-tree (first tree)) 563 | (square-tree (rest tree))))) 564 | 565 | (square-tree (list 1 (list 2 (list 3 4) 5) (list 6 7))) 566 | 567 | (defn square-tree [tree] 568 | (map (fn [sub-tree] 569 | (if (coll? sub-tree) 570 | (square-tree sub-tree) 571 | (* sub-tree sub-tree))) 572 | tree)) 573 | 574 | (square-tree (list 1 (list 2 (list 3 4) 5) (list 6 7))) 575 | 576 | ;; Exercise 2.31 577 | 578 | (defn tree-map [f tree] 579 | (map (fn [sub-tree] 580 | (if (coll? sub-tree) 581 | (tree-map f sub-tree) 582 | (f sub-tree))) 583 | tree)) 584 | 585 | (tree-map #(* % %) (list 1 (list 2 (list 3 4) 5) (list 6 7))) 586 | 587 | ;; Exercise 2.32 588 | 589 | (defn subsets [s] 590 | (if (nil? s) [[]] 591 | (let [rest (subsets (next s))] 592 | (concat rest (map #(cons (first s) %) rest))))) 593 | 594 | ;; Exercise 2.33 595 | 596 | (defn accumulate [op initial sequence] 597 | (if (empty? sequence) 598 | initial 599 | (op (first sequence) 600 | (accumulate op initial (rest sequence))))) 601 | 602 | (defn map' [p sequence] 603 | (accumulate (fn [x y] (cons (p x) y)) [] sequence)) 604 | 605 | (map' #(* % 2) [1 2 3]) 606 | 607 | (defn append [seq1 seq2] 608 | (accumulate cons seq2 seq1)) 609 | 610 | (append [1 2 3 4] [5 6 7]) 611 | 612 | (defn length [sequence] 613 | (accumulate (fn [x y] (+ y 1)) 0 sequence)) 614 | 615 | (length [:one :two :three :four]) 616 | 617 | ;; Exercise 2.34 618 | 619 | (defn horner-eval [x coefficient-sequence] 620 | (accumulate (fn [this-coeff higher-terms] (+ this-coeff (* x higher-terms))) 621 | 0 622 | coefficient-sequence)) 623 | 624 | 625 | (horner-eval 2 (list 1 3 0 5 0 1)) 626 | 627 | ;; Exercise 2.35 628 | 629 | (defn count-leaves [t] 630 | (accumulate + 0 (map (fn [x] 1) (fringe t)))) 631 | 632 | (count-leaves [1 [2 [5 [6]]] 3 [ 1 2 [ 3 4]]]) 633 | 634 | ;; Exercise 2.36 635 | 636 | (defn accumulate-n [op init seqs] 637 | (if (empty? (first seqs)) nil 638 | (cons (accumulate op init (map first seqs)) 639 | (accumulate-n op init (map rest seqs))))) 640 | 641 | (accumulate-n + 0 [[1 2 3] [4 5 6] [7 8 9]]) 642 | 643 | ;; Exercise 2.37 644 | 645 | (defn dot-product [v w] 646 | (accumulate + 0 (map * v w))) 647 | 648 | (defn matrix-*-vector [m v] 649 | (map #(dot-product v %) m)) 650 | 651 | (defn transpose [mat] 652 | (accumulate-n cons [] mat)) 653 | 654 | (defn matrix-*-matrix [m n] 655 | (let [cols (transpose n)] 656 | (map #(matrix-*-vector cols %) m))) 657 | 658 | 659 | (def v (list 1 3 -5)) 660 | (def w (list 4 -2 -1)) 661 | 662 | (dot-product v w) ;> 3 663 | 664 | (def m (list (list 1 2 3) (list 4 5 6))) 665 | 666 | (matrix-*-vector m v) ;> [-8 -11] 667 | 668 | (def n (list (list 14 9 3) (list 2 11 15))) 669 | 670 | (matrix-*-matrix m n) 671 | 672 | ;; Exercise 2.38 673 | 674 | (defn fold-right [op initial sequence] 675 | (if (nil? sequence) 676 | initial 677 | (op (first sequence) 678 | (fold-right op initial (next sequence))))) 679 | 680 | (defn fold-left [op initial sequence] 681 | (defn iter [result rest] 682 | (if (nil? rest) 683 | result 684 | (iter (op result (first rest)) 685 | (next rest)))) 686 | (iter initial sequence)) 687 | 688 | 689 | (fold-right / 1 (list 1 2 3)) (/ 1 (/ 2 (/ 3 1))) 690 | 691 | (fold-left / 1 (list 1 2 3)) (/ (/ (/ 1 1) 2) 3) 692 | 693 | (fold-right list nil (list 1 2 3)) 694 | 695 | (fold-left list nil (list 1 2 3)) 696 | 697 | (fold-right + 0 (list 1 2 3)) 698 | 699 | (fold-left + 0 (list 1 2 3)) 700 | 701 | ;; Exercise 2.39 702 | 703 | (defn reverse [sequence] 704 | (fold-right (fn [x y] (append y [x])) [] sequence)) 705 | 706 | (reverse [1 2 3]) 707 | 708 | (defn reverse [sequence] 709 | (fold-left (fn [x y] (cons y x)) [] sequence)) 710 | 711 | (reverse [1 2 3]) 712 | 713 | ;; Exercise 2.40 714 | 715 | (defn unique-pairs [n] 716 | (mapcat 717 | (fn [i] (map 718 | (fn [j] [i j]) 719 | (range 1 i))) 720 | (range 1 (inc n)))) 721 | 722 | (unique-pairs 4) 723 | 724 | 725 | (defn prime? [n] 726 | (-> n (bigint) (.toBigInteger) (.isProbablePrime 100))) 727 | 728 | (defn prime-sum? [[x y]] 729 | (prime? (+ x y))) 730 | 731 | (defn make-pair-sum [[x y]] 732 | [x y (+ x y)]) 733 | 734 | 735 | (defn prime-sum-pairs [n] 736 | (map make-pair-sum (filter prime-sum? (unique-pairs n)))) 737 | 738 | (prime-sum-pairs 6) 739 | 740 | ;; Exercise 2.41 741 | 742 | (defn unique-triplets [n] 743 | (mapcat 744 | (fn [i] (mapcat 745 | (fn [j] (map 746 | (fn [k] [i j k]) 747 | (range 1 j))) 748 | (range 1 i))) 749 | (range 1 (inc n)))) 750 | 751 | (defn make-triplet-sum [[x y z]] 752 | [x y z (+ x y z)]) 753 | 754 | (defn sum-to [[x y z] n] 755 | (= n (+ x y z))) 756 | 757 | (defn sum-triplets [n] 758 | (map make-triplet-sum (filter #(sum-to % n) (unique-triplets n)))) 759 | 760 | (sum-triplets 15) 761 | 762 | ;; Exercise 2.42 763 | 764 | (def empty-board []) 765 | 766 | (defn adjoin-position [new-row col rest-of-queens] 767 | (cons new-row rest-of-queens)) 768 | 769 | (defn safe? [k positions] 770 | (def candidate (first positions)) 771 | (defn safe-iter [top bot remain] 772 | (cond (empty? remain) true 773 | (or (= (first remain) candidate) 774 | (= (first remain) top) 775 | (= (first remain) bot)) false 776 | :else 777 | (safe-iter (- top 1) (+ bot 1) (rest remain)))) 778 | (safe-iter (- candidate 1) (+ candidate 1) (rest positions))) 779 | 780 | (defn queens [board-size] 781 | (defn queen-cols [k] 782 | (if (= k 0) 783 | (list empty-board) 784 | (filter (fn [positions] (safe? k positions)) 785 | (mapcat 786 | (fn [rest-of-queens] 787 | (map (fn [new-row] 788 | (adjoin-position new-row k rest-of-queens)) 789 | (range 1 (inc board-size)))) 790 | (queen-cols (dec k)))))) 791 | (queen-cols board-size)) 792 | 793 | (queens 4) 794 | 795 | ;; Exercise 2.42 796 | 797 | (defn queens [board-size] 798 | (defn queen-cols [k] 799 | (if (= k 0) 800 | (list empty-board) 801 | (filter (fn [positions] (safe? k positions)) 802 | (mapcat 803 | (fn [new-row] 804 | (map (fn [rest-of-queens] 805 | (adjoin-position new-row k rest-of-queens)) 806 | (queen-cols (dec k)))) 807 | (range 1 (inc board-size)))))) 808 | (queen-cols board-size)) 809 | 810 | ;; Exercise 2.43 811 | 812 | ; (queens 6) -> from linear recursive to tree recursive = T^board-size 813 | 814 | ;; Exercise 2.44 815 | 816 | (defn below [p1 p2] :new-painter) 817 | (defn beside [p1 p2] :new-painter) 818 | 819 | (defn up-split [painter n] 820 | (if (= n 0) 821 | painter 822 | (let [smaller (up-split painter (- n 1))] 823 | (below painter (beside smaller smaller))))) 824 | 825 | ;; Exercise 2.45 826 | 827 | (defn split [split1 split2] 828 | (fn [painter n] 829 | (if (= n 0) 830 | painter 831 | (let [smaller (split painter (dec n))] 832 | (split1 painter (split2 smaller smaller)))))) 833 | 834 | (def right-split (split beside below)) 835 | (def up-split (split below beside)) 836 | 837 | ;; Exercise 2.46 838 | 839 | (defn make-vect [x y]) 840 | (defn xcor-vect [v] (v 0)) 841 | (defn ycor-vect [v] (v 1)) 842 | 843 | (defn add-vect [v1 v2] (make-vect (+ (xcor-vect v1) (xcor-vect v2)) (+ (ycor-vect v1) (ycor-vect v2)))) 844 | (defn sub-vect [v1 v2] (make-vect (- (xcor-vect v1) (xcor-vect v2)) (- (ycor-vect v1) (ycor-vect v2)))) 845 | (defn scale-vect [v s] (make-vect (* s (xcor-vect v)) (* (ycor-vect v)))) 846 | 847 | ;; Exercise 2.47 848 | 849 | (defn make-frame [origin edge1 edge2] 850 | [origin edge1 edge2]) 851 | 852 | (defn origin-frame [f] 853 | (f 0)) 854 | 855 | (defn edge1-frame [f] 856 | (f 1)) 857 | 858 | (defn edge2-frame [f] 859 | (f 2)) 860 | 861 | (defn make-frame [origin edge1 edge2] 862 | (cons origin [edge1 edge2])) 863 | 864 | (defn origin-frame [f] 865 | (f 0)) 866 | 867 | (defn edge1-frame [f] 868 | ((f 0) 0)) 869 | 870 | (defn edge2-frame [f] 871 | ((f 0) 1)) 872 | 873 | ;; Exercise 2.48 874 | 875 | (defn make-segment [v1 v2] [v1 v2]) 876 | (defn start-segment [s] (s 0)) 877 | (defn end-segment [s] (s 1)) 878 | 879 | ;; Exercise 2.49 880 | 881 | ; The painter that draws the outline of the designated frame. 882 | (def outline-segments 883 | (list 884 | (make-segment 885 | (make-vect 0.0 0.0) 886 | (make-vect 0.0 0.99)) 887 | (make-segment 888 | (make-vect 0.0 0.0) 889 | (make-vect 0.99 0.0)) 890 | (make-segment 891 | (make-vect 0.99 0.0) 892 | (make-vect 0.99 0.99)) 893 | (make-segment 894 | (make-vect 0.0 0.99) 895 | (make-vect 0.99 0.99)))) 896 | 897 | ; The painter that draws an 'X' by connecting opposite corners of the frame. 898 | (def x-segments 899 | (list 900 | (make-segment 901 | (make-vect 0.0 0.0) 902 | (make-vect 0.99 0.99)) 903 | (make-segment 904 | (make-vect 0.0 0.99) 905 | (make-vect 0.99 0.0)))) 906 | 907 | ; The painter that draws a diamond shape by connecting the midpoints of the sides of the frame. 908 | (def diamond-segments 909 | (list 910 | (make-segment 911 | (make-vect 0.0 0.5) 912 | (make-vect 0.5 0.0)) 913 | (make-segment 914 | (make-vect 0.0 0.5) 915 | (make-vect 0.5 0.99)) 916 | (make-segment 917 | (make-vect 0.5 0.99) 918 | (make-vect 0.99 0.5)) 919 | (make-segment 920 | (make-vect 0.99 0.5) 921 | (make-vect 0.5 0.0)))) 922 | 923 | ; The wave painter. 924 | (def wave-segments 925 | (list 926 | (make-segment 927 | (make-vect 0.006 0.840) 928 | (make-vect 0.155 0.591)) 929 | (make-segment 930 | (make-vect 0.006 0.635) 931 | (make-vect 0.155 0.392)) 932 | (make-segment 933 | (make-vect 0.304 0.646) 934 | (make-vect 0.155 0.591)) 935 | (make-segment 936 | (make-vect 0.298 0.591) 937 | (make-vect 0.155 0.392)) 938 | (make-segment 939 | (make-vect 0.304 0.646) 940 | (make-vect 0.403 0.646)) 941 | (make-segment 942 | (make-vect 0.298 0.591) 943 | (make-vect 0.354 0.492)) 944 | (make-segment 945 | (make-vect 0.403 0.646) 946 | (make-vect 0.348 0.845)) 947 | (make-segment 948 | (make-vect 0.354 0.492) 949 | (make-vect 0.249 0.000)) 950 | (make-segment 951 | (make-vect 0.403 0.000) 952 | (make-vect 0.502 0.293)) 953 | (make-segment 954 | (make-vect 0.502 0.293) 955 | (make-vect 0.602 0.000)) 956 | (make-segment 957 | (make-vect 0.348 0.845) 958 | (make-vect 0.403 0.999)) 959 | (make-segment 960 | (make-vect 0.602 0.999) 961 | (make-vect 0.652 0.845)) 962 | (make-segment 963 | (make-vect 0.652 0.845) 964 | (make-vect 0.602 0.646)) 965 | (make-segment 966 | (make-vect 0.602 0.646) 967 | (make-vect 0.751 0.646)) 968 | (make-segment 969 | (make-vect 0.751 0.646) 970 | (make-vect 0.999 0.343)) 971 | (make-segment 972 | (make-vect 0.751 0.000) 973 | (make-vect 0.597 0.442)) 974 | (make-segment 975 | (make-vect 0.597 0.442) 976 | (make-vect 0.999 0.144)))) 977 | 978 | 979 | ;; Exercise 2.50 980 | 981 | (defn frame-coord-map [frame] 982 | (fn [v] 983 | (add-vect 984 | (origin-frame frame) 985 | (add-vect (scale-vect (xcor-vect v) 986 | (edge1-frame frame)) 987 | (scale-vect (ycor-vect v) 988 | (edge2-frame frame)))))) 989 | 990 | (defn transform-painter [painter origin corner1 corner2] 991 | (fn [frame] 992 | (let [m (frame-coord-map frame) new-origin (m origin)] 993 | (painter (make-frame new-origin 994 | (sub-vect (m corner1) new-origin) 995 | (sub-vect (m corner2) new-origin)))))) 996 | 997 | 998 | (defn flip-horiz [painter] 999 | ((transform-painter (make-vect 1.0 0.0) 1000 | (make-vect 0.0 0.0) 1001 | (make-vect 1.0 1.0)) 1002 | painter)) 1003 | 1004 | (defn rotate180 [painter] 1005 | ((transform-painter (make-vect 1.0 1.0) 1006 | (make-vect 0.0 1.0) 1007 | (make-vect 1.0 0.0)) 1008 | painter)) 1009 | 1010 | (defn rotate270 [painter] 1011 | ((transform-painter (make-vect 0.0 1.0) 1012 | (make-vect 0.0 0.0) 1013 | (make-vect 1.0 1.0)) 1014 | painter)) 1015 | 1016 | ;; Exercise 2.51 1017 | 1018 | (defn beside [painter1 painter2] 1019 | (let [split-point (make-vect 0.5 0.0) 1020 | paint-left (transform-painter painter1 1021 | (make-vect 0.0 0.0) 1022 | split-point 1023 | (make-vect 0.0 1.0)) 1024 | paint-right (transform-painter painter2 1025 | split-point 1026 | (make-vect 1.0 0.0) 1027 | (make-vect 0.5 1.0)) 1028 | ] 1029 | (fn [frame] 1030 | (paint-left frame) 1031 | (paint-right frame)))) 1032 | 1033 | (defn below [painter1 painter2] 1034 | (let [split-point (make-vect 0.0 0.5) 1035 | paint-bottom ((transform-painter 1036 | (make-vect 0.0 0.0) 1037 | (make-vect 1.0 0.0) 1038 | split-point) painter1) 1039 | paint-top ((transform-painter 1040 | split-point 1041 | (make-vect 1.0 0.5) 1042 | (make-vect 0.0 1.0)) painter2) 1043 | ] 1044 | (fn [frame] 1045 | (paint-bottom frame) 1046 | (paint-top frame)))) 1047 | 1048 | (defn rotate90 [painter] 1049 | ((transform-painter (make-vect 1.0 0.0) 1050 | (make-vect 1.0 1.0) 1051 | (make-vect 0.0 0.0)) 1052 | painter)) 1053 | 1054 | (defn below [painter1 painter2] 1055 | (rotate90 (beside (rotate270 painter1) (rotate270 painter2)))) 1056 | 1057 | ;; Exercise 2.52 1058 | 1059 | (def wave-segments 1060 | (list 1061 | (make-segment 1062 | (make-vect 0.006 0.840) 1063 | (make-vect 0.155 0.591)) 1064 | (make-segment 1065 | (make-vect 0.006 0.635) 1066 | (make-vect 0.155 0.392)) 1067 | (make-segment 1068 | (make-vect 0.304 0.646) 1069 | (make-vect 0.155 0.591)) 1070 | (make-segment 1071 | (make-vect 0.298 0.591) 1072 | (make-vect 0.155 0.392)) 1073 | (make-segment 1074 | (make-vect 0.304 0.646) 1075 | (make-vect 0.403 0.646)) 1076 | (make-segment 1077 | (make-vect 0.298 0.591) 1078 | (make-vect 0.354 0.492)) 1079 | (make-segment ; left face 1080 | (make-vect 0.403 0.646) 1081 | (make-vect 0.348 0.845)) 1082 | (make-segment 1083 | (make-vect 0.354 0.492) 1084 | (make-vect 0.249 0.000)) 1085 | (make-segment 1086 | (make-vect 0.403 0.000) 1087 | (make-vect 0.502 0.293)) 1088 | (make-segment 1089 | (make-vect 0.502 0.293) 1090 | (make-vect 0.602 0.000)) 1091 | (make-segment 1092 | (make-vect 0.348 0.845) 1093 | (make-vect 0.403 0.999)) 1094 | (make-segment 1095 | (make-vect 0.602 0.999) 1096 | (make-vect 0.652 0.845)) 1097 | (make-segment 1098 | (make-vect 0.652 0.845) 1099 | (make-vect 0.602 0.646)) 1100 | (make-segment 1101 | (make-vect 0.602 0.646) 1102 | (make-vect 0.751 0.646)) 1103 | (make-segment 1104 | (make-vect 0.751 0.646) 1105 | (make-vect 0.999 0.343)) 1106 | (make-segment 1107 | (make-vect 0.751 0.000) 1108 | (make-vect 0.597 0.442)) 1109 | (make-segment 1110 | (make-vect 0.597 0.442) 1111 | (make-vect 0.999 0.144)) 1112 | (make-segment ; eye 1113 | (make-vect 0.395 0.916) 1114 | (make-vect 0.410 0.916)) 1115 | (make-segment ; smile 1116 | (make-vect 0.376 0.746) 1117 | (make-vect 0.460 0.790)))) 1118 | 1119 | (defn corner-split [painter n] 1120 | (if (= n 0) 1121 | painter 1122 | (let [up (up-split painter (- n 1)) 1123 | right (right-split painter (- n 1)) 1124 | corner (corner-split painter (- n 1))] 1125 | (beside (below painter up) 1126 | (below right corner))))) 1127 | 1128 | (defn flip-vert [painter] 1129 | (transform-painter painter 1130 | (make-vect 0.0 1.0) ; new origin 1131 | (make-vect 1.0 1.0) ; new end of edge1 1132 | (make-vect 0.0 0.0))) ; new end of edge2 1133 | 1134 | (defn square-limit [painter n] 1135 | (let [quarter (rotate180 (corner-split painter n)) 1136 | half (beside (flip-horiz quarter) quarter)] 1137 | (below (flip-vert half) half))) 1138 | 1139 | 1140 | ;; Exercise 2.53 1141 | 1142 | (defn memq [item x] 1143 | (cond (empty? x) false 1144 | (= item (first x)) x 1145 | :else (memq item (rest x)))) 1146 | 1147 | (list 'a 'b 'c) 1148 | 1149 | (list (list 'george)) 1150 | 1151 | (rest '((x1 x2) (y1 y2))) 1152 | 1153 | (first '((x1 x2) (y1 y2))) 1154 | 1155 | (coll? (first '(a short list))) 1156 | 1157 | (memq 'red '((red shoes) (blue socks))) 1158 | 1159 | (memq 'red '(red shoes blue socks)) 1160 | 1161 | 1162 | ;; Exercise 2.54 1163 | 1164 | (defn equal? [a b] 1165 | (cond 1166 | (and (symbol? a) (symbol? b) (= a b)) true 1167 | (and (coll? a) (coll? b) (= (first a) (first b))) (equal? (rest a) (rest b)) 1168 | :else false)) 1169 | 1170 | ;; Exercise 2.55 1171 | 1172 | (first ''abracadabra) 1173 | 1174 | ; -> ''abracadabra yields (quote abracadabra) 1175 | 1176 | 1177 | ;; Exercise 2.55 1178 | 1179 | (defn variable? [x] (symbol? x)) 1180 | 1181 | (defn same-variable? [v1 v2] 1182 | (and (variable? v1) (variable? v2) (= v1 v2))) 1183 | 1184 | (defn make-sum [a1 a2] 1185 | (cond (= a1 0) a2 1186 | (= a2 0) a1 1187 | (and (number? a1) (number? a2)) (+ a1 a2) 1188 | :else (list '+ a1 a2))) 1189 | 1190 | (defn make-product [m1 m2] 1191 | (cond (or (= m1 0) (= m2 0)) 0 1192 | (= m1 1) m2 1193 | (= m2 1) m1 1194 | (and (number? m1) (number? m2)) (* m1 m2) 1195 | :else (list '* m1 m2))) 1196 | 1197 | (defn sum? [x] 1198 | (and (coll? x) (= (first x) '+))) 1199 | 1200 | (defn addend [s] (second s)) 1201 | 1202 | (defn augend [s] (second (rest s))) 1203 | 1204 | (defn product? [x] 1205 | (and (coll? x) (= (first x) '*))) 1206 | 1207 | (defn multiplier [p] (second p)) 1208 | 1209 | (defn multiplicand [p] (second (rest p))) 1210 | 1211 | 1212 | (defn deriv [exp var] 1213 | (cond (number? exp) 0 1214 | (variable? exp) (if (same-variable? exp var) 1 0) 1215 | (sum? exp) (make-sum (deriv (addend exp) var) 1216 | (deriv (augend exp) var)) 1217 | (product? exp) (make-sum 1218 | (make-product (multiplier exp) 1219 | (deriv (multiplicand exp) var)) 1220 | (make-product (deriv (multiplier exp) var) 1221 | (multiplicand exp))) 1222 | :else (throw (Exception. "unknown expression type -- DERIV" exp)))) 1223 | 1224 | ;; Exercise 2.56 1225 | 1226 | (defn exponentiation? [x] 1227 | (and (coll? x) (= (first x) '**))) 1228 | 1229 | (defn base [p] (second p)) 1230 | 1231 | (defn exponent [p] (second (rest p))) 1232 | 1233 | (defn make-exponentiation [b e] 1234 | (cond (= e 0) 1 1235 | (= e 1) b 1236 | (or (= b 1) (= b 0)) b 1237 | :else (list '** b e))) 1238 | 1239 | 1240 | (defn deriv [exp var] 1241 | (cond (number? exp) 0 1242 | (variable? exp) (if (same-variable? exp var) 1 0) 1243 | (sum? exp) (make-sum (deriv (addend exp) var) 1244 | (deriv (augend exp) var)) 1245 | (product? exp) (make-sum 1246 | (make-product (multiplier exp) 1247 | (deriv (multiplicand exp) var)) 1248 | (make-product (deriv (multiplier exp) var) 1249 | (multiplicand exp))) 1250 | (exponentiation? exp) (make-product 1251 | (make-product (exponent exp) 1252 | (make-exponentiation (base exp) (dec (exponent exp)))) 1253 | (deriv (base exp) var) 1254 | ) 1255 | :else (throw (Exception. "unknown expression type -- DERIV" exp)))) 1256 | 1257 | 1258 | ;; Exercise 2.57 1259 | 1260 | (defn augend [s] 1261 | (let [a (rest (drop 1 s))] 1262 | (if (= 1 (count a)) a 1263 | (cons '+ a)))) 1264 | 1265 | (defn multiplicand [s] 1266 | (let [m (rest (drop 1 s))] 1267 | (if (= 1 (count m)) m 1268 | (cons '* m)))) 1269 | 1270 | ;; Exercise 2.58 1271 | 1272 | (defn make-sum [a1 a2] 1273 | (cond (= a1 0) a2 1274 | (= a2 0) a1 1275 | (and (number? a1) (number? a2)) (+ a1 a2) 1276 | :else (list a1 '+ a2))) 1277 | 1278 | (defn make-product [m1 m2] 1279 | (cond (or (= m1 0) (= m2 0)) 0 1280 | (= m1 1) m2 1281 | (= m2 1) m1 1282 | (and (number? m1) (number? m2)) (* m1 m2) 1283 | :else (list m1 '* m2))) 1284 | 1285 | (defn sum? [x] 1286 | (and (coll? x) (= (second x) '+))) 1287 | 1288 | (defn addend [s] (first s)) 1289 | 1290 | (defn augend [s] (second (rest s))) 1291 | 1292 | (defn product? [x] 1293 | (and (coll? x) (= (second x) '*))) 1294 | 1295 | (defn multiplier [p] (first p)) 1296 | 1297 | (defn multiplicand [p] (second (rest p))) 1298 | 1299 | (defn exponentiation? [x] 1300 | (and (coll? x) (= (second x) '**))) 1301 | 1302 | (defn base [p] (first p)) 1303 | 1304 | (defn exponent [p] (second (rest p))) 1305 | 1306 | (defn make-exponentiation [b e] 1307 | (cond (= e 0) 1 1308 | (= e 1) b 1309 | (or (= b 1) (= b 0)) b 1310 | :else (list b '** e))) 1311 | 1312 | ; b) 1313 | 1314 | 1315 | (defn sum? [x] (check-symbol '+ x)) 1316 | 1317 | (defn addend [s] (left '+ s)) 1318 | 1319 | (defn augend [s] (right '+ s)) 1320 | 1321 | (defn product? [x] (check-symbol '* x)) 1322 | 1323 | (defn multiplier [p] (left '* p)) 1324 | 1325 | (defn multiplicand [p] (right '* p)) 1326 | 1327 | (defn exponentiation? [x] (check-symbol '** x)) 1328 | 1329 | (defn base [e] (left '** e)) 1330 | 1331 | (defn exponent [e] (right '** e)) 1332 | 1333 | (defn check-symbol [s x] (and (coll? x) (memq s x))) 1334 | 1335 | (defn left [s x] 1336 | (let [exp (take-while #(not= % s) x)] 1337 | (if (= 1 (count exp)) (first exp) exp))) 1338 | 1339 | (defn right [s x] 1340 | (let [exp (rest (memq s x))] 1341 | (if (= 1 (count exp)) (first exp) exp))) 1342 | 1343 | (defn make-sum [a1 a2] 1344 | (cond (= a1 0) a2 1345 | (= a2 0) a1 1346 | (and (number? a1) (number? a2)) (+ a1 a2) 1347 | (and (coll? a1) (coll? a2)) (concat a1 '(+) a2) 1348 | (coll? a1) (concat a1 ['+ a2]) 1349 | (coll? a2) (concat [a1 '+] a2) 1350 | :else (list a1 '+ a2))) 1351 | 1352 | (defn make-product [m1 m2] 1353 | (cond (or (= m1 0) (= m2 0)) 0 1354 | (= m1 1) m2 1355 | (= m2 1) m1 1356 | (and (number? m1) (number? m2)) (* m1 m2) 1357 | (and (coll? m1) (coll? m2) (not (sum? m1)) (not (sum? m2))) (concat m1 '(*) m2) 1358 | (and (coll? m1) (not (sum? m1))) (concat m1 ['* m2]) 1359 | (and (coll? m2) (not (sum? m2))) (concat [m1 '*] m2) 1360 | :else (list m1 '* m2))) 1361 | 1362 | (defn make-exponentiation [b e] 1363 | (cond (= e 0) 1 1364 | (= e 1) b 1365 | (or (= b 1) (= b 0)) b 1366 | (and (number? b) (number? e)) (* b e) 1367 | :else (list b '** e))) 1368 | 1369 | 1370 | ;; Exercise 2.59 1371 | 1372 | (defn element-of-set? [x set] 1373 | (cond (empty? set) false 1374 | (= x (first set)) true 1375 | :else (element-of-set? x (rest set)))) 1376 | 1377 | (defn adjoin-set [x set] 1378 | (if (element-of-set? x set) 1379 | set 1380 | (cons x set))) 1381 | 1382 | (defn intersection-set [set1 set2] 1383 | (cond (or (empty? set1) (empty? set2)) '() 1384 | (element-of-set? (first set1) set2) (cons (first set1) 1385 | (intersection-set (rest set1) set2)) 1386 | :else (intersection-set (rest set1) set2))) 1387 | 1388 | (defn union-set [set1 set2] 1389 | (cond 1390 | (empty? set1) set2 1391 | (element-of-set? (first set1) set2) (union-set (rest set1) set2) 1392 | :else (union-set (rest set1) (cons (first set1) set2)))) 1393 | 1394 | ;; Exercise 2.60 1395 | 1396 | (defn element-of-set? [x set] 1397 | (cond (empty? set) false 1398 | (= x (first set)) true 1399 | :else (element-of-set? x (rest set)))) 1400 | 1401 | (defn adjoin-set [x set] (cons x set)) 1402 | 1403 | (defn intersection-set [set1 set2] 1404 | (cond (or (empty? set1) (empty? set2)) '() 1405 | (element-of-set? (first set1) set2) (cons (first set1) 1406 | (intersection-set (rest set1) set2)) 1407 | :else (intersection-set (rest set1) set2))) 1408 | 1409 | (defn union-set [set1 set2] (concat set1 set2)) 1410 | 1411 | ;; Exercise 2.61 1412 | 1413 | (defn element-of-set? [x set] 1414 | (cond (empty? set) false 1415 | (= x (first set)) true 1416 | (< x (first set)) false 1417 | :else (element-of-set? x (rest set)))) 1418 | 1419 | 1420 | (defn intersection-set [set1 set2] 1421 | (if (or (empty? set1) (empty? set2)) [] 1422 | (let [x1 (first set1) x2 (first set2)] 1423 | (cond (= x1 x2) (cons x1 (intersection-set (rest set1) 1424 | (rest set2))) 1425 | (< x1 x2) (intersection-set (rest set1) set2) 1426 | (< x2 x1) (intersection-set set1 (rest set2)))))) 1427 | 1428 | (defn adjoin-set [x set] 1429 | (cond 1430 | (empty? set) (cons x set) 1431 | (= x (first set)) set 1432 | (< x (first set)) (cons x set) 1433 | :else (cons (first set) (adjoin-set x (rest set))))) 1434 | 1435 | ;; Exercise 2.62 1436 | 1437 | (defn union-set [set1 set2] 1438 | (cond 1439 | (empty? set1) set2 1440 | (empty? set2) set1 1441 | :else (let [x1 (first set1) x2 (first set2)] 1442 | (cond (= x1 x2) (cons x1 (union-set (rest set1) (rest set2))) 1443 | (< x1 x2) (cons x1 (union-set (rest set1) set2)) 1444 | (< x2 x1) (cons x2 (union-set set1 (rest set2))))))) 1445 | 1446 | ;; Exercise 2.63 1447 | 1448 | (defn entry [tree] (tree 0)) 1449 | (defn left-branch [tree] (tree 1)) 1450 | (defn right-branch [tree] (tree 2)) 1451 | (defn make-tree [entry left right] [entry left right]) 1452 | 1453 | (defn element-of-set? [x set] 1454 | (cond (empty? set) false 1455 | (= x (entry set)) true 1456 | (< x (entry set)) (element-of-set? x (left-branch set)) 1457 | (> x (entry set)) (element-of-set? x (right-branch set)))) 1458 | 1459 | (defn adjoin-set [x set] 1460 | (cond (empty? set) (make-tree x [] []) 1461 | (= x (entry set)) set 1462 | (< x (entry set)) (make-tree (entry set) 1463 | (adjoin-set x (left-branch set)) 1464 | (right-branch set)) 1465 | (> x (entry set)) (make-tree (entry set) 1466 | (left-branch set) 1467 | (adjoin-set x (right-branch set))))) 1468 | 1469 | (defn tree->list-1 [tree] 1470 | (if (empty? tree) [] 1471 | (concat (tree->list-1 (left-branch tree)) 1472 | (cons (entry tree) 1473 | (tree->list-1 (right-branch tree)))))) 1474 | 1475 | (defn tree->list-2 [tree] 1476 | (defn copy-to-list [tree result-list] 1477 | (if (empty? tree) result-list 1478 | (copy-to-list (left-branch tree) 1479 | (cons (entry tree) 1480 | (copy-to-list (right-branch tree) 1481 | result-list))))) 1482 | (copy-to-list tree [])) 1483 | 1484 | 1485 | (def tree1 [7 [3 [1 [] []] [5 [] []]] [9 [] [11 [] []]]]) 1486 | 1487 | (tree->list-1 tree1) 1488 | 1489 | (tree->list-2 tree1) 1490 | 1491 | (def tree2 [3 [1 [] []] [7 [5 [] []] [9 [] [11 [] []]]]]) 1492 | 1493 | (tree->list-1 tree2) 1494 | 1495 | (tree->list-2 tree2) 1496 | 1497 | (def tree3 [5 [3 [1 [] []] []] [9 [7 [] []] [11 [] []]]]) 1498 | 1499 | (tree->list-1 tree3) 1500 | 1501 | (tree->list-2 tree3) 1502 | 1503 | ; In tree->list-1 concat is called on every recursive called 1504 | ; Append is O(length) and the length is halves on each call so log n 1505 | ; Total complexity tree->list-1 O(n logn) while tree->list-2 is just O(n) 1506 | 1507 | ;; Exercise 2.64 1508 | 1509 | (defn list->tree [elements] 1510 | (first (partial-tree elements (count elements)))) 1511 | 1512 | (defn partial-tree [elts n] 1513 | (if (= n 0) ([[] elts]) 1514 | (let [left-size (quot (dec n) 2) 1515 | left-result (partial-tree elts left-size) 1516 | left-tree (first left-result) 1517 | non-left-elts (second left-result) 1518 | right-size (- n (inc left-size)) 1519 | this-entry (first non-left-elts) 1520 | right-result (partial-tree (rest non-left-elts) right-size) 1521 | right-tree (first right-result) 1522 | remaining-elts (second right-result) 1523 | ] 1524 | [(make-tree this-entry left-tree right-tree) remaining-elts]))) 1525 | 1526 | ; The important bit is to substract 1 in the calculation of left and right size so you can extract this-entry 1527 | ; There is one recursive call for each element in the list with no expensive operands like concat so O(n) 1528 | 1529 | ;; Exercise 2.65 1530 | 1531 | ; Just use tree->list2 on the sets, feed them to the functions 2.61 2.62 and reconvert them back with list->tree 1532 | 1533 | ;; Exercise 2.66 1534 | 1535 | (defn lookup [given-key set-of-records] 1536 | (cond 1537 | (empty? set-of-records) false 1538 | (= given-key (key (entry set-of-records))) (entry set-of-records) 1539 | (< given-key (key (entry set-of-records))) (lookup given-key (left-branch set-of-records)) 1540 | (> given-key (key (entry set-of-records))) (lookup given-key (right-branch set-of-records)))) 1541 | 1542 | ;; Exercise 2.67 1543 | 1544 | (defn make-leaf [symbol weight] ['leaf symbol weight]) 1545 | (defn leaf? [object] (= (object 0) 'leaf)) 1546 | (defn symbol-leaf [x] (x 1)) 1547 | (defn weight-leaf [x] (x 2)) 1548 | 1549 | (defn make-code-tree [left right] 1550 | [left right (concat (symbols left) (symbols right)) (+ (weight left) (weight right))]) 1551 | (defn left-branch [tree] (tree 0)) 1552 | (defn right-branch [tree] (tree 1)) 1553 | (defn symbols [tree] 1554 | (if (leaf? tree) 1555 | [(symbol-leaf tree)] 1556 | (tree 2))) 1557 | (defn weight [tree] 1558 | (if (leaf? tree) 1559 | (weight-leaf tree) 1560 | (tree 3))) 1561 | 1562 | (defn decode [bits tree] 1563 | (defn decode-1 [bits current-branch] 1564 | (if (empty? bits) [] 1565 | (let [next-branch (choose-branch (first bits) current-branch)] 1566 | (if (leaf? next-branch) 1567 | (cons (symbol-leaf next-branch) 1568 | (decode-1 (rest bits) tree)) 1569 | (decode-1 (rest bits) next-branch))))) 1570 | (decode-1 bits tree)) 1571 | 1572 | (defn choose-branch [bit branch] 1573 | (cond (= bit 0) (left-branch branch) 1574 | (= bit 1) (right-branch branch))) 1575 | 1576 | (defn adjoin-set [x set] 1577 | (cond 1578 | (empty? set) [x] 1579 | (< (weight x) (weight (first set))) (cons x set) 1580 | :else (cons (first set) (adjoin-set x (rest set))))) 1581 | 1582 | (defn make-leaf-set [pairs] 1583 | (if (empty? pairs) [] 1584 | (let [pair (first pairs)] 1585 | (adjoin-set (make-leaf (first pair) ; symbol 1586 | (second pair)) ; frequency 1587 | (make-leaf-set (rest pairs)))))) 1588 | 1589 | (def sample-tree 1590 | (make-code-tree (make-leaf 'A 4) 1591 | (make-code-tree 1592 | (make-leaf 'B 2) 1593 | (make-code-tree (make-leaf 'D 1) 1594 | (make-leaf 'C 1))))) 1595 | 1596 | (def sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) 1597 | 1598 | (decode sample-message sample-tree) 1599 | 1600 | ;; Exercise 2.68 1601 | 1602 | (defn encode [message tree] 1603 | (if (empty? message) [] 1604 | (concat (encode-symbol (first message) tree) 1605 | (encode (rest message) tree)))) 1606 | 1607 | (defn encode-symbol [symbol tree] 1608 | (defn in-branch? [branch] 1609 | (if (leaf? branch) 1610 | (= symbol (symbol-leaf branch)) 1611 | (memq symbol (symbols branch)))) 1612 | (let [lb (left-branch tree) 1613 | rb (right-branch tree)] 1614 | (cond (in-branch? lb) (if (leaf? lb) [0] (cons 0 (encode-symbol symbol lb))) 1615 | (in-branch? rb) (if (leaf? rb) [1] (cons 1 (encode-symbol symbol rb))) 1616 | :else (throw (RuntimeException. (str "Can't encode symbol " symbol)))))) 1617 | 1618 | 1619 | (encode '(A D A B B C A) sample-tree) 1620 | 1621 | ;; Exercise 2.69 1622 | 1623 | (defn generate-huffman-tree [pairs] 1624 | (successive-merge (make-leaf-set pairs))) 1625 | 1626 | (defn successive-merge [trees] 1627 | (if (= 1 (count trees)) 1628 | (first trees) 1629 | (let [a (first trees) 1630 | b (second trees) 1631 | remainder (drop 2 trees) 1632 | new-tree (make-code-tree a b) 1633 | new-trees (adjoin-set new-tree remainder)] 1634 | (successive-merge new-trees)))) 1635 | 1636 | (generate-huffman-tree #{'(A 8) '(B 3) '(C 1) '(D 1) '(E 1) '(F 1) '(G 1) '(H 1)}) 1637 | 1638 | ;; Exercise 2.70 1639 | 1640 | (def rock-tree (generate-huffman-tree #{'(a 2) '(boom 1) '(Get 2) '(job 2) '(na 16) '(Sha 3) '(yip 9) '(Wah 1)})) 1641 | 1642 | (def rock-lyric '(Get a job 1643 | Sha na na na na na na na na 1644 | Get a job 1645 | Sha na na na na na na na na 1646 | Wah yip yip yip yip yip yip yip yip yip 1647 | Sha boom)) 1648 | 1649 | (def encoded-lyric (encode rock-lyric rock-tree)) 1650 | 1651 | (< (count encoded-lyric) (* 3 (count rock-lyric))) 1652 | 1653 | ;; Exercise 2.71 1654 | 1655 | ; Such tree always has a leaf on its left branch so the most frequent symbol is encoded with 1 bit and the least frequent with (n - 1) bits 1656 | 1657 | 1658 | ;; Exercise 2.72 1659 | 1660 | ; In a normal tree the complexity is O(n log n) 1661 | ; In a skewed tree the complexity is O(n) for the most frequent and O(n^2) for the least frequent 1662 | ; If a tree doesn't need to be modified we can store all the symbols in a map with their encodings for maximum performance 1663 | 1664 | 1665 | ;; Exercise 2.73 1666 | 1667 | ; a) Because they have no type tag on their data structure. We could in principle but we have to change their representation. 1668 | 1669 | ; b) 1670 | 1671 | (defn addend [s] (first s)) 1672 | 1673 | (defn augend [s] (second s)) 1674 | 1675 | (defn multiplier [p] (first p)) 1676 | 1677 | (defn multiplicand [p] (second p)) 1678 | 1679 | (defn operator [exp] (first exp)) 1680 | 1681 | (defn operands [exp] (rest exp)) 1682 | 1683 | (defn deriv [exp var] 1684 | (cond 1685 | (number? exp) 0 1686 | (variable? exp) (if (same-variable? exp var) 1 0) 1687 | :else ((pt-get 'deriv (operator exp)) (operands exp) 1688 | var))) 1689 | 1690 | (defn deriv-sum [exp var] 1691 | (make-sum (deriv (addend exp) var) 1692 | (deriv (augend exp) var))) 1693 | 1694 | (defn deriv-product [exp var] 1695 | (make-sum (make-product (multiplier exp) 1696 | (deriv (multiplicand exp) var)) 1697 | (make-product (deriv (multiplier exp) var) 1698 | (multiplicand exp)))) 1699 | 1700 | (def proc-table (atom {})) 1701 | 1702 | (defn pt-get [op type] (@proc-table [op type])) 1703 | 1704 | (defn pt-put [op type item] (swap! proc-table #(assoc % [op type] item))) 1705 | 1706 | (defn install-deriv [] 1707 | (pt-put 'deriv '+ deriv-sum) 1708 | (pt-put 'deriv '* deriv-product)) 1709 | 1710 | (install-deriv) 1711 | 1712 | (deriv '(* (+ x y) 3) 'x) 1713 | 1714 | ; c) 1715 | 1716 | (defn base [e] (first e)) 1717 | 1718 | (defn exponent [e] (second e)) 1719 | 1720 | 1721 | (defn deriv-exponentiation [expr var] 1722 | (let [base (base expr) 1723 | exponent (exponent expr)] 1724 | (make-product exponent 1725 | (make-product (make-exponentiation base (make-sum exponent -1)) 1726 | (deriv base var))))) 1727 | 1728 | (defn install-deriv [] 1729 | (pt-put 'deriv '+ deriv-sum) 1730 | (pt-put 'deriv '* deriv-product) 1731 | (pt-put 'deriv '** deriv-exponentiation)) 1732 | 1733 | (install-deriv) 1734 | 1735 | (deriv '(** (+ x y) 3) 'x) 1736 | 1737 | ; d) We only need to change the way we save them 1738 | 1739 | ;; Exercise 2.74 1740 | 1741 | ; a) 1742 | 1743 | (defn make-hq-file [division file] 1744 | (cons division file)) 1745 | (defn file-division [hq-file] 1746 | (first hq-file)) 1747 | (defn original-file [hq-file] 1748 | (second hq-file)) 1749 | 1750 | (defn get-record [employee hq-file] 1751 | (let [get-record-fn (pt-get 'get-record (file-division hq-file))] 1752 | (get-record-fn employee (original-file hq-file)))) 1753 | 1754 | (defn has-record? [employee division] 1755 | (let [has-record?-fn (pt-get 'has-record? division)] 1756 | (has-record?-fn employee))) 1757 | 1758 | ; b) 1759 | 1760 | (defn make-hq-record [division record] 1761 | (cons division record)) 1762 | (defn record-division [hq-record] 1763 | (first hq-record)) 1764 | (defn original-record [hq-record] 1765 | (second hq-record)) 1766 | 1767 | (defn get-salary [hq-file] 1768 | (let [get-salary-fn (pt-get 'get-salary (file-division hq-file))] 1769 | (get-salary-fn (original-record hq-file)))) 1770 | 1771 | ; c) 1772 | 1773 | (defn find-employee-record [employee files] 1774 | (cond 1775 | (empty? files) (throw (RuntimeException. (str "FIND-EMPLOYEE-RECORD : No such employee." employee))) 1776 | (has-record? employee (file-division (first files))) (get-record employee (first files)) 1777 | :else (find-employee-record employee (rest files)))) 1778 | 1779 | ; d) 1780 | 1781 | (defn install-ultra-mega-corp [table] 1782 | (assoc table 'get-record :ultra-mega-corp-get-record) 1783 | (assoc table 'has-record? :ultra-mega-corp-has-record?) 1784 | (assoc table 'get-salary :ultra-mega-corp-get-salary)) 1785 | 1786 | ;; Exercise 2.75 1787 | 1788 | (defn apply-generic [op arg] (arg op)) 1789 | 1790 | (defn make-from-mag-ang [m a] 1791 | (defn dispatch [op] 1792 | (cond 1793 | (= op 'real-part) (* m (Math/cos a)) 1794 | (= op 'imag-part) (* m (Math/sin a)) 1795 | (= op 'magnitude) m 1796 | (= op 'angle) a 1797 | :else (throw (RuntimeException. (str "Unknown op -- MAKE-FROM-REAL-IMAG" op))))) 1798 | dispatch) 1799 | 1800 | ;; Exercise 2.76 1801 | 1802 | ; Lots of new types -> message passing (which is basically OO) 1803 | ; Lots of new operations -> data-directed style 1804 | 1805 | ;; Exercise 2.77 1806 | 1807 | (def proc-table (atom {})) 1808 | 1809 | (defn pt-get [op type] (@proc-table [op type])) 1810 | 1811 | (defn pt-put [op type item] (swap! proc-table #(assoc % [op type] item))) 1812 | 1813 | (defn type-tag [datum] 1814 | (cond (number? datum) datum 1815 | (coll? datum) (first datum) 1816 | :else (throw (RuntimeException. (str "Wrong datum -- TYPE-TAG " datum))))) 1817 | 1818 | (defn contents [datum] 1819 | (cond (number? datum) datum 1820 | (coll? datum) (rest datum) 1821 | :else (throw (RuntimeException. (str "Wrong datum -- CONTENGS " datum))))) 1822 | 1823 | (defn attach-tag [tag content] 1824 | (if (coll? content) (cons tag content) content)) 1825 | 1826 | (defn gcd [a b] 1827 | (if (= b 0) 1828 | a 1829 | (gcd b (rem a b)))) 1830 | 1831 | ;;; 2.77 1832 | 1833 | (defn install-rectangular-package [] 1834 | (let [real-part (fn [z] (first z)) 1835 | imag-part (fn [z] (second z)) 1836 | make-from-real-imag (fn [x y] [x y]) 1837 | magnitude (fn [z] 1838 | (Math/sqrt (+ (#(* % %) (real-part z)) 1839 | (#(* % %) (imag-part z))))) 1840 | angle (fn [z] 1841 | (Math/atan2 (imag-part z) (real-part z))) 1842 | make-from-mag-ang (fn [r a] 1843 | [(* r (Math/cos a)) 1844 | (* r (Math/sin a))]) 1845 | tag (fn [x] (attach-tag 'rectangular x))] 1846 | 1847 | (pt-put 'real-part '(rectangular) real-part) 1848 | (pt-put 'imag-part '(rectangular) imag-part) 1849 | (pt-put 'magnitude '(rectangular) magnitude) 1850 | (pt-put 'angle '(rectangular) angle) 1851 | (pt-put 'make-from-real-imag 'rectangular 1852 | (fn [x y] (tag (make-from-real-imag x y)))) 1853 | (pt-put 'make-from-mag-ang 'rectangular 1854 | (fn [r a] (tag (make-from-mag-ang r a)))))) 1855 | 1856 | (defn install-polar-package [] 1857 | (let [magnitude (fn [z] (first z)) 1858 | angle (fn [z] (second z)) 1859 | make-from-mag-ang (fn [r a] [r a]) 1860 | real-part (fn [z] 1861 | (* (magnitude z) (Math/cos (angle z)))) 1862 | imag-part (fn [z] 1863 | (* (magnitude z) (Math/sin (angle z)))) 1864 | make-from-real-imag (fn [x y] 1865 | [(Math/sqrt (+ (#(* % %) x) (#(* % %) y))) 1866 | (Math/atan2 y x)]) 1867 | tag (fn [x] (attach-tag 'polar x))] 1868 | 1869 | 1870 | (pt-put 'real-part '(polar) real-part) 1871 | (pt-put 'imag-part '(polar) imag-part) 1872 | (pt-put 'magnitude '(polar) magnitude) 1873 | (pt-put 'angle '(polar) angle) 1874 | (pt-put 'make-from-real-imag 'polar 1875 | (fn [x y] (tag (make-from-real-imag x y)))) 1876 | (pt-put 'make-from-mag-ang 'polar 1877 | (fn [r a] (tag (make-from-mag-ang r a)))))) 1878 | 1879 | 1880 | (defn apply-generic [op & args] 1881 | (let [type-tags (map type-tag args) 1882 | proc (pt-get op type-tags)] 1883 | (if proc 1884 | (apply proc (map contents args)) 1885 | (throw (RuntimeException. (str "No method for -- " op type-tags)))))) 1886 | 1887 | 1888 | (defn real-part [z] (apply-generic 'real-part z)) 1889 | (defn imag-part [z] (apply-generic 'imag-part z)) 1890 | (defn magnitude [z] (apply-generic 'magnitude z)) 1891 | (defn angle [z] (apply-generic 'angle z)) 1892 | 1893 | (defn add [x y] (apply-generic 'add x y)) 1894 | (defn sub [x y] (apply-generic 'sub x y)) 1895 | (defn mul [x y] (apply-generic 'mul x y)) 1896 | (defn div [x y] (apply-generic 'div x y)) 1897 | 1898 | (defn install-scheme-number-package [] 1899 | (let [tag (fn [x] 1900 | (attach-tag 'scheme-number x))] 1901 | 1902 | (pt-put 'add '(scheme-number scheme-number) 1903 | (fn [x y] (tag (+ x y)))) 1904 | (pt-put 'sub '(scheme-number scheme-number) 1905 | (fn [x y] (tag (- x y)))) 1906 | (pt-put 'mul '(scheme-number scheme-number) 1907 | (fn [x y] (tag (* x y)))) 1908 | (pt-put 'div '(scheme-number scheme-number) 1909 | (fn [x y] (tag (/ x y)))) 1910 | (pt-put 'make 'scheme-number 1911 | (fn [x] (tag x))))) 1912 | 1913 | (defn make-scheme-number [n] 1914 | ((pt-get 'make 'scheme-number) n)) 1915 | 1916 | (defn install-rational-package [] 1917 | 1918 | (let [numer (fn [x] (first x)) 1919 | denom (fn [x] (second x)) 1920 | make-rat (fn [n d] (let [g (gcd n d)] [(/ n g) (/ d g)])) 1921 | add-rat (fn [x y] 1922 | (make-rat (+ (* (numer x) (denom y)) 1923 | (* (numer y) (denom x))) 1924 | (* (denom x) (denom y)))) 1925 | sub-rat (fn [x y] 1926 | (make-rat (- (* (numer x) (denom y)) 1927 | (* (numer y) (denom x))) 1928 | (* (denom x) (denom y)))) 1929 | mul-rat (fn [x y] 1930 | (make-rat (* (numer x) (numer y)) 1931 | (* (denom x) (denom y)))) 1932 | div-rat (fn [x y] 1933 | (make-rat (* (numer x) (denom y)) 1934 | (* (denom x) (numer y)))) 1935 | tag (fn [x] (attach-tag 'rational x)) 1936 | ] 1937 | 1938 | (pt-put 'add '(rational rational) 1939 | (fn [x y] (tag (add-rat x y)))) 1940 | (pt-put 'sub '(rational rational) 1941 | (fn [x y] (tag (sub-rat x y)))) 1942 | (pt-put 'mul '(rational rational) 1943 | (fn [x y] (tag (mul-rat x y)))) 1944 | (pt-put 'div '(rational rational) 1945 | (fn [x y] (tag (div-rat x y)))) 1946 | (pt-put 'make 'rational 1947 | (fn [n d] (tag (make-rat n d)))))) 1948 | 1949 | (defn make-rational [n d] 1950 | ((pt-get 'make 'rational) n d)) 1951 | 1952 | 1953 | (defn install-complex-package [] 1954 | (let [;; imported procedures from rectangular and polar packages 1955 | make-from-real-imag (fn [x y] 1956 | ((pt-get 'make-from-real-imag 'rectangular) x y)) 1957 | make-from-mag-ang (fn [r a] 1958 | ((pt-get 'make-from-mag-ang 'polar) r a)) 1959 | add-complex (fn [z1 z2] 1960 | (make-from-real-imag (+ (real-part z1) (real-part z2)) 1961 | (+ (imag-part z1) (imag-part z2)))) 1962 | sub-complex (fn [z1 z2] 1963 | (make-from-real-imag (- (real-part z1) (real-part z2)) 1964 | (- (imag-part z1) (imag-part z2)))) 1965 | mul-complex (fn [z1 z2] 1966 | (make-from-mag-ang (* (magnitude z1) (magnitude z2)) 1967 | (+ (angle z1) (angle z2)))) 1968 | div-complex (fn [z1 z2] 1969 | (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) 1970 | (- (angle z1) (angle z2)))) 1971 | tag (fn [z] (attach-tag 'complex z)) 1972 | ] 1973 | (pt-put 'add '(complex complex) 1974 | (fn [z1 z2] (tag (add-complex z1 z2)))) 1975 | (pt-put 'sub '(complex complex) 1976 | (fn [z1 z2] (tag (sub-complex z1 z2)))) 1977 | (pt-put 'mul '(complex complex) 1978 | (fn [z1 z2] (tag (mul-complex z1 z2)))) 1979 | (pt-put 'div '(complex complex) 1980 | (fn [z1 z2] (tag (div-complex z1 z2)))) 1981 | (pt-put 'make-from-real-imag 'complex 1982 | (fn [x y] (tag (make-from-real-imag x y)))) 1983 | (pt-put 'make-from-mag-ang 'complex 1984 | (fn [r a] (tag (make-from-mag-ang r a)))))) 1985 | 1986 | (install-rectangular-package) 1987 | (install-polar-package) 1988 | (install-scheme-number-package) 1989 | (install-rational-package) 1990 | (install-complex-package) 1991 | 1992 | (defn make-complex-from-real-imag [x y] 1993 | ((pt-get 'make-from-real-imag 'complex) x y)) 1994 | (defn make-complex-from-mag-ang [r a] 1995 | ((pt-get 'make-from-mag-ang 'complex) r a)) 1996 | 1997 | (def z (make-complex-from-mag-ang 8 6)) 1998 | 1999 | ; This fails 2000 | (magnitude z) 2001 | 2002 | (pt-put 'real-part '(complex) real-part) 2003 | (pt-put 'imag-part '(complex) imag-part) 2004 | (pt-put 'magnitude '(complex) magnitude) 2005 | (pt-put 'angle '(complex) angle) 2006 | 2007 | (magnitude z) 2008 | 2009 | 2010 | ; apply-generic is invoked twice, first dispatch is magnitude of 'complex, second is magnitude of 'rectangular. 2011 | 2012 | ;; Exercise 2.78 2013 | 2014 | (defn type-tag [datum] 2015 | (cond (number? datum) 'scheme-number 2016 | (coll? datum) (first datum) 2017 | :else (throw (RuntimeException. (str "Wrong datum -- TYPE-TAG" datum))))) 2018 | 2019 | (defn contents [datum] 2020 | (cond (number? datum) datum 2021 | (coll? datum) (rest datum) 2022 | :else (throw (RuntimeException. (str "Wrong datum -- CONTENGS" datum))))) 2023 | 2024 | (defn attach-tag [tag content] 2025 | (if (coll? content) (cons tag content) content)) 2026 | 2027 | ;; Exercise 2.79 2028 | 2029 | (defn install-scheme-number-package [] 2030 | (let [equ? =]) 2031 | ; ... put 2032 | ) 2033 | 2034 | (defn install-rational-package [] 2035 | (let [equ? (fn [x y] 2036 | (= (* (numer x) (denom y)) (* (numer y) (denom x))))]) 2037 | ;; ... put 2038 | ) 2039 | 2040 | (defn install-complex-package [] 2041 | ;; ... 2042 | (let [equ? (fn [x y] 2043 | (and (= (real-part x) (real-part y)) (= (imag-part x) (imag-part y))))]) 2044 | ;; ... put 2045 | ) 2046 | 2047 | (defn equ? [x y] (apply-generic 'equ? x y)) 2048 | 2049 | ;; Exercise 2.80 2050 | 2051 | (defn =zero? [x] (apply-generic '=zero? x)) 2052 | 2053 | (pt-put '=zero? 'scheme-number (fn [x] (= x 0))) 2054 | 2055 | (pt-put '=zero? 'rational-number (fn [x] (= (numer x) 0))) 2056 | 2057 | (pt-put '=zero? 'complex-number (fn [x] (= (real-part x) (imag-part x) 0))) 2058 | 2059 | ;; Exercise 2.81 2060 | 2061 | ;;a 2062 | ; apply-generic will go into infinite recursion. 2063 | 2064 | ;;b 2065 | ; apply-generic just works as it is. 2066 | 2067 | ;;c 2068 | 2069 | (defn put-coercion [source-type target-type proc] 2070 | (pt-put 'coercion [source-type target-type] proc)) 2071 | 2072 | (defn get-coercion [source-type target-type] 2073 | (pt-get 'coercion [source-type target-type])) 2074 | 2075 | (defn scheme-number->complex [n] 2076 | (make-complex-from-real-imag (contents n) 0)) 2077 | 2078 | (put-coercion 'scheme-number 'complex scheme-number->complex) 2079 | 2080 | (defn apply-generic [op & args] 2081 | (defn no-method [type-tags] 2082 | (throw (RuntimeException. (str "No method for -- " op " -- " type-tags)))) 2083 | 2084 | (let [type-tags (map type-tag args) 2085 | proc (pt-get op type-tags)] 2086 | (if proc 2087 | (apply proc (map contents args)) 2088 | (if (= (count args) 2) 2089 | (let [type1 (first type-tags) 2090 | type2 (second type-tags) 2091 | a1 (first args) 2092 | a2 (second args)] 2093 | (if (= type1 type2) 2094 | (no-method type-tags) 2095 | (let [t1->t2 (get-coercion type1 type2) 2096 | t2->t1 (get-coercion type2 type1)] 2097 | (cond 2098 | t1->t2 (apply-generic op (t1->t2 a1) a2) 2099 | t2->t1 (apply-generic op a1 (t2->t1 a2)) 2100 | :else (no-method type-tags))))) 2101 | (no-method type-tags))))) 2102 | 2103 | (add (make-rational 1 2) (make-rational 3 4)) 2104 | 2105 | (add (make-scheme-number 2) (make-complex-from-real-imag 3 4)) 2106 | 2107 | ;; Exercise 2.82 2108 | 2109 | (defn add [& args] (apply apply-generic 'add args)) 2110 | (pt-put 'add '(scheme-number scheme-number scheme-number) str) 2111 | (pt-put 'add '(complex complex complex) str) 2112 | 2113 | (defn apply-generic [op & args] 2114 | ; coercing list to a type 2115 | (defn coerce-list-to-type [lst type] 2116 | (if (empty? lst) [] 2117 | (let [t1->t2 (get-coercion (type-tag (first lst)) type)] 2118 | (if t1->t2 2119 | (cons (t1->t2 (first lst)) (coerce-list-to-type (rest lst) type)) 2120 | (cons (first lst) (coerce-list-to-type (rest lst) type)))))) 2121 | 2122 | ; applying to a list of multiple arguments 2123 | (defn apply-coerced [lst] 2124 | (if (empty? lst) 2125 | (throw (RuntimeException. (str "No method for -- " op " - " args))) 2126 | (let [coerced-list (coerce-list-to-type args (type-tag (first lst))) 2127 | proc (pt-get op (map type-tag coerced-list))] 2128 | (if proc 2129 | (apply proc (map contents coerced-list)) 2130 | (apply-coerced (rest lst)))))) 2131 | 2132 | ; logic to prevent always coercing if there is already direct input entry 2133 | (let [type-tags (map type-tag args) 2134 | proc (pt-get op type-tags)] 2135 | (if proc 2136 | (apply proc (map contents args)) 2137 | (apply-coerced args)))) 2138 | 2139 | (add (make-scheme-number 2) (make-scheme-number 2) (make-scheme-number 2)) 2140 | (add (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4)) 2141 | (add (make-scheme-number 2) (make-complex-from-real-imag 3 4) (make-scheme-number 2)) 2142 | 2143 | ; Problems 2144 | ; a) It fails for operations defined for mixed types. 2145 | ; b) It fails for operations defined on types that are not present in the argument list. 2146 | 2147 | ;; Exercise 2.83 2148 | 2149 | ; number -> rational -> complex 2150 | 2151 | (defn raise [x] (apply-generic 'raise x)) 2152 | 2153 | (defn install-scheme-number-package [] 2154 | (let [tag (fn [x] 2155 | (attach-tag 'scheme-number x))] 2156 | 2157 | (pt-put 'add '(scheme-number scheme-number) 2158 | (fn [x y] (tag (+ x y)))) 2159 | (pt-put 'sub '(scheme-number scheme-number) 2160 | (fn [x y] (tag (- x y)))) 2161 | (pt-put 'mul '(scheme-number scheme-number) 2162 | (fn [x y] (tag (* x y)))) 2163 | (pt-put 'div '(scheme-number scheme-number) 2164 | (fn [x y] (tag (/ x y)))) 2165 | (pt-put 'raise '(scheme-number) 2166 | (fn [x] (make-rational x 1))) 2167 | (pt-put 'make 'scheme-number tag))) 2168 | 2169 | (defn install-rational-package [] 2170 | (let [numer (fn [x] (first x)) 2171 | denom (fn [x] (second x)) 2172 | make-rat (fn [n d] (let [g (gcd n d)] [(/ n g) (/ d g)])) 2173 | add-rat (fn [x y] 2174 | (make-rat (+ (* (numer x) (denom y)) 2175 | (* (numer y) (denom x))) 2176 | (* (denom x) (denom y)))) 2177 | sub-rat (fn [x y] 2178 | (make-rat (- (* (numer x) (denom y)) 2179 | (* (numer y) (denom x))) 2180 | (* (denom x) (denom y)))) 2181 | mul-rat (fn [x y] 2182 | (make-rat (* (numer x) (numer y)) 2183 | (* (denom x) (denom y)))) 2184 | div-rat (fn [x y] 2185 | (make-rat (* (numer x) (denom y)) 2186 | (* (denom x) (numer y)))) 2187 | tag (fn [x] (attach-tag 'rational x)) 2188 | ] 2189 | 2190 | (pt-put 'add '(rational rational) 2191 | (fn [x y] (tag (add-rat x y)))) 2192 | (pt-put 'sub '(rational rational) 2193 | (fn [x y] (tag (sub-rat x y)))) 2194 | (pt-put 'mul '(rational rational) 2195 | (fn [x y] (tag (mul-rat x y)))) 2196 | (pt-put 'div '(rational rational) 2197 | (fn [x y] (tag (div-rat x y)))) 2198 | (pt-put 'raise '(rational) 2199 | (fn [x] (make-complex-from-real-imag (/ (numer x) (denom x)) 0))) 2200 | (pt-put 'make 'rational 2201 | (fn [n d] (tag (make-rat n d)))))) 2202 | 2203 | (install-scheme-number-package) 2204 | (install-rational-package) 2205 | 2206 | (raise (raise (make-scheme-number 3))) 2207 | 2208 | ;; Exercise 2.84 2209 | 2210 | (def type-levels {'scheme-number 0, 'rational 1, 'complex 2}) 2211 | 2212 | (defn get-coercion [orig-type dest-type] 2213 | (let [orig-level (type-levels orig-type) 2214 | dest-level (type-levels dest-type) 2215 | level-diff (- dest-level orig-level)] 2216 | (if (> level-diff 0) 2217 | (apply comp (repeat level-diff raise)) 2218 | nil))) 2219 | 2220 | (defn apply-generic [op & args] 2221 | ; coercing list to a type 2222 | (defn coerce-list-to-type [lst type] 2223 | (if (empty? lst) [] 2224 | (let [t1->t2 (get-coercion (type-tag (first lst)) type)] 2225 | (if t1->t2 2226 | (cons (t1->t2 (first lst)) (coerce-list-to-type (rest lst) type)) 2227 | (cons (first lst) (coerce-list-to-type (rest lst) type)))))) 2228 | 2229 | ; applying to a list of multiple arguments 2230 | (defn apply-coerced [lst] 2231 | (if (empty? lst) 2232 | (throw (RuntimeException. (str "No method for -- " op " - " args))) 2233 | (let [coerced-list (coerce-list-to-type args (type-tag (first lst))) 2234 | proc (pt-get op (map type-tag coerced-list))] 2235 | (if proc 2236 | (apply proc (map contents coerced-list)) 2237 | (apply-coerced (rest lst)))))) 2238 | 2239 | ; logic to prevent always coercing if there is already direct input entry 2240 | (let [type-tags (map type-tag args) 2241 | proc (pt-get op type-tags)] 2242 | (if proc 2243 | (apply proc (map contents args)) 2244 | (apply-coerced args)))) 2245 | 2246 | (add (make-scheme-number 2) (make-scheme-number 2) (make-scheme-number 2)) 2247 | (add (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4)) 2248 | (add (make-scheme-number 2) (make-complex-from-real-imag 3 4) (make-scheme-number 2)) 2249 | -------------------------------------------------------------------------------- /src/sicp/chapter-3.clj: -------------------------------------------------------------------------------- 1 | (ns sicp.ch3) 2 | 3 | (defn error [message & args] 4 | (throw (RuntimeException. (clojure.string/join " " (cons message args))))) 5 | 6 | (set! *print-length* 10) 7 | 8 | ;; Exercise 3.1 9 | 10 | (defn make-accumulator [x] 11 | (let [acc (atom x) 12 | acc-fn (fn [y] (do (swap! acc #(+ % y)) @acc))] 13 | acc-fn)) 14 | 15 | (def A (make-accumulator 5)) 16 | 17 | (A 10) 18 | 19 | (A 10) 20 | 21 | ;; Exercise 3.2 22 | 23 | (defn make-monitored [f] 24 | (let [counter (atom 0) 25 | counter-fn (fn [param] (condp = param 26 | 'how-many-calls? @counter 27 | 'reset-count (reset! counter 0) 28 | (do (swap! counter inc) (f param))))] 29 | counter-fn)) 30 | 31 | 32 | (def s (make-monitored #(Math/sqrt %))) 33 | 34 | (s 100) 35 | 36 | (s 25) 37 | 38 | (s 'how-many-calls?) 39 | 40 | (s 'reset-count) 41 | 42 | (s 36) 43 | 44 | (s 'how-many-calls?) 45 | 46 | ;; Exercise 3.3 47 | 48 | (defn make-account [initial-balance account-pwd] 49 | (let [balance (atom initial-balance) 50 | withdraw (fn [amount] 51 | (if (>= @balance amount) 52 | (do (swap! balance #(- % amount)) 53 | @balance) 54 | "Insufficient funds")) 55 | deposit (fn [amount] 56 | (swap! balance #(+ % amount)) 57 | @balance) 58 | dispatch (fn [m] 59 | (condp = m 60 | 'withdraw withdraw 61 | 'deposit deposit 62 | (error "Unknown request -- MAKE-ACCOUNT " m))) 63 | pwd-check (fn [input-pwd m] 64 | (if (= input-pwd account-pwd) 65 | (dispatch m) 66 | (fn [ignored] "Incorrect password")))] 67 | pwd-check)) 68 | 69 | (def acc (make-account 100 'secret-password)) 70 | 71 | ((acc 'secret-password 'withdraw) 40) 72 | 73 | ((acc 'some-other-password 'deposit) 50) 74 | 75 | ;; Exercise 3.4 76 | 77 | (defn make-account [account-pwd initial-balance] 78 | (let [balance (atom initial-balance) 79 | withdraw (fn [amount] 80 | (if (>= @balance amount) 81 | (do (swap! balance #(- % amount)) 82 | @balance) 83 | "Insufficient funds")) 84 | deposit (fn [amount] 85 | (swap! balance #(+ % amount)) 86 | @balance) 87 | dispatch (fn [m] 88 | (condp = m 89 | 'withdraw withdraw 90 | 'deposit deposit 91 | (error "Unknown request -- MAKE-ACCOUNT " m))) 92 | wrong-pwd (make-monitored (fn [ignored] "Incorrect password")) 93 | call-the-cops (fn [ignored] "Freeze!") 94 | pwd-check (fn [input-pwd m] 95 | (cond 96 | (= input-pwd account-pwd) (dispatch m) 97 | (< (wrong-pwd 'how-many-calls?) 2) wrong-pwd 98 | :else call-the-cops))] 99 | pwd-check)) 100 | 101 | (def acc (make-account 'secret-password 100)) 102 | 103 | ((acc 'secret-password 'withdraw) 40) 104 | 105 | ((acc 'some-other-password 'deposit) 50) 106 | 107 | ((acc 'some-other-password 'deposit) 50) 108 | 109 | ((acc 'some-other-password 'deposit) 50) 110 | 111 | ;; Exercise 3.5 112 | 113 | (defn monte-carlo [trials experiment] 114 | (defn iter [trials-remaining trials-passed] 115 | (cond 116 | (= trials-remaining 0) (/ trials-passed trials) 117 | (experiment) (iter (- trials-remaining 1) (+ trials-passed 1)) 118 | :else (iter (- trials-remaining 1) trials-passed))) 119 | (iter trials 0)) 120 | 121 | (defn random-in-range [low high] 122 | (let [range (- high low)] 123 | (+ low (rand range)))) 124 | 125 | (defn estimate-integral [predicate x1 x2 y1 y2 trials] 126 | (defn experiment [] (predicate (random-in-range x1 x2) (random-in-range y1 y2))) 127 | (let [percent (monte-carlo trials experiment) 128 | area (* (- x2 x1) (- y2 y1))] 129 | (* percent area))) 130 | 131 | (defn square [x] (* x x)) 132 | 133 | (defn unit-circle-predicate [x y] (<= (+ (square x) (square y)) 1)) 134 | 135 | (def estimate-pi (estimate-integral unit-circle-predicate -1.0 1.0 -1.0 1.0 1000)) 136 | 137 | estimate-pi 138 | 139 | ;; Exercise 3.6 140 | 141 | (defn rand-update "Linear Congruential Generator" [x] 142 | (let [a (Math/pow 2 32) 143 | c 1103515245 144 | m 12345] 145 | (mod (+ (* a x) c) m))) 146 | 147 | (def random-init 137) 148 | 149 | (def random 150 | (let [x (atom random-init)] 151 | (defn dispatch [m] 152 | (condp = m 153 | 'generate (do (swap! x rand-update) 154 | @x) 155 | 'reset (fn [new-x] 156 | (reset! x new-x)) 157 | (error "unknown request"))) 158 | dispatch)) 159 | 160 | 161 | (random 'generate) 162 | 163 | (random 'generate) 164 | 165 | ((random 'reset) 3062) 166 | 167 | (random 'generate) 168 | 169 | ;; Exercise 3.7 170 | 171 | (defn password-protect [password subject] 172 | (defn call-the-cops [ignored-msg] 173 | "Freeze!") 174 | (def wrong-pwd 175 | (make-monitored (fn [ignored-msg] 176 | "Incorrect password"))) 177 | (defn check-pwd [input-pwd msg] 178 | (cond 179 | (= input-pwd password) (subject msg) 180 | (< (wrong-pwd 'how-many-calls?) 2) wrong-pwd 181 | :else call-the-cops)) 182 | 183 | check-pwd) 184 | 185 | 186 | (defn make-account [account-pwd initial-balance] 187 | (let [balance (atom initial-balance) 188 | withdraw (fn [amount] 189 | (if (>= @balance amount) 190 | (do (swap! balance #(- % amount)) 191 | @balance) 192 | "Insufficient funds")) 193 | deposit (fn [amount] 194 | (swap! balance #(+ % amount)) 195 | @balance) 196 | dispatch (fn [m] 197 | (condp = m 198 | 'withdraw withdraw 199 | 'deposit deposit 200 | (error "Unknown request -- MAKE-ACCOUNT " m)))] 201 | (password-protect account-pwd dispatch))) 202 | 203 | (def peter-acc 204 | (make-account 'open-sesame 100)) 205 | 206 | (defn make-joint [account original-password new-password] 207 | (defn forward [msg] 208 | (account original-password msg)) 209 | (password-protect new-password forward)) 210 | 211 | (def paul-acc 212 | (make-joint peter-acc 'open-sesame 'rosebud)) 213 | 214 | ((peter-acc 'open-sesame 'withdraw) 10) 215 | 216 | ((paul-acc 'rosebud 'withdraw) 10) 217 | 218 | ;; Exercise 3.8 219 | 220 | (def f 221 | (let [state (atom 0)] 222 | (defn switch-state [x] 223 | (let [old-state @state] 224 | (reset! state (+ x old-state)) 225 | old-state)) 226 | switch-state)) 227 | 228 | (f 0) 229 | 230 | (f 1) 231 | 232 | (f 0) 233 | 234 | 235 | ;; Exercise 3.28 236 | 237 | (defn call-each [procedures] 238 | (if (empty? procedures) 239 | 'done 240 | (do 241 | ((first procedures)) 242 | (call-each (rest procedures))))) 243 | 244 | (defn make-wire [] 245 | (let [signal-value (atom 0) 246 | action-procedures (atom []) 247 | 248 | set-my-signal! (fn [new-value] 249 | (if (not= signal-value new-value) 250 | (do 251 | (reset! signal-value new-value) 252 | (call-each @action-procedures)) 253 | 'done)) 254 | 255 | accept-action-procedure! (fn [proc] 256 | (swap! action-procedures #(cons proc %)) 257 | (proc)) 258 | 259 | dispatch (fn [m] 260 | (condp = m 261 | 'get-signal @signal-value 262 | 'set-signal! set-my-signal! 263 | 'add-action! accept-action-procedure! 264 | (error "Unknown operation -- WIRE " m)))] 265 | dispatch)) 266 | 267 | 268 | (defn get-signal [wire] 269 | (wire 'get-signal)) 270 | 271 | (defn set-signal! [wire new-value] 272 | ((wire 'set-signal!) new-value)) 273 | 274 | (defn add-action! [wire action-procedure] 275 | ((wire 'add-action!) action-procedure)) 276 | 277 | ;; 278 | 279 | (defn make-queue [] (atom [])) 280 | 281 | (defn delete-queue! [q] (swap! q pop)) 282 | 283 | (defn insert-queue! [q e] (swap! q #(conj % e))) 284 | 285 | (defn empty-queue? [q] (empty? @q)) 286 | 287 | (defn front-queue [q] (first @q)) 288 | 289 | (defn make-time-segment [time queue] [time queue]) 290 | 291 | (defn segment-time [s] (first s)) 292 | 293 | (defn segment-queue [s] (second s)) 294 | 295 | (defn make-agenda [] (atom {:time 0 :segments []})) 296 | 297 | (defn current-time [agenda] (:time @agenda)) 298 | 299 | (defn set-current-time! [agenda time] (swap! agenda #(assoc % :time time))) 300 | 301 | (defn segments [agenda] (:segments @agenda)) 302 | 303 | (defn set-segments! [agenda segments] (swap! agenda #(assoc % :segments segments))) 304 | 305 | (defn first-segment [agenda] (first (segments agenda))) 306 | 307 | (defn rest-segments [agenda] (rest (segments agenda))) 308 | 309 | (defn empty-agenda? [agenda] (empty? (segments agenda))) 310 | 311 | (defn add-to-agenda! [time action agenda] 312 | (defn belongs-before? [segments] 313 | (or (empty? segments) 314 | (< time (segment-time (first segments))))) 315 | 316 | (defn make-new-time-segment [time action] 317 | (let [q (make-queue)] 318 | (insert-queue! q action) 319 | (make-time-segment time q))) 320 | 321 | (defn add-to-segments! [segments] 322 | (if (= (segment-time (first segments)) time) 323 | (do 324 | (insert-queue! 325 | (segment-queue (first segments)) action) 326 | segments) 327 | (let [others (rest segments) 328 | others+segment (if (belongs-before? others) 329 | (cons (make-new-time-segment time action) others) 330 | (add-to-segments! others))] 331 | (if (empty? others) 332 | others+segment 333 | (cons (first segments) others+segment))))) 334 | 335 | (let [new-segments (add-to-segments! (segments agenda))] 336 | (set-segments! agenda new-segments))) 337 | 338 | (defn remove-first-agenda-item! [agenda] 339 | (let [q (segment-queue (first-segment agenda))] 340 | (delete-queue! q) 341 | (if (empty-queue? q) 342 | (set-segments! agenda (rest-segments agenda))))) 343 | 344 | (defn first-agenda-item [agenda] 345 | (if (empty-agenda? agenda) 346 | (error "Agenda is empty -- FIRST-AGENDA-ITEM") 347 | (let [first-seg (first-segment agenda)] 348 | (set-current-time! agenda (segment-time first-seg)) 349 | (front-queue (segment-queue first-seg))))) 350 | 351 | (def the-agenda (make-agenda)) 352 | 353 | (defn after-delay [delay action] 354 | (add-to-agenda! (+ delay (current-time the-agenda)) 355 | action 356 | the-agenda)) 357 | 358 | (defn propagate [] 359 | (if (empty-agenda? the-agenda) 360 | 'done 361 | (let [first-item (first-agenda-item the-agenda)] 362 | (first-item) 363 | (remove-first-agenda-item! the-agenda) 364 | (propagate)))) 365 | 366 | (defn probe [name wire] 367 | (add-action! wire #(println 368 | "Name:" 369 | name 370 | "| Time:" 371 | (current-time the-agenda) 372 | "| New-value:" 373 | (get-signal wire)))) 374 | 375 | ;; 376 | 377 | (def inverter-delay 2) 378 | 379 | (def and-gate-delay 3) 380 | 381 | (def or-gate-delay 5) 382 | 383 | ;; 384 | 385 | (defn and-gate [a1 a2 output] 386 | (defn logical-and [s1 s2] 387 | (condp = [s1 s2] 388 | [1 1] 1 389 | [1 0] 0 390 | [0 1] 0 391 | [0 0] 0 392 | (error "Invalid signals " s1 " " s2))) 393 | 394 | (defn and-action-procedure [] 395 | (let [new-value (logical-and (get-signal a1) (get-signal a2))] 396 | (after-delay and-gate-delay 397 | (fn [] 398 | (set-signal! output new-value))))) 399 | (add-action! a1 and-action-procedure) 400 | (add-action! a2 and-action-procedure) 401 | 'ok) 402 | 403 | (defn inverter [input output] 404 | (defn logical-not [s] 405 | (case s 406 | 0 1 407 | 1 0 408 | (error "Invalid signal " s))) 409 | 410 | (defn invert-input [] 411 | (let [new-value (logical-not (get-signal input))] 412 | (after-delay inverter-delay 413 | (fn [] 414 | (set-signal! output new-value))))) 415 | 416 | (add-action! input invert-input) 417 | 'ok) 418 | 419 | 420 | (defn or-gate [a1 a2 output] 421 | (defn logical-or [s1 s2] 422 | (condp = [s1 s2] 423 | [1 1] 1 424 | [1 0] 1 425 | [0 1] 1 426 | [0 0] 0 427 | (error "Invalid signals " s1 " " s2))) 428 | 429 | (defn or-action-procedure [] 430 | (let [new-value (logical-or (get-signal a1) (get-signal a2))] 431 | (after-delay or-gate-delay 432 | (fn [] 433 | (set-signal! output new-value))))) 434 | (add-action! a1 or-action-procedure) 435 | (add-action! a2 or-action-procedure) 436 | 'ok) 437 | 438 | ;; Exercise 3.29 439 | 440 | (defn or-gate [a1 a2 output] 441 | (let [c1 (make-wire) 442 | c2 (make-wire) 443 | c3 (make-wire)] 444 | (inverter a1 c1) 445 | (inverter a2 c2) 446 | (and-gate c1 c2 c3) 447 | (inverter c3 output))) 448 | 449 | ;; Exercise 3.30 450 | 451 | (defn half-adder [a b s c] 452 | (let [d (make-wire) e (make-wire)] 453 | (or-gate a b d) 454 | (and-gate a b c) 455 | (inverter c e) 456 | (and-gate d e s) 457 | 'ok)) 458 | 459 | (defn full-adder [a b c-in sum c-out] 460 | (let [s (make-wire) 461 | c1 (make-wire) 462 | c2 (make-wire)] 463 | (half-adder b c-in s c1) 464 | (half-adder a s sum c2) 465 | (or-gate c1 c2 c-out) 466 | 'ok)) 467 | 468 | (defn ripple-carry-adder [a b s c-out] 469 | (let [c-in (make-wire)] 470 | (if (empty? a) 471 | (set-signal! c-in 0) 472 | (ripple-carry-adder (first a) (first b) (first s) c-in)) 473 | (full-adder (first a) (first b) c-in (first s) c-out))) 474 | 475 | ;; Exercise 3.31 476 | 477 | ; Because accept-action-procedure! adds the procedure to the wire, not to the agenda 478 | 479 | ;; Exercise 3.32 480 | 481 | (def input-1 (make-wire)) 482 | (def input-2 (make-wire)) 483 | (def sum (make-wire)) 484 | (def carry (make-wire)) 485 | (probe 'sum sum) 486 | ; sum 0 New-value = 0 487 | (probe 'carry carry) 488 | ; carry 0 New-value = 0 489 | (half-adder input-1 input-2 sum carry) 490 | (set-signal! input-1 1) 491 | (propagate) 492 | ; sum 8 New-value = 1 493 | (set-signal! input-2 1) 494 | (propagate) 495 | ; carry 11 New-value = 1 496 | ; sum 16 New-value = 0 497 | 498 | ; The procedure that sets the output checks the current value of the input wires. 499 | ; If that procedure is executed first (LIFO) it may not yet see the changes to the inputs. 500 | 501 | 502 | ;; Exercise 3.50 503 | 504 | (defmacro cons-stream [el coll] 505 | (list 'lazy-seq (list cons el coll))) 506 | 507 | (defn stream-map [proc coll & more] 508 | (let [argstreams (cons coll more)] 509 | (if (some true? (map empty? argstreams)) 510 | '() 511 | (cons-stream 512 | (apply proc (map first argstreams)) 513 | (apply stream-map proc (map rest argstreams)))))) 514 | 515 | ;; Exercise 3.51 516 | 517 | (defn show [x] 518 | (println x) 519 | x) 520 | 521 | (def x (stream-map show (range 10))) ; 0 522 | (nth x 5) ; 1 2 3 4 5 523 | (nth x 7) ; 6 7 524 | 525 | ;; Exercise 3.52 526 | 527 | (def sum (atom 0)) 528 | 529 | (defn accum [x] 530 | (swap! sum #(+ x %))) 531 | 532 | (def stream (map accum (range 1 20))) ; 1 533 | 534 | (def y (filter even? stream)) ; 6 535 | 536 | (def z (filter #(= (rem % 5) 0) stream)) ; 10 537 | 538 | (nth y 7) ; 136 539 | 540 | ;; Exercise 3.53 541 | 542 | (def s (cons-stream 1 (map + s s))) ; 1 2 4 6 16 543 | 544 | ;; Exercise 3.54 545 | 546 | (def factorials (cons-stream 1 (map * factorials (iterate inc 2)))) 547 | 548 | ;; Exercise 3.55 549 | 550 | (defn partial-sums [stream] 551 | (if (empty? stream) 552 | '() 553 | (cons-stream 554 | (first stream) 555 | (map + 556 | (rest stream) 557 | (partial-sums stream))))) 558 | 559 | ;; Exercise 3.56 560 | 561 | (defn merge-streams [s1 s2] 562 | (cond 563 | (empty? s1) s2 564 | (empty? s2) s1 565 | :else (let [s1car (first s1) 566 | s2car (first s2) 567 | s1cdr (rest s1) 568 | s2cdr (rest s2)] 569 | (cond 570 | (< s1car s2car) (cons-stream s1car (merge-streams s1cdr s2)) 571 | (> s1car s2car) (cons-stream s2car (merge-streams s1 s2cdr)) 572 | (= s1car s2car) (cons-stream s1car (merge-streams s1cdr s2cdr)))))) 573 | 574 | (defn scale-stream [s n] 575 | (map #(* n %) s)) 576 | 577 | (def integers (range 1 100)) 578 | 579 | (def S (cons-stream 1 (merge-streams (scale-stream integers 2) 580 | (merge-streams (scale-stream integers 3) 581 | (scale-stream integers 5))))) 582 | 583 | (take 20 S) 584 | 585 | ;; Exercise 3.57 586 | 587 | (def fibs 588 | (cons-stream 0 589 | (cons-stream 1 590 | (map + fibs (rest fibs))))) 591 | 592 | ; If memoized steps are linear, otherwise it's the same as a naive recursive. 593 | 594 | ;; Exercise 3.58 595 | 596 | (defn expand [num den radix] 597 | (cons-stream 598 | (quot (* num radix) den) 599 | (expand (rem (* num radix) den) den radix))) 600 | 601 | (expand 1 7 10) 602 | 603 | (expand 3 8 10) 604 | 605 | ;; Exercise 3.59 606 | 607 | ; a 608 | 609 | (defn integrate-series [s] 610 | (map / s integers)) 611 | 612 | ; b 613 | 614 | (def cosine-series 615 | (cons-stream 1 (map #(* -1 %) (integrate-series sine-series)))) 616 | (def sine-series 617 | (cons-stream 0 (integrate-series cosine-series))) 618 | 619 | ;; Exercise 3.60 620 | 621 | (defn add-streams [s1 s2] 622 | (map + s1 s2)) 623 | 624 | (defn mul-series [s1 s2] 625 | (cons-stream (* (first s1) (first s2)) 626 | (add-streams 627 | (add-streams (scale-stream (rest s1) 628 | (first s2)) 629 | (scale-stream (rest s1) 630 | (first s2))) 631 | (cons-stream 0 (mul-series (rest s1) 632 | (rest s2)))))) 633 | 634 | (def one (add-streams (mul-series sine-series sine-series) 635 | (mul-series cosine-series cosine-series))) 636 | 637 | (take 3 one) 638 | 639 | ;; Exercise 3.61 640 | 641 | (defn invert-unit-series [s] 642 | (cons-stream 1 (mul-series 643 | (map #(* -1 %) s) 644 | (invert-unit-series s)))) 645 | 646 | ;; Exercise 3.62 647 | 648 | (defn div-series [num den] 649 | (let [divisor (/ 1 (first den))] 650 | (scale-stream (mul-series num 651 | (invert-unit-series (scale-stream den divisor)) 652 | divisor)))) 653 | 654 | (def tangent-series (div-series sine-series cosine-series)) 655 | 656 | ;; Exercise 3.63 657 | 658 | (defn average [x y] (/ (+ x y) 2)) 659 | 660 | (defn sqrt-improve [guess x] 661 | (average guess (/ x guess))) 662 | 663 | (defn sqrt-stream [x] 664 | (def guesses 665 | (cons-stream 1.0 666 | (map (fn [guess] 667 | (sqrt-improve guess x)) guesses))) 668 | guesses) 669 | 670 | (take 8 (sqrt-stream 2)) 671 | 672 | ; By defining guesses we leverage on the memoization used inside the data structure itself 673 | ; If we call (sqrt-stream x) directly every time there's no caching of values 674 | 675 | ;; Exercise 3.64 676 | 677 | (defn stream-limit [stream tolerance] 678 | (let [difference (Math/abs (- (first stream) (second stream)))] 679 | (if (< difference tolerance) 680 | (second stream) 681 | (stream-limit (rest stream) tolerance)))) 682 | 683 | (defn sqrt [x tolerance] 684 | (stream-limit (sqrt-stream x) tolerance)) 685 | 686 | (sqrt 2 0.1) 687 | 688 | ;; Exercise 3.65 689 | 690 | (defn pi-summands [n] 691 | (cons-stream (/ 1.0 n) 692 | (map - (pi-summands (+ n 2))))) 693 | (def pi-stream 694 | (scale-stream (partial-sums (pi-summands 1)) 4)) 695 | 696 | (take 8 pi-stream) 697 | 698 | (defn euler-transform [s] 699 | (let [s0 (nth s 0) ; Sn-1 700 | s1 (nth s 1) ; Sn 701 | s2 (nth s 2)] ; Sn+1 702 | (cons-stream (- s2 (/ (square (- s2 s1)) 703 | (+ s0 (* -2 s1) s2))) 704 | (euler-transform (rest s))))) 705 | 706 | (take 8 (euler-transform pi-stream)) 707 | 708 | (defn make-tableau [transform s] 709 | (cons-stream s 710 | (make-tableau transform 711 | (transform s)))) 712 | 713 | (defn accelerated-sequence [transform s] 714 | (map first (make-tableau transform s))) 715 | 716 | (take 8 (accelerated-sequence euler-transform pi-stream)) 717 | 718 | ; 719 | 720 | (defn ln2-summands [n] 721 | (cons-stream (/ 1.0 n) 722 | (map - (ln2-summands (inc n))))) 723 | (def ln2-stream 724 | (partial-sums (ln2-summands 1))) 725 | 726 | (take 8 ln2-stream) 727 | 728 | (take 8 (accelerated-sequence euler-transform ln2-stream)) 729 | 730 | ;; Exercise 3.66 731 | 732 | (defn pairs [s t] 733 | (cons-stream 734 | [(first s) (first t)] 735 | (interleave 736 | (map #(vector (first s) %) (rest t)) 737 | (pairs (rest s) (rest t))))) 738 | 739 | (pairs [1 2 3 4] [5 6 7 8]) 740 | 741 | ;; Exercise 3.67 742 | 743 | (defn pairs [s t] 744 | (cons-stream 745 | [(first s) (first t)] 746 | (interleave 747 | (map #(vector (first s) %) (rest t)) 748 | (map #(vector % (first t)) (rest s)) 749 | (pairs (next s) (next t))))) 750 | 751 | (pairs [1 2 3 4] [5 6 7 8]) 752 | 753 | ;; Exercise 3.68 754 | 755 | (defn pairs [s t] 756 | (interleave 757 | (map #(vector (first s) %) t) 758 | (pairs (rest s) (rest t)))) 759 | 760 | (pairs integers integers) ; The first 'map never terminates if not defined lazily 761 | 762 | ;; Exercise 3.69 763 | 764 | (defn triples [s t u] 765 | (cons-stream 766 | [(first s) (first t) (first u)] 767 | (interleave 768 | (map #(cons (first s) %) (pairs t (rest u))) 769 | (triples (rest s) (rest t) (rest u))))) 770 | 771 | (triples [1 2 3 4] [5 6 7 8] [9 10 11 12]) 772 | 773 | (defn pythagorean-test [x y z] (= (+ (square x) (square y)) (square z))) 774 | 775 | (def pythagorean-triples (filter pythagorean-test (triples integers integers integers))) 776 | 777 | (take 10 pythagorean-triples) 778 | 779 | ;; Exercise 3.70 780 | 781 | (defn merge-weighted [s1 s2 weight] 782 | (cond 783 | (empty? s1) s2 784 | (empty? s2) s1 785 | :else (let [s1car (first s1) 786 | s2car (first s2) 787 | w1 (weight s1car) 788 | w2 (weight s2car) 789 | s1cdr (rest s1) 790 | s2cdr (rest s2)] 791 | (cond 792 | (< w1 w2) (cons-stream s1car (merge-streams s1cdr s2)) 793 | (> w1 w2) (cons-stream s2car (merge-streams s1 s2cdr)) 794 | (= w1 w2) (cons-stream s1car (merge-streams s1cdr s2cdr)))))) 795 | 796 | (defn weighted-pairs [s1 s2 weight] 797 | (merge-weighted 798 | (map #(vector (first s) %) t) 799 | (pairs (rest s) (rest t)) 800 | weight)) 801 | 802 | ; a 803 | 804 | (take 20 (weighted-pairs integers integers #(+ %1 %2))) 805 | 806 | ; b 807 | 808 | (defn weight [i j] (+ (* 2 i) (* 3 j) (* 5 i j))) 809 | 810 | (take 20 (-> (scale-stream integers 2) 811 | (weighted-pairs (scale-stream 3) weight) 812 | (weighted-pairs (scale-stream 5) weight))) 813 | 814 | ;; Exercise 3.71 815 | 816 | (defn cube [x] (* x x x)) 817 | 818 | (defn weight [i j] (+ (cube i) (cube j))) 819 | 820 | (defn search-pairs [int-pairs] 821 | (let [x (first int-pairs) 822 | y (second int-pairs)] 823 | (if (= (weight x) (weight y)) 824 | (cons-stream x (search-pairs (rest int-pairs))) 825 | (search-pairs (rest int-pairs))))) 826 | 827 | (def rama-pairs (search-pairs (weighted-pairs integers integers weight))) 828 | 829 | (take 6 rama-pairs) 830 | 831 | ;; Exercise 3.72 832 | 833 | (defn weight [i j] (+ (square i) (square j))) 834 | 835 | (defn search-pairs [int-pairs] 836 | (let [x (nth int-pairs 0) 837 | y (nth int-pairs 1) 838 | y (nth int-pairs 2)] 839 | (if (= (weight x) (weight y) (weight z)) 840 | (cons-stream [(weight x) [x y z]] (search-pairs (rest int-pairs))) 841 | (search-pairs (rest int-pairs))))) 842 | 843 | (take 6 (search-pairs (weighted-pairs integers integers weight))) 844 | 845 | ;; Exercise 3.73 846 | 847 | (defn integral [integrand initial-value dt] 848 | (def stream 849 | (cons-stream initial-value 850 | (add-streams (scale-stream integrand dt) 851 | stream))) 852 | stream) 853 | 854 | (defn RC [R C dt] 855 | (fn [i v0] 856 | (let [Ri (scale-stream i R) 857 | reverse-C (scale-stream i (/ 1 C)) 858 | integral (reverse-C v0 dt)] 859 | (add-streams Ri integral)))) 860 | 861 | (def RC1 (RC 5 1 0.5)) 862 | 863 | ;; Exercise 3.74 864 | 865 | (defn sign-change-detector [current last] 866 | (cond 867 | (and (neg? last) (pos? current)) 1 868 | (and (pos? last) (neg? current)) -1 869 | :else 0)) 870 | 871 | (def sense-data '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)) 872 | 873 | (def zero-crossings 874 | (map sign-change-detector sense-data (cons-stream 0 sense-data))) 875 | 876 | ;; Exercise 3.75 877 | 878 | (defn make-zero-crossings [input-stream last-value last-avpt] 879 | (let [avpt (/ (+ (first input-stream) last-value) 2)] 880 | (cons-stream (sign-change-detector avpt last-avpt) 881 | (make-zero-crossings (rest input-stream) 882 | (first input-stream) 883 | avpt)))) 884 | 885 | ;; Exercise 3.76 886 | 887 | (defn smooth [input-stream] 888 | (let [a (first input-stream) 889 | b (second input-stream) 890 | avg (/ (+ a b) 2)] 891 | (cons-stream avg (smooth (rest input-stream))))) 892 | 893 | (defn make-zero-crossings [input-stream] 894 | (let [smooth-input (smooth input-stream)] 895 | (map sign-change-detector smooth-input (cons-stream 0 smooth-input)))) 896 | 897 | ;; Exercise 3.77 898 | 899 | (defn integral [delayed-integrand initial-value dt] 900 | (cons-stream initial-value 901 | (let [integrand (force delayed-integrand)] 902 | (if (empty? integrand) 903 | integrand 904 | (integral (delay (rest integrand)) 905 | (+ (* dt (first integrand)) 906 | initial-value) 907 | dt))))) 908 | 909 | ;; Exercise 3.78 910 | 911 | (defn solve-2nd [a b dt y0 dy0] 912 | (letfn [(y [] (integral (delay (dy)) y0 dt)) 913 | (dy [] (integral (delay (ddy)) dy0 dt)) 914 | (ddy [] (add-streams 915 | (scale-stream (dy) a) 916 | (scale-stream (y) b)))] 917 | (y))) 918 | 919 | ;; Exercise 3.79 920 | 921 | (defn solve-2nd [f dt y0 dy0] 922 | (letfn [(y [] (integral (delay (dy)) y0 dt)) 923 | (dy [] (integral (delay (ddy)) dy0 dt)) 924 | (ddy [] (map f (dy) (y)))] 925 | (y))) 926 | 927 | ;; Exercise 3.80 928 | 929 | (defn RLC [R L C dt] 930 | (fn [vC0 iL0] 931 | (letfn [(iL [] (integral (delay (diL)) iL0 dt)) 932 | (diL [] (add-streams 933 | (scale-stream (iL) (- (/ R L))) 934 | (scale-stream (vC) (/ 1 L)))) 935 | (vC [] (integral (delay (dvC)) vC0 dt)) 936 | (dvC [] (scale-stream (iL) (/ -1 C)))] 937 | (list (vC) (iL))))) 938 | 939 | ;; Exercise 3.81 940 | 941 | (defn random-numbers [requests-stream] 942 | (defn action [last-value message] 943 | (if (= message 'generate) 944 | (rand-update last-value) 945 | message ; New seed 946 | )) 947 | (cons-stream random-init 948 | (map action (random-numbers requests-stream) requests-stream))) 949 | 950 | ;; Exercise 3.82 951 | 952 | (defn monte-carlo [experiment-stream passed failed] 953 | (defn iter [passed failed] 954 | (cons-stream 955 | (/ passed (+ passed failed)) 956 | (monte-carlo 957 | (rest experiment-stream) passed failed))) 958 | 959 | (if (first experiment-stream) 960 | (iter (+ passed 1) failed) 961 | (iter passed (+ failed 1)))) 962 | 963 | (defn random-numbers-in-range [low high] 964 | (cons-stream 965 | (random-in-range low high) 966 | (random-numbers-in-range low high))) 967 | 968 | (defn estimate-integral [predicate x1 x2 y1 y2] 969 | (let [experiment-stream (map predicate (random-numbers-in-range x1 x2) (random-numbers-in-range y1 y2)) 970 | monte-carlo-stream (monte-carlo experiment-stream 0 0) 971 | area (* (- x2 x1) (- y2 y1))] 972 | (scale-stream monte-carlo-stream area))) 973 | 974 | (def estimate-pi-stream (estimate-integral unit-circle-predicate -1.0 1.0 -1.0 1.0)) 975 | 976 | (nth estimate-pi-stream 1000) 977 | -------------------------------------------------------------------------------- /src/sicp/core.clj: -------------------------------------------------------------------------------- 1 | (ns sicp.core) 2 | 3 | (defn foo 4 | "I don't do a whole lot." 5 | [x] 6 | (println x "Hello, World!")) 7 | -------------------------------------------------------------------------------- /src/sicp/temp-2-82.clj: -------------------------------------------------------------------------------- 1 | ;; Exercise 2.77 2 | 3 | (def proc-table (atom {})) 4 | 5 | (defn pt-get [op type] (@proc-table [op type])) 6 | 7 | (defn pt-put [op type item] (swap! proc-table #(assoc % [op type] item))) 8 | 9 | (defn type-tag [datum] 10 | (cond (number? datum) datum 11 | (coll? datum) (first datum) 12 | :else (throw (RuntimeException. (str "Wrong datum -- TYPE-TAG " datum))))) 13 | 14 | (defn contents [datum] 15 | (cond (number? datum) datum 16 | (coll? datum) (rest datum) 17 | :else (throw (RuntimeException. (str "Wrong datum -- CONTENGS " datum))))) 18 | 19 | (defn attach-tag [tag content] 20 | (if (coll? content) (cons tag content) content)) 21 | 22 | (defn gcd [a b] 23 | (if (= b 0) 24 | a 25 | (gcd b (rem a b)))) 26 | 27 | ;;; 2.77 28 | 29 | (defn install-rectangular-package [] 30 | (let [real-part (fn [z] (first z)) 31 | imag-part (fn [z] (second z)) 32 | make-from-real-imag (fn [x y] [x y]) 33 | magnitude (fn [z] 34 | (Math/sqrt (+ (#(* % %) (real-part z)) 35 | (#(* % %) (imag-part z))))) 36 | angle (fn [z] 37 | (Math/atan2 (imag-part z) (real-part z))) 38 | make-from-mag-ang (fn [r a] 39 | [(* r (Math/cos a)) 40 | (* r (Math/sin a))]) 41 | tag (fn [x] (attach-tag 'rectangular x))] 42 | 43 | (pt-put 'real-part '(rectangular) real-part) 44 | (pt-put 'imag-part '(rectangular) imag-part) 45 | (pt-put 'magnitude '(rectangular) magnitude) 46 | (pt-put 'angle '(rectangular) angle) 47 | (pt-put 'make-from-real-imag 'rectangular 48 | (fn [x y] (tag (make-from-real-imag x y)))) 49 | (pt-put 'make-from-mag-ang 'rectangular 50 | (fn [r a] (tag (make-from-mag-ang r a)))))) 51 | 52 | (defn install-polar-package [] 53 | (let [magnitude (fn [z] (first z)) 54 | angle (fn [z] (second z)) 55 | make-from-mag-ang (fn [r a] [r a]) 56 | real-part (fn [z] 57 | (* (magnitude z) (Math/cos (angle z)))) 58 | imag-part (fn [z] 59 | (* (magnitude z) (Math/sin (angle z)))) 60 | make-from-real-imag (fn [x y] 61 | [(Math/sqrt (+ (#(* % %) x) (#(* % %) y))) 62 | (Math/atan2 y x)]) 63 | tag (fn [x] (attach-tag 'polar x))] 64 | 65 | 66 | (pt-put 'real-part '(polar) real-part) 67 | (pt-put 'imag-part '(polar) imag-part) 68 | (pt-put 'magnitude '(polar) magnitude) 69 | (pt-put 'angle '(polar) angle) 70 | (pt-put 'make-from-real-imag 'polar 71 | (fn [x y] (tag (make-from-real-imag x y)))) 72 | (pt-put 'make-from-mag-ang 'polar 73 | (fn [r a] (tag (make-from-mag-ang r a)))))) 74 | 75 | 76 | (defn apply-generic [op & args] 77 | (let [type-tags (map type-tag args) 78 | proc (pt-get op type-tags)] 79 | (if proc 80 | (apply proc (map contents args)) 81 | (throw (RuntimeException. (str "No method for -- " op type-tags)))))) 82 | 83 | 84 | (defn real-part [z] (apply-generic 'real-part z)) 85 | (defn imag-part [z] (apply-generic 'imag-part z)) 86 | (defn magnitude [z] (apply-generic 'magnitude z)) 87 | (defn angle [z] (apply-generic 'angle z)) 88 | 89 | (defn add [x y] (apply-generic 'add x y)) 90 | (defn sub [x y] (apply-generic 'sub x y)) 91 | (defn mul [x y] (apply-generic 'mul x y)) 92 | (defn div [x y] (apply-generic 'div x y)) 93 | 94 | (defn install-scheme-number-package [] 95 | (let [tag (fn [x] 96 | (attach-tag 'scheme-number x))] 97 | 98 | (pt-put 'add '(scheme-number scheme-number) 99 | (fn [x y] (tag (+ x y)))) 100 | (pt-put 'sub '(scheme-number scheme-number) 101 | (fn [x y] (tag (- x y)))) 102 | (pt-put 'mul '(scheme-number scheme-number) 103 | (fn [x y] (tag (* x y)))) 104 | (pt-put 'div '(scheme-number scheme-number) 105 | (fn [x y] (tag (/ x y)))) 106 | (pt-put 'make 'scheme-number 107 | (fn [x] (tag x))))) 108 | 109 | (defn make-scheme-number [n] 110 | ((pt-get 'make 'scheme-number) n)) 111 | 112 | (defn install-rational-package [] 113 | (let [numer (fn [x] (first x)) 114 | denom (fn [x] (second x)) 115 | make-rat (fn [n d] (let [g (gcd n d)] [(/ n g) (/ d g)])) 116 | add-rat (fn [x y] 117 | (make-rat (+ (* (numer x) (denom y)) 118 | (* (numer y) (denom x))) 119 | (* (denom x) (denom y)))) 120 | sub-rat (fn [x y] 121 | (make-rat (- (* (numer x) (denom y)) 122 | (* (numer y) (denom x))) 123 | (* (denom x) (denom y)))) 124 | mul-rat (fn [x y] 125 | (make-rat (* (numer x) (numer y)) 126 | (* (denom x) (denom y)))) 127 | div-rat (fn [x y] 128 | (make-rat (* (numer x) (denom y)) 129 | (* (denom x) (numer y)))) 130 | tag (fn [x] (attach-tag 'rational x)) 131 | ] 132 | 133 | (pt-put 'add '(rational rational) 134 | (fn [x y] (tag (add-rat x y)))) 135 | (pt-put 'sub '(rational rational) 136 | (fn [x y] (tag (sub-rat x y)))) 137 | (pt-put 'mul '(rational rational) 138 | (fn [x y] (tag (mul-rat x y)))) 139 | (pt-put 'div '(rational rational) 140 | (fn [x y] (tag (div-rat x y)))) 141 | (pt-put 'make 'rational 142 | (fn [n d] (tag (make-rat n d)))))) 143 | 144 | (defn make-rational [n d] 145 | ((pt-get 'make 'rational) n d)) 146 | 147 | 148 | (defn install-complex-package [] 149 | (let [;; imported procedures from rectangular and polar packages 150 | make-from-real-imag (fn [x y] 151 | ((pt-get 'make-from-real-imag 'rectangular) x y)) 152 | make-from-mag-ang (fn [r a] 153 | ((pt-get 'make-from-mag-ang 'polar) r a)) 154 | add-complex (fn [z1 z2] 155 | (make-from-real-imag (+ (real-part z1) (real-part z2)) 156 | (+ (imag-part z1) (imag-part z2)))) 157 | sub-complex (fn [z1 z2] 158 | (make-from-real-imag (- (real-part z1) (real-part z2)) 159 | (- (imag-part z1) (imag-part z2)))) 160 | mul-complex (fn [z1 z2] 161 | (make-from-mag-ang (* (magnitude z1) (magnitude z2)) 162 | (+ (angle z1) (angle z2)))) 163 | div-complex (fn [z1 z2] 164 | (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) 165 | (- (angle z1) (angle z2)))) 166 | tag (fn [z] (attach-tag 'complex z)) 167 | ] 168 | (pt-put 'add '(complex complex) 169 | (fn [z1 z2] (tag (add-complex z1 z2)))) 170 | (pt-put 'sub '(complex complex) 171 | (fn [z1 z2] (tag (sub-complex z1 z2)))) 172 | (pt-put 'mul '(complex complex) 173 | (fn [z1 z2] (tag (mul-complex z1 z2)))) 174 | (pt-put 'div '(complex complex) 175 | (fn [z1 z2] (tag (div-complex z1 z2)))) 176 | (pt-put 'make-from-real-imag 'complex 177 | (fn [x y] (tag (make-from-real-imag x y)))) 178 | (pt-put 'make-from-mag-ang 'complex 179 | (fn [r a] (tag (make-from-mag-ang r a)))))) 180 | 181 | (install-rectangular-package) 182 | (install-polar-package) 183 | (install-scheme-number-package) 184 | (install-rational-package) 185 | (install-complex-package) 186 | 187 | (defn make-complex-from-real-imag [x y] 188 | ((pt-get 'make-from-real-imag 'complex) x y)) 189 | (defn make-complex-from-mag-ang [r a] 190 | ((pt-get 'make-from-mag-ang 'complex) r a)) 191 | 192 | (def z (make-complex-from-mag-ang 8 6)) 193 | 194 | ; This fails 195 | (magnitude z) 196 | 197 | (pt-put 'real-part '(complex) real-part) 198 | (pt-put 'imag-part '(complex) imag-part) 199 | (pt-put 'magnitude '(complex) magnitude) 200 | (pt-put 'angle '(complex) angle) 201 | 202 | (magnitude z) 203 | 204 | 205 | ; apply-generic is invoked twice, first dispatch is magnitude of 'complex, second is magnitude of 'rectangular. 206 | 207 | ;; Exercise 2.78 208 | 209 | (defn type-tag [datum] 210 | (cond (number? datum) 'scheme-number 211 | (coll? datum) (first datum) 212 | :else (throw (RuntimeException. (str "Wrong datum -- TYPE-TAG" datum))))) 213 | 214 | (defn contents [datum] 215 | (cond (number? datum) datum 216 | (coll? datum) (rest datum) 217 | :else (throw (RuntimeException. (str "Wrong datum -- CONTENGS" datum))))) 218 | 219 | (defn attach-tag [tag content] 220 | (if (coll? content) (cons tag content) content)) 221 | 222 | ;; Exercise 2.81 223 | 224 | ;;a 225 | ; apply-generic will go into infinite recursion. 226 | 227 | ;;b 228 | ; apply-generic just works as it is. 229 | 230 | ;;c 231 | 232 | (defn put-coercion [source-type target-type proc] 233 | (pt-put 'coercion [source-type target-type] proc)) 234 | 235 | (defn get-coercion [source-type target-type] 236 | (pt-get 'coercion [source-type target-type])) 237 | 238 | (defn scheme-number->complex [n] 239 | (make-complex-from-real-imag (contents n) 0)) 240 | 241 | (put-coercion 'scheme-number 'complex scheme-number->complex) 242 | 243 | (defn apply-generic [op & args] 244 | (defn no-method [type-tags] 245 | (throw (RuntimeException. (str "No method for -- " op " -- " type-tags)))) 246 | 247 | (let [type-tags (map type-tag args) 248 | proc (pt-get op type-tags)] 249 | (if proc 250 | (apply proc (map contents args)) 251 | (if (= (count args) 2) 252 | (let [type1 (first type-tags) 253 | type2 (second type-tags) 254 | a1 (first args) 255 | a2 (second args)] 256 | (if (= type1 type2) 257 | (no-method type-tags) 258 | (let [t1->t2 (get-coercion type1 type2) 259 | t2->t1 (get-coercion type2 type1)] 260 | (cond 261 | t1->t2 (apply-generic op (t1->t2 a1) a2) 262 | t2->t1 (apply-generic op a1 (t2->t1 a2)) 263 | :else (no-method type-tags))))) 264 | (no-method type-tags))))) 265 | 266 | (add (make-rational 1 2) (make-rational 3 4)) 267 | 268 | (add (make-scheme-number 2) (make-complex-from-real-imag 3 4)) 269 | 270 | (get-coercion 'scheme-number 'complex) 271 | 272 | 273 | (defn add [& args] (apply apply-generic 'add args)) 274 | (pt-put 'add '(scheme-number scheme-number scheme-number) str) 275 | (pt-put 'add '(complex complex complex) str) 276 | 277 | (defn apply-generic [op & args] 278 | ; coercing list to a type 279 | (defn coerce-list-to-type [lst type] 280 | (if (empty? lst) [] 281 | (let [t1->t2 (get-coercion (type-tag (first lst)) type)] 282 | (if t1->t2 283 | (cons (t1->t2 (first lst)) (coerce-list-to-type (rest lst) type)) 284 | (cons (first lst) (coerce-list-to-type (rest lst) type)))))) 285 | 286 | ; applying to a list of multiple arguments 287 | (defn apply-coerced [lst] 288 | (if (empty? lst) 289 | (throw (RuntimeException. (str "No method for -- " op " - " args))) 290 | (let [coerced-list (coerce-list-to-type args (type-tag (first lst))) 291 | proc (pt-get op (map type-tag coerced-list))] 292 | (if proc 293 | (apply proc (map contents coerced-list)) 294 | (apply-coerced (rest lst)))))) 295 | 296 | ; logic to prevent always coercing if there is already direct input entry 297 | (let [type-tags (map type-tag args) 298 | proc (pt-get op type-tags)] 299 | (if proc 300 | (apply proc (map contents args)) 301 | (apply-coerced args)))) 302 | 303 | (add (make-scheme-number 2) (make-scheme-number 2) (make-scheme-number 2)) 304 | (add (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4)) 305 | (add (make-scheme-number 2) (make-complex-from-real-imag 3 4) (make-scheme-number 2)) 306 | 307 | ; number -> rational -> complex 308 | 309 | (defn raise [x] (apply-generic 'raise x)) 310 | 311 | (defn install-scheme-number-package [] 312 | (let [tag (fn [x] 313 | (attach-tag 'scheme-number x))] 314 | 315 | (pt-put 'add '(scheme-number scheme-number) 316 | (fn [x y] (tag (+ x y)))) 317 | (pt-put 'sub '(scheme-number scheme-number) 318 | (fn [x y] (tag (- x y)))) 319 | (pt-put 'mul '(scheme-number scheme-number) 320 | (fn [x y] (tag (* x y)))) 321 | (pt-put 'div '(scheme-number scheme-number) 322 | (fn [x y] (tag (/ x y)))) 323 | (pt-put 'raise '(scheme-number) 324 | (fn [x] (make-rational x 1))) 325 | (pt-put 'make 'scheme-number tag))) 326 | 327 | (defn install-rational-package [] 328 | (let [numer (fn [x] (first x)) 329 | denom (fn [x] (second x)) 330 | make-rat (fn [n d] (let [g (gcd n d)] [(/ n g) (/ d g)])) 331 | add-rat (fn [x y] 332 | (make-rat (+ (* (numer x) (denom y)) 333 | (* (numer y) (denom x))) 334 | (* (denom x) (denom y)))) 335 | sub-rat (fn [x y] 336 | (make-rat (- (* (numer x) (denom y)) 337 | (* (numer y) (denom x))) 338 | (* (denom x) (denom y)))) 339 | mul-rat (fn [x y] 340 | (make-rat (* (numer x) (numer y)) 341 | (* (denom x) (denom y)))) 342 | div-rat (fn [x y] 343 | (make-rat (* (numer x) (denom y)) 344 | (* (denom x) (numer y)))) 345 | tag (fn [x] (attach-tag 'rational x)) 346 | ] 347 | 348 | (pt-put 'add '(rational rational) 349 | (fn [x y] (tag (add-rat x y)))) 350 | (pt-put 'sub '(rational rational) 351 | (fn [x y] (tag (sub-rat x y)))) 352 | (pt-put 'mul '(rational rational) 353 | (fn [x y] (tag (mul-rat x y)))) 354 | (pt-put 'div '(rational rational) 355 | (fn [x y] (tag (div-rat x y)))) 356 | (pt-put 'raise '(rational) 357 | (fn [x] (make-complex-from-real-imag (/ (numer x) (denom x)) 0))) 358 | (pt-put 'make 'rational 359 | (fn [n d] (tag (make-rat n d)))))) 360 | 361 | (defn install-complex-package [] 362 | (let [;; imported procedures from rectangular and polar packages 363 | make-from-real-imag (fn [x y] 364 | ((pt-get 'make-from-real-imag 'rectangular) x y)) 365 | make-from-mag-ang (fn [r a] 366 | ((pt-get 'make-from-mag-ang 'polar) r a)) 367 | add-complex (fn [z1 z2] 368 | (make-from-real-imag (+ (real-part z1) (real-part z2)) 369 | (+ (imag-part z1) (imag-part z2)))) 370 | sub-complex (fn [z1 z2] 371 | (make-from-real-imag (- (real-part z1) (real-part z2)) 372 | (- (imag-part z1) (imag-part z2)))) 373 | mul-complex (fn [z1 z2] 374 | (make-from-mag-ang (* (magnitude z1) (magnitude z2)) 375 | (+ (angle z1) (angle z2)))) 376 | div-complex (fn [z1 z2] 377 | (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) 378 | (- (angle z1) (angle z2)))) 379 | tag (fn [z] (attach-tag 'complex z)) 380 | ] 381 | (pt-put 'add '(complex complex) 382 | (fn [z1 z2] (tag (add-complex z1 z2)))) 383 | (pt-put 'sub '(complex complex) 384 | (fn [z1 z2] (tag (sub-complex z1 z2)))) 385 | (pt-put 'mul '(complex complex) 386 | (fn [z1 z2] (tag (mul-complex z1 z2)))) 387 | (pt-put 'div '(complex complex) 388 | (fn [z1 z2] (tag (div-complex z1 z2)))) 389 | (pt-put 'make-from-real-imag 'complex 390 | (fn [x y] (tag (make-from-real-imag x y)))) 391 | (pt-put 'make-from-mag-ang 'complex 392 | (fn [r a] (tag (make-from-mag-ang r a)))))) 393 | 394 | (install-scheme-number-package) 395 | (install-rational-package) 396 | 397 | (raise (raise (make-scheme-number 3))) 398 | 399 | (def type-levels {'scheme-number 0, 'rational 1, 'complex 2}) 400 | 401 | (defn get-coercion [orig-type dest-type] 402 | (let [orig-level (type-levels orig-type) 403 | dest-level (type-levels dest-type) 404 | level-diff (- dest-level orig-level)] 405 | (if (> level-diff 0) 406 | (apply comp (repeat level-diff raise)) 407 | nil))) 408 | 409 | (defn apply-generic [op & args] 410 | ; coercing list to a type 411 | (defn coerce-list-to-type [lst type] 412 | (if (empty? lst) [] 413 | (let [t1->t2 (get-coercion (type-tag (first lst)) type)] 414 | (if t1->t2 415 | (cons (t1->t2 (first lst)) (coerce-list-to-type (rest lst) type)) 416 | (cons (first lst) (coerce-list-to-type (rest lst) type)))))) 417 | 418 | ; applying to a list of multiple arguments 419 | (defn apply-coerced [lst] 420 | (if (empty? lst) 421 | (throw (RuntimeException. (str "No method for -- " op " - " args))) 422 | (let [coerced-list (coerce-list-to-type args (type-tag (first lst))) 423 | proc (pt-get op (map type-tag coerced-list))] 424 | (if proc 425 | (apply proc (map contents coerced-list)) 426 | (apply-coerced (rest lst)))))) 427 | 428 | ; logic to prevent always coercing if there is already direct input entry 429 | (let [type-tags (map type-tag args) 430 | proc (pt-get op type-tags)] 431 | (if proc 432 | (apply proc (map contents args)) 433 | (apply-coerced args)))) 434 | 435 | (add (make-scheme-number 2) (make-scheme-number 2) (make-scheme-number 2)) 436 | (add (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4) (make-complex-from-real-imag 3 4)) 437 | (add (make-scheme-number 2) (make-complex-from-real-imag 3 4) (make-scheme-number 2)) 438 | 439 | 440 | (defn equ? [x y] (apply-generic 'equ? x y)) 441 | 442 | ;; Exercise 2.85 443 | 444 | (defn install-scheme-number-package [] 445 | (let [tag (fn [x] 446 | (attach-tag 'scheme-number x))] 447 | 448 | (pt-put 'add '(scheme-number scheme-number) 449 | (fn [x y] (tag (+ x y)))) 450 | (pt-put 'sub '(scheme-number scheme-number) 451 | (fn [x y] (tag (- x y)))) 452 | (pt-put 'mul '(scheme-number scheme-number) 453 | (fn [x y] (tag (* x y)))) 454 | (pt-put 'div '(scheme-number scheme-number) 455 | (fn [x y] (tag (/ x y)))) 456 | (pt-put 'raise '(scheme-number) 457 | (fn [x] (make-rational x 1))) 458 | (pt-put 'equ? '(scheme-number scheme-number) =) 459 | (pt-put 'make 'scheme-number tag))) 460 | 461 | (defn install-rational-package [] 462 | (let [numer (fn [x] (first x)) 463 | denom (fn [x] (second x)) 464 | make-rat (fn [n d] (let [g (gcd n d)] [(/ n g) (/ d g)])) 465 | add-rat (fn [x y] 466 | (make-rat (+ (* (numer x) (denom y)) 467 | (* (numer y) (denom x))) 468 | (* (denom x) (denom y)))) 469 | sub-rat (fn [x y] 470 | (make-rat (- (* (numer x) (denom y)) 471 | (* (numer y) (denom x))) 472 | (* (denom x) (denom y)))) 473 | mul-rat (fn [x y] 474 | (make-rat (* (numer x) (numer y)) 475 | (* (denom x) (denom y)))) 476 | div-rat (fn [x y] 477 | (make-rat (* (numer x) (denom y)) 478 | (* (denom x) (numer y)))) 479 | tag (fn [x] (attach-tag 'rational x))] 480 | 481 | (pt-put 'add '(rational rational) 482 | (fn [x y] (tag (add-rat x y)))) 483 | (pt-put 'sub '(rational rational) 484 | (fn [x y] (tag (sub-rat x y)))) 485 | (pt-put 'mul '(rational rational) 486 | (fn [x y] (tag (mul-rat x y)))) 487 | (pt-put 'div '(rational rational) 488 | (fn [x y] (tag (div-rat x y)))) 489 | (pt-put 'raise '(rational) 490 | (fn [x] (make-complex-from-real-imag (/ (numer x) (denom x)) 0))) 491 | (pt-put 'project '(rational) 492 | (fn [x] (make-scheme-number (quot (numer x) (denom x))))) 493 | (pt-put 'equ? '(rational rational) 494 | (fn [x y] (= (* (numer x) (denom y)) (* (numer y) (denom x))))) 495 | (pt-put 'make 'rational 496 | (fn [n d] (tag (make-rat n d)))))) 497 | 498 | (defn install-complex-package [] 499 | (let [;; imported procedures from rectangular and polar packages 500 | make-from-real-imag (fn [x y] 501 | ((pt-get 'make-from-real-imag 'rectangular) x y)) 502 | make-from-mag-ang (fn [r a] 503 | ((pt-get 'make-from-mag-ang 'polar) r a)) 504 | add-complex (fn [z1 z2] 505 | (make-from-real-imag (+ (real-part z1) (real-part z2)) 506 | (+ (imag-part z1) (imag-part z2)))) 507 | sub-complex (fn [z1 z2] 508 | (make-from-real-imag (- (real-part z1) (real-part z2)) 509 | (- (imag-part z1) (imag-part z2)))) 510 | mul-complex (fn [z1 z2] 511 | (make-from-mag-ang (* (magnitude z1) (magnitude z2)) 512 | (+ (angle z1) (angle z2)))) 513 | div-complex (fn [z1 z2] 514 | (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) 515 | (- (angle z1) (angle z2)))) 516 | tag (fn [z] (attach-tag 'complex z))] 517 | (pt-put 'add '(complex complex) 518 | (fn [z1 z2] (tag (add-complex z1 z2)))) 519 | (pt-put 'sub '(complex complex) 520 | (fn [z1 z2] (tag (sub-complex z1 z2)))) 521 | (pt-put 'mul '(complex complex) 522 | (fn [z1 z2] (tag (mul-complex z1 z2)))) 523 | (pt-put 'div '(complex complex) 524 | (fn [z1 z2] (tag (div-complex z1 z2)))) 525 | (pt-put 'project '(complex) 526 | (fn [x] (make-rational (real-part x) 1))) 527 | (pt-put 'equ? '(complex complex) 528 | (fn [x y] (and (= (real-part x) (real-part y)) (= (imag-part y) (imag-part x))))) 529 | (pt-put 'make-from-real-imag 'complex 530 | (fn [x y] (tag (make-from-real-imag x y)))) 531 | (pt-put 'make-from-mag-ang 'complex 532 | (fn [r a] (tag (make-from-mag-ang r a)))))) 533 | 534 | 535 | (install-scheme-number-package) 536 | (install-rational-package) 537 | (install-complex-package) 538 | 539 | (equ? (make-scheme-number 2) (make-scheme-number 2)) 540 | (equ? (make-rational 2 3) (make-rational 4 6)) 541 | (equ? (make-scheme-number 1) (make-rational 6 6)) 542 | 543 | (defn drop-type [x] 544 | (if-let [project-proc (pt-get 'project (list (type-tag x)))] 545 | (let [project-number (project-proc (contents x))] 546 | (if (equ? project-number x) 547 | (drop-type project-number) 548 | x)) 549 | x)) 550 | 551 | 552 | (apply-generic 'project (make-complex-from-real-imag 3 0)) 553 | (apply-generic 'raise (make-rational 3 1)) 554 | (type-tag (make-complex-from-real-imag 3 0)) 555 | (let [project-proc (pt-get 'project (type-tag (make-complex-from-real-imag 3 0)))] project-proc) 556 | (drop-type (make-complex-from-real-imag 3 0)) 557 | 558 | (defn apply-generic [op & args] 559 | ; coercing list to a type 560 | (defn coerce-list-to-type [lst type] 561 | (if (empty? lst) [] 562 | (let [t1->t2 (get-coercion (type-tag (first lst)) type)] 563 | (if t1->t2 564 | (cons (t1->t2 (first lst)) (coerce-list-to-type (rest lst) type)) 565 | (cons (first lst) (coerce-list-to-type (rest lst) type)))))) 566 | 567 | ; applying to a list of multiple arguments 568 | (defn apply-coerced [lst] 569 | (if (empty? lst) 570 | (throw (RuntimeException. (str "No method for -- " op " - " args))) 571 | (let [coerced-list (coerce-list-to-type args (type-tag (first lst))) 572 | proc (pt-get op (map type-tag coerced-list))] 573 | (if proc 574 | (apply proc (map contents coerced-list)) 575 | (apply-coerced (rest lst)))))) 576 | 577 | ; logic to prevent always coercing if there is already direct input entry 578 | (let [type-tags (map type-tag args) 579 | proc (pt-get op type-tags)] 580 | (if proc 581 | (drop-type (apply proc (map contents args))) 582 | (apply-coerced args)))) 583 | 584 | (add (make-complex-from-real-imag 5 -3) (make-complex-from-real-imag 2 3)) 585 | 586 | ; /Users/frankie/Desktop/temp-2-82.clj:309 proc-table/raise 587 | ; /Users/frankie/Desktop/temp-2-82.clj:546 proc-table/drop-type 588 | ; /Users/frankie/Desktop/temp-2-82.clj:581 proc-table/apply-generic 589 | -------------------------------------------------------------------------------- /src/sicp/tmp.clj: -------------------------------------------------------------------------------- 1 | (ns tmp) 2 | 3 | (defn error [message & args] 4 | (throw (RuntimeException. (clojure.string/join " " (cons message args))))) 5 | 6 | ;; 7 | 8 | (defn for-each-except [exception procedure elements] 9 | (defn iter [items] 10 | (cond 11 | (empty? items) 'done 12 | (= (first items) exception) (iter (rest items)) 13 | :else (do 14 | (procedure (first items)) 15 | (iter (rest items))))) 16 | (iter elements)) 17 | 18 | (defn has-value? [connector] 19 | (connector 'has-value?)) 20 | 21 | (defn get-value [connector] 22 | (connector 'value)) 23 | 24 | (defn set-value! [connector new-value informant] 25 | ((connector 'set-value!) new-value informant)) 26 | 27 | (defn forget-value! [connector retractor] 28 | ((connector 'forget) retractor)) 29 | 30 | (defn connect [connector new-constraint] 31 | ((connector 'connect) new-constraint)) 32 | 33 | (defn make-connector [] 34 | (let [value (atom false) 35 | informant (atom false) 36 | constraints (atom '()) 37 | set-my-value (fn [newval setter] 38 | (cond 39 | (not (has-value? me)) (do 40 | (reset! value newval) 41 | (reset! informant setter) 42 | (for-each-except setter 43 | inform-about-value 44 | constraints)) 45 | (not= value newval) (error "Contradiction" value newval) 46 | :else 'ignored)) 47 | 48 | forget-my-value (fn [retractor] 49 | (if (= retractor @informant) 50 | (do 51 | (reset! informant false) 52 | (for-each-except retractor 53 | inform-about-no-value 54 | constraints)) 55 | 'ignored)) 56 | 57 | connect (fn [new-constraint] 58 | (when (not-any? #{new-constraint} @constraints) 59 | (swap! constraints #(cons new-constraint %))) 60 | (when (has-value? me) 61 | (inform-about-value new-constraint)) 62 | 'done) 63 | 64 | me (fn [request] 65 | (condp = request 66 | 'has-value? (if @informant true false) 67 | 'value @value 68 | 'set-value! set-my-value 69 | 'forget forget-my-value 70 | 'connect connect 71 | (error "Unknown operation -- CONNECTOR"request)))] 72 | 73 | me)) 74 | 75 | ;; 76 | 77 | (defn adder [a1 a2 sum] 78 | (let [process-new-value (fn [] 79 | (cond 80 | (and 81 | (has-value? a1) 82 | (has-value? a2)) (set-value! sum (+ (get-value a1) (get-value a2)) me) 83 | (and 84 | (has-value? a1) 85 | (has-value? sum)) (set-value! a2 (- (get-value sum) (get-value a1)) me) 86 | (and 87 | (has-value? a2) 88 | (has-value? sum)) (set-value! a1 (- (get-value sum) (get-value a2)) me))) 89 | 90 | process-forget-value (fn [] 91 | (forget-value! sum me) 92 | (forget-value! a1 me) 93 | (forget-value! a2 me) 94 | (process-new-value)) 95 | 96 | me (fn [request] 97 | (condp = request 98 | 'I-have-a-value (process-new-value) 99 | 'I-lost-my-value (process-forget-value) 100 | (error "Unknown request -- ADDER" request)))] 101 | 102 | (connect a1 me) 103 | (connect a2 me) 104 | (connect sum me) 105 | me)) 106 | 107 | (defn multiplier [m1 m2 product] 108 | (let [process-new-value (fn [] 109 | (cond 110 | (or (and 111 | (has-value? m1) 112 | (= (get-value m1) 0)) 113 | (and 114 | (has-value? m2) 115 | (= (get-value m2) 0))) (set-value! product 0 me) 116 | (and 117 | (has-value? m1) 118 | (has-value? m2)) (set-value! product (* (get-value m1) (get-value m2)) me) 119 | (and 120 | (has-value? m1) 121 | (has-value? product)) (set-value! m2 (/ (get-value product) (get-value m1)) me) 122 | (and 123 | (has-value? m2) 124 | (has-value? product)) (set-value! m1 (/ (get-value product) (get-value m2)) me))) 125 | 126 | process-forget-value (fn [] 127 | (forget-value! product me) 128 | (forget-value! m1 me) 129 | (forget-value! m2 me) 130 | (process-new-value)) 131 | 132 | me (fn [request] 133 | (condp = request 134 | 'I-have-a-value (process-new-value) 135 | 'I-lost-my-value (process-forget-value) 136 | (error "Unknown request -- MULTIPLIER" request)))] 137 | 138 | (connect m1 me) 139 | (connect m2 me) 140 | (connect product me) 141 | me)) 142 | 143 | (defn constant [value connector] 144 | (let [me (fn [request] 145 | (error "Unknown request -- CONSTANT" request))] 146 | 147 | (connect connector me) 148 | (set-value! connector value me) 149 | me)) 150 | 151 | (defn probe [name connector] 152 | (let [print-probe (fn [value] 153 | (println-str "Probe:" name "=" value)) 154 | 155 | process-new-value (fn [] 156 | (print-probe (get-value connector))) 157 | 158 | process-forget-value (fn [] 159 | (print-probe "?")) 160 | 161 | me (fn [request] 162 | (condp = request 163 | 'I-have-a-value (process-new-value) 164 | 'I-lost-my-value (process-forget-value) 165 | (error "Unknown request -- PROBE" request)))] 166 | 167 | (connect connector me) 168 | me)) 169 | 170 | (defn inform-about-value [constraint] 171 | (constraint 'I-have-a-value)) 172 | 173 | (defn inform-about-no-value [constraint] 174 | (constraint 'I-lost-my-value)) 175 | 176 | ;; 177 | 178 | 179 | ;; 180 | 181 | (defn celsius-fahrenheit-converter [c f] 182 | (let [u (make-connector) 183 | v (make-connector) 184 | w (make-connector) 185 | x (make-connector) 186 | y (make-connector)] 187 | (multiplier c w u) 188 | (multiplier v x u) 189 | (adder v y f) 190 | (constant 9 w) 191 | (constant 5 x) 192 | (constant 32 y) 193 | 'ok)) 194 | 195 | (def C (make-connector)) 196 | 197 | (def F (make-connector)) 198 | 199 | (celsius-fahrenheit-converter C F) 200 | 201 | (probe "Celsius temp" C) 202 | 203 | (probe "Fahrenheit temp" F) 204 | 205 | (set-value! C 25 'user) 206 | 207 | (forget-value! C 'user) 208 | 209 | (set-value! F 212 'user) 210 | -------------------------------------------------------------------------------- /test/sicp/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/frankiesardo/sicp-in-clojure/dc341617c2ab8eb34ac316175a56141a0c605421/test/sicp/.DS_Store -------------------------------------------------------------------------------- /test/sicp/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns sicp.core-test 2 | (:require [clojure.test :refer :all] 3 | [sicp.core :refer :all])) 4 | 5 | (deftest a-test 6 | (testing "FIXME, I fail." 7 | (is (= 0 1)))) 8 | --------------------------------------------------------------------------------