├── .gitignore ├── chapters ├── 1 │ ├── 1.2.2 │ │ ├── count-coin-change.hs │ │ └── count-coin-change.clj │ ├── 1.2.6 │ │ ├── smallest-divisor.clj │ │ └── smallest-divisor.hs │ └── 1.3.1 │ │ └── sum.clj ├── 2 │ ├── 2.3.4 │ │ └── huffman-tree.clj │ ├── 2.3.3 │ │ ├── set-as-binary-tree.clj │ │ ├── set-as-ordered-list.clj │ │ └── set-as-unordered-list.clj │ ├── 2.1.3 │ │ ├── pair-as-list.clj │ │ └── pair-as-closure.clj │ ├── 2.1.1 │ │ └── rationals.clj │ ├── 2.1.2 │ │ └── rationals-with-simplification.clj │ ├── 2.1.4 │ │ └── intervals.clj │ └── 2.3.2 │ │ └── deriv.clj ├── 3 │ ├── 3.1.1 │ │ ├── 3.1-accumulator.clj │ │ ├── 3.2-make-monitored.clj │ │ ├── account.clj │ │ ├── 3.4-safe-account-with-cops.clj │ │ ├── full-account.clj │ │ └── 3.3-safe-account.clj │ ├── 3.3.2 │ │ ├── 3.27-memoize.clj │ │ ├── queue.clj │ │ └── 3.23-dequeue.clj │ ├── 3.5.2 │ │ └── infinite-streams.clj │ ├── 3.5.5 │ │ └── monte-carlo.clj │ └── 3.3.4 │ │ └── electronic-circuit.clj ├── 4 │ ├── 4.4.4 │ │ └── logic-example │ │ │ ├── .gitignore │ │ │ ├── project.clj │ │ │ └── src │ │ │ └── logic_example │ │ │ └── core.clj │ ├── 4.2.2 │ │ └── laziness-example.clj │ ├── 4.1.1 │ │ ├── eval-apply-examples-in-clojure.clj │ │ └── eval-apply.clj │ └── 4.3.3 │ │ └── amb-example.clj └── 5 │ ├── 5.1.2 │ └── abstraction.clj │ ├── 5.1.3 │ └── subroutines.clj │ ├── 5.2.2 │ └── assembler.clj │ ├── 5.2.1 │ └── machine-model.clj │ ├── 5.1.1 │ └── register-machines-dsl.clj │ ├── 5.1.4 │ └── stack-based-recursion.clj │ ├── 5.5.1 │ └── compiler-structure.clj │ └── 5.4.2 │ └── sequences-and-tail-recursion.clj ├── README.md └── License - MIT.md /.gitignore: -------------------------------------------------------------------------------- 1 | /**/*.hi 2 | /**/*.o -------------------------------------------------------------------------------- /chapters/2/2.3.4/huffman-tree.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.1.2/abstraction.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.1.3/subroutines.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.2.2/assembler.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.2.1/machine-model.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/2/2.3.3/set-as-binary-tree.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/2/2.3.3/set-as-ordered-list.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.1.1/register-machines-dsl.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.1.4/stack-based-recursion.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.5.1/compiler-structure.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/5/5.4.2/sequences-and-tail-recursion.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /chapters/4/4.4.4/logic-example/.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | 5 | pom.xml 6 | pom.xml.asc 7 | 8 | *.jar 9 | *.class 10 | 11 | /.lein-* 12 | 13 | /.nrepl-port 14 | -------------------------------------------------------------------------------- /chapters/4/4.4.4/logic-example/project.clj: -------------------------------------------------------------------------------- 1 | (defproject logic-example "0.0.1-SNAPSHOT" 2 | :dependencies [[org.clojure/clojure "1.7.0"] 3 | [org.clojure/core.logic "0.8.10"]]) 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sicp-examples 2 | 3 | Examples from *Structure and Interpretation of Computer Programs* by H. Abelson, G. J. Sussman and J. Sussman in different languages: 4 | 5 | - Clojure 6 | - Haskell 7 | -------------------------------------------------------------------------------- /chapters/1/1.2.2/count-coin-change.hs: -------------------------------------------------------------------------------- 1 | count 0 _ = 1 2 | count _ [] = 0 3 | count x (c : coins) = sum [ count (x - (n * c)) coins | n <- [ 0 .. (quot x c) ] ] 4 | 5 | main = print (count 100 [ 1, 5, 10, 25, 50 ]) 6 | -------------------------------------------------------------------------------- /chapters/3/3.1.1/3.1-accumulator.clj: -------------------------------------------------------------------------------- 1 | (defn make-accumulator [start] 2 | (let [acc (atom start)] 3 | (fn [x] 4 | (swap! acc + x)))) 5 | 6 | (def A (make-accumulator 5)) 7 | 8 | (println "Accumulator:" (A 10)) 9 | (println "Accumulator:" (A 10)) 10 | -------------------------------------------------------------------------------- /chapters/4/4.2.2/laziness-example.clj: -------------------------------------------------------------------------------- 1 | (import java.util.UUID) 2 | 3 | (defn uuid-seq [] 4 | (lazy-seq (cons (str (UUID/randomUUID)) 5 | (uuid-seq)))) 6 | 7 | (println (take 3 (uuid-seq))) 8 | 9 | (println (str (clojure.string/join (take 5 (repeat "Na "))) "Batman!")) 10 | (println (repeatedly 5 #(rand-int 100))) 11 | 12 | (println (take 5 (cycle [1 2 3]))) 13 | (println (take 5 (iterate (partial * 3) 1))) 14 | -------------------------------------------------------------------------------- /chapters/1/1.2.6/smallest-divisor.clj: -------------------------------------------------------------------------------- 1 | (defn divides? [ a b ] 2 | (= (rem b a) 0)) 3 | 4 | (defn find-divisor [ n test-divisor ] 5 | (cond (> (* test-divisor test-divisor) n) n 6 | (divides? test-divisor n) test-divisor 7 | :else (find-divisor n (+ test-divisor 1)))) 8 | 9 | (defn smallest-divisor [ n ] 10 | (find-divisor n 2)) 11 | 12 | (defn prime? [ n ] 13 | (= n (smallest-divisor n))) 14 | 15 | (println (prime? 4)) 16 | (println (prime? 3)) -------------------------------------------------------------------------------- /chapters/2/2.1.3/pair-as-list.clj: -------------------------------------------------------------------------------- 1 | ;; Pair represented as a list. 2 | ;; 3 | ;; We are returning list, which 4 | ;; has only 2 elements 5 | ;; 6 | ;; As in the previous case, 7 | ;; this is a constructor. 8 | 9 | (defn cons [x y] 10 | (list x y)) 11 | 12 | ;; In that case, following 13 | ;; functions are selectors. 14 | 15 | (defn car [z] (nth z 0)) 16 | (defn cdr [z] (nth z 1)) 17 | 18 | (println (car (cons 1 2))) ;; 1 19 | (println (cdr (cons 1 2))) ;; 2 20 | -------------------------------------------------------------------------------- /chapters/1/1.2.6/smallest-divisor.hs: -------------------------------------------------------------------------------- 1 | square :: (Num a) => a -> a 2 | square n = n * n 3 | 4 | isDivisor :: (Integral a) => a -> a -> Bool 5 | isDivisor a b = b `mod` a == 0 6 | 7 | findDivisor :: (Integral a) => a -> a -> a 8 | findDivisor divisor n 9 | | square divisor > n = n 10 | | isDivisor divisor n = divisor 11 | | otherwise = findDivisor (divisor + 1) n 12 | 13 | smallestDivisor :: (Integral a) => a -> a 14 | smallestDivisor = findDivisor 2 15 | 16 | prime :: (Integral a) => a -> Bool 17 | prime n = n == smallestDivisor n 18 | 19 | no = prime 4 20 | yes = prime 3 -------------------------------------------------------------------------------- /chapters/1/1.2.2/count-coin-change.clj: -------------------------------------------------------------------------------- 1 | (defn first-denomization [ kinds-of-coins ] 2 | (condp = kinds-of-coins 3 | 1 1 4 | 2 5 5 | 3 10 6 | 4 25 7 | 5 50)) 8 | 9 | (defn cc [ amount kinds-of-coins ] 10 | (cond (= amount 0) 1 11 | (or (< amount 0) (= kinds-of-coins 0)) 0 12 | :else (+ (cc amount 13 | (- kinds-of-coins 1)) 14 | (cc (- amount 15 | (first-denomization kinds-of-coins)) 16 | kinds-of-coins)))) 17 | 18 | (defn count-change [ amount ] 19 | (cc amount 5)) 20 | 21 | (println (count-change 100)) 22 | -------------------------------------------------------------------------------- /chapters/3/3.3.2/3.27-memoize.clj: -------------------------------------------------------------------------------- 1 | ;; Memoization technique. 2 | 3 | (defn memoizer [f] 4 | (let [table (atom {})] 5 | (fn [x] 6 | (let [previous (get table x)] 7 | (if (nil? previous) 8 | (let [result (f x)] 9 | (swap! table assoc x result) 10 | result) 11 | previous))))) 12 | 13 | ;; Fibonacci sequence. 14 | 15 | (defn fib [n] 16 | (condp = n 17 | 0 0 18 | 1 1 19 | (+ (fib (- n 1)) 20 | (fib (- n 2))))) 21 | 22 | (def memoized-fib (memoizer fib)) 23 | 24 | (println (fib 10)) 25 | (println (memoized-fib 10)) 26 | 27 | (time (fib 35)) 28 | (time (memoized-fib 35)) 29 | -------------------------------------------------------------------------------- /chapters/4/4.1.1/eval-apply-examples-in-clojure.clj: -------------------------------------------------------------------------------- 1 | ;; You can either evaluate quoted expressions 2 | ;; or strings, but keep in mind that string 3 | ;; does not have an AST-like structure by itself. 4 | ;; It needs to be parsed first (with a 5 | ;; `read-string`). 6 | 7 | (eval '(let [a 10] (+ 3 4 a))) 8 | (eval (read-string "(+ 1 1)")) 9 | 10 | ;; Result of executing both expressions is 11 | ;; exactly the same, but only the first one 12 | ;; is an application. 13 | ;; 14 | ;; Function application means that you have to 15 | ;; deliver all arguments upfront in a form of 16 | ;; collection. 17 | 18 | (apply str ["str1" "str2" "str3"]) 19 | (str "str1" "str2" "str3") 20 | -------------------------------------------------------------------------------- /chapters/2/2.1.3/pair-as-closure.clj: -------------------------------------------------------------------------------- 1 | ;; Pair represented as a closure. 2 | ;; 3 | ;; We are returning new function, which 4 | ;; accepts only 0 or 1 as an index value. 5 | ;; 6 | ;; This is a constructor which is first part 7 | ;; of our barrier. 8 | 9 | (defn cons [x y] 10 | (fn [m] 11 | (cond (= m 0) x 12 | (= m 1) y 13 | :else (assert (or (= m 1) (= m 0)) "Argument should be 0 or 1.")))) 14 | 15 | ;; Those functions are selectors, second 16 | ;; part of our barrier. 17 | 18 | (defn car [z] (z 0)) 19 | (defn cdr [z] (z 1)) 20 | 21 | (println (car (cons 1 2))) ;; 1 22 | (println (cdr (cons 1 2))) ;; 2 23 | 24 | (println ((cons 1 2) 3)) ;; 2 25 | -------------------------------------------------------------------------------- /chapters/1/1.3.1/sum.clj: -------------------------------------------------------------------------------- 1 | (defn sum [ term a next b ] 2 | (if (> a b) 3 | 0 4 | (+ (term a) 5 | (sum term (next a) next b)))) 6 | 7 | (defn cube [ n ] 8 | (* n n n)) 9 | 10 | (defn incr [ n ] 11 | (+ n 1)) 12 | 13 | (defn sum-cubes [ a b ] 14 | (sum cube a incr b)) 15 | 16 | (println (sum-cubes 1 10)) 17 | 18 | (defn pi-sum [ a b ] 19 | (letfn [ (pi-term [ x ] (/ 1.0 (* x (+ x 2)))) 20 | (pi-next [ x ] (+ x 4)) ] 21 | (sum pi-term a pi-next b))) 22 | 23 | (println (* 8 (pi-sum 1 1000))) 24 | 25 | (defn integral [ f a b dx ] 26 | (letfn [ (add-dx [ x ] (+ x dx)) ] 27 | (* (sum f (+ a (/ dx 2.0)) add-dx b) dx))) 28 | 29 | (println (integral cube 0 1 0.001)) 30 | -------------------------------------------------------------------------------- /chapters/3/3.1.1/3.2-make-monitored.clj: -------------------------------------------------------------------------------- 1 | (defn make-monitored [f] 2 | (let [counter (atom 0)] 3 | (fn [arg] 4 | (condp = arg 5 | 'reset-count (reset! counter 0) 6 | 'how-many-calls? @counter 7 | (do (swap! counter inc) (f arg)))))) 8 | 9 | ;; Unfortunately you cannot pass directly 10 | ;; Java method here, even a static one. 11 | ;; 12 | ;; You need to wrap it in a Clojure 13 | ;; function first. 14 | 15 | (def sqrt (make-monitored (fn [x] (Math/sqrt x)))) 16 | 17 | (println (sqrt 100)) 18 | (println (sqrt 'how-many-calls?)) 19 | (println (sqrt 25)) 20 | (println (sqrt 'how-many-calls?)) 21 | (println (sqrt 'reset-count)) 22 | (println (sqrt 'how-many-calls?)) 23 | -------------------------------------------------------------------------------- /chapters/3/3.1.1/account.clj: -------------------------------------------------------------------------------- 1 | (defn make-withdraw [starting-balance] 2 | (let [balance (atom starting-balance)] 3 | (fn [amount] 4 | (if (>= @balance amount) 5 | (swap! balance - amount) 6 | "Not enough money!")))) 7 | 8 | (def withdraw-from-account-1 (make-withdraw 100)) 9 | (def withdraw-from-account-2 (make-withdraw 100)) 10 | 11 | (def operations-on-account-1 [10 10 10 10 60 10 10 20 10]) 12 | (def operations-on-account-2 [101 10 60]) 13 | 14 | (doseq [op operations-on-account-1] 15 | (println (str "Account 1 (-" op "):") (withdraw-from-account-1 op))) 16 | 17 | (doseq [op operations-on-account-2] 18 | (println (str "Account 2 (-" op "):") (withdraw-from-account-2 op))) 19 | -------------------------------------------------------------------------------- /chapters/3/3.1.1/3.4-safe-account-with-cops.clj: -------------------------------------------------------------------------------- 1 | (def max-violations 7) 2 | 3 | (defn call-the-cops [] 4 | (assert false "Drop the gun! You are under arrest!")) 5 | 6 | (defn make-account [starting-balance secret] 7 | (let [balance (atom starting-balance) 8 | violation-counter (atom 0)] 9 | 10 | (letfn [(withdraw [amount] (if (>= @balance amount) (swap! balance - amount) "Not enough money!")) 11 | (deposit [amount] (swap! balance + amount))] 12 | 13 | (fn [password operation amount] 14 | (if (= password secret) 15 | (condp = operation 16 | 'withdraw (withdraw amount) 17 | 'deposit (deposit amount) 18 | (assert false (str "Unexpected operation:" operation))) 19 | 20 | (if (>= @violation-counter max-violations) 21 | (call-the-cops) 22 | (do (swap! violation-counter + 1) "Unauthorized access!"))))))) 23 | 24 | (def account (make-account 100 "admin1")) 25 | 26 | (doseq [i (range 1 10)] 27 | (println (str "Account (-" i " $):") (account "nope" 'withdraw i))) 28 | -------------------------------------------------------------------------------- /chapters/3/3.1.1/full-account.clj: -------------------------------------------------------------------------------- 1 | (defn make-account [starting-balance] 2 | (let [balance (atom starting-balance)] 3 | 4 | (letfn [(withdraw [amount] (if (>= @balance amount) (swap! balance - amount) "Not enough money!")) 5 | (deposit [amount] (swap! balance + amount))] 6 | 7 | (fn [operation amount] 8 | (condp = operation 9 | 'withdraw (withdraw amount) 10 | 'deposit (deposit amount) 11 | (assert false (str "Unexpected operation:" operation))))))) 12 | 13 | (def account-1 (make-account 100)) 14 | (def account-2 (make-account 100)) 15 | 16 | (def operations-on-account-1 [['deposit 10] ['withdraw 10] ['withdraw 100] ['withdraw 10]]) 17 | (def operations-on-account-2 [['withdraw 101] ['deposit 10] ['withdraw 60]]) 18 | 19 | (defn op->symbol [op] 20 | (condp = op 21 | 'withdraw "-" 22 | 'deposit "+" 23 | "?")) 24 | 25 | (doseq [[op amount] operations-on-account-1] 26 | (println (str "Account 1 (" (op->symbol op) amount " $):") (account-1 op amount))) 27 | 28 | (doseq [[op amount] operations-on-account-2] 29 | (println (str "Account 2 (" (op->symbol op) amount " $):") (account-2 op amount))) 30 | -------------------------------------------------------------------------------- /License - MIT.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) Wojciech Gawroński (afronski@gmail.com) 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /chapters/2/2.1.1/rationals.clj: -------------------------------------------------------------------------------- 1 | ;; Data structure representation. 2 | 3 | (defn make-rat [n d] [n d]) 4 | 5 | (defn numer [x] (first x)) 6 | (defn denom [x] (second x)) 7 | 8 | ;; Operations. 9 | 10 | (defn print-rat [x] 11 | (println (str (numer x)) "/" (str (denom x)))) 12 | 13 | (defn add-rat [x y] 14 | (make-rat (+ (* (numer x) (denom y)) 15 | (* (numer y) (denom x))) 16 | (* (denom x) (denom y)))) 17 | 18 | (defn sub-rat [x y] 19 | (make-rat (- (* (numer x) (denom y)) 20 | (* (numer y) (denom x))) 21 | (* (denom x) (denom y)))) 22 | 23 | (defn mul-rat [x y] 24 | (make-rat (* (numer x) (numer y)) 25 | (* (denom x) (denom y)))) 26 | 27 | (defn div-rat [x y] 28 | (make-rat (* (numer x) (denom y)) 29 | (* (denom x) (numer y)))) 30 | 31 | (defn equal-rat? [x y] 32 | (= (* (numer x) (denom y)) 33 | (* (numer y) (denom x)))) 34 | 35 | ;; Constants. 36 | 37 | (def one-half (make-rat 1 2)) 38 | (def one-third (make-rat 1 3)) 39 | (def two-thirds (make-rat 2 3)) 40 | (def three-fourths (make-rat 3 4)) 41 | 42 | ;; Main flow. 43 | 44 | (print-rat one-half) 45 | (print-rat (add-rat one-half one-third)) 46 | (print-rat (mul-rat one-half one-third)) 47 | (print-rat (add-rat one-third one-third)) 48 | -------------------------------------------------------------------------------- /chapters/3/3.1.1/3.3-safe-account.clj: -------------------------------------------------------------------------------- 1 | (defn make-account [starting-balance secret] 2 | (let [balance (atom starting-balance)] 3 | 4 | (letfn [(withdraw [amount] (if (>= @balance amount) (swap! balance - amount) "Not enough money!")) 5 | (deposit [amount] (swap! balance + amount))] 6 | 7 | (fn [password operation amount] 8 | (if (= password secret) 9 | (condp = operation 10 | 'withdraw (withdraw amount) 11 | 'deposit (deposit amount) 12 | (assert false (str "Unexpected operation:" operation))) 13 | "Unauthorized access!" 14 | ))))) 15 | 16 | (def account-1 (make-account 100 "admin1")) 17 | (def account-2 (make-account 100 "qwerty")) 18 | 19 | (def operations-on-account-1 [["admin1" 'deposit 10] ["admin1" 'withdraw 10] ["admin1" 'withdraw 100] ["oops" 'withdraw 10]]) 20 | (def operations-on-account-2 [["qwerty" 'withdraw 101] ["yikes" 'deposit 10] ["qwerty" 'withdraw 60]]) 21 | 22 | (defn op->symbol [op] 23 | (condp = op 24 | 'withdraw "-" 25 | 'deposit "+" 26 | "?")) 27 | 28 | (doseq [[pass op amount] operations-on-account-1] 29 | (println (str "Account 1 (" (op->symbol op) amount " $):") (account-1 pass op amount))) 30 | 31 | (doseq [[pass op amount] operations-on-account-2] 32 | (println (str "Account 2 (" (op->symbol op) amount " $):") (account-2 pass op amount))) 33 | -------------------------------------------------------------------------------- /chapters/2/2.1.2/rationals-with-simplification.clj: -------------------------------------------------------------------------------- 1 | (defn gcd [a b] 2 | (if (zero? b) 3 | a 4 | (recur b (mod a b)))) 5 | 6 | (defn make-rat [n d] [n d]) 7 | 8 | (defn numer [x] 9 | (let [g (gcd (first x) (second x))] 10 | (/ (first x) g))) 11 | 12 | (defn denom [x] 13 | (let [g (gcd (first x) (second x))] 14 | (/ (second x) g))) 15 | 16 | (defn print-rat [x] 17 | (println (str (numer x)) "/" (str (denom x)))) 18 | 19 | (defn add-rat [x y] 20 | (make-rat (+ (* (numer x) (denom y)) 21 | (* (numer y) (denom x))) 22 | (* (denom x) (denom y)))) 23 | 24 | (defn sub-rat [x y] 25 | (make-rat (- (* (numer x) (denom y)) 26 | (* (numer y) (denom x))) 27 | (* (denom x) (denom y)))) 28 | 29 | (defn mul-rat [x y] 30 | (make-rat (* (numer x) (numer y)) 31 | (* (denom x) (denom y)))) 32 | 33 | (defn div-rat [x y] 34 | (make-rat (* (numer x) (denom y)) 35 | (* (denom x) (numer y)))) 36 | 37 | (defn equal-rat? [x y] 38 | (= (* (numer x) (denom y)) 39 | (* (numer y) (denom x)))) 40 | 41 | (def one-half (make-rat 1 2)) 42 | (def one-third (make-rat 1 3)) 43 | (def two-thirds (make-rat 2 3)) 44 | (def three-fourths (make-rat 3 4)) 45 | 46 | ;; Main flow. 47 | 48 | (print-rat one-half) 49 | (print-rat (add-rat one-half one-third)) 50 | (print-rat (mul-rat one-half one-third)) 51 | (print-rat (add-rat one-third one-third)) 52 | -------------------------------------------------------------------------------- /chapters/3/3.5.2/infinite-streams.clj: -------------------------------------------------------------------------------- 1 | ;; Representing infinite stream of numbers with lazy sequences in clojure. 2 | ;; Thanks to the `lazy-seq` macro, we are not evaluating whole expression 3 | ;; but we are deferring execution until it is necessary. 4 | ;; 5 | ;; Thanks to that in examples below we are calculating only 10 numbers 6 | ;; from an infinite stream. 7 | ;; 8 | ;; One more remark - it is not necessary to create `delay` and `force` 9 | ;; because Clojure already has facilities for that (`lazy-seq` is only 10 | ;; an example - I have in mind e.g. `promise` and `future`). 11 | 12 | (defn integers-from [n] 13 | (cons n (lazy-seq (integers-from (inc n))))) 14 | 15 | (def integers (integers-from 1)) 16 | 17 | (defn divisible? [x y] 18 | (= (rem x y) 0)) 19 | 20 | (defn no-sevens [] 21 | (filter #(not (divisible? % 7)) integers)) 22 | 23 | (println (take 10 integers)) 24 | (println (take 10 (no-sevens))) 25 | 26 | ;; Infinite stream of Fibonacci numbers. 27 | 28 | (defn fib [a b] 29 | (cons a (lazy-seq (fib b (+ a b))))) 30 | 31 | (println (take 10 (fib 0 1))) 32 | 33 | ;; Algorithm of Eratosthenes Sieve. 34 | 35 | (defn sieve [stream] 36 | (cons (first stream) 37 | (lazy-seq (sieve (filter #(not (divisible? % (first stream))) 38 | (rest stream)))))) 39 | 40 | ;; Infinite stream of prime numbers. 41 | 42 | (def primes (sieve (integers-from 2))) 43 | 44 | (println (take 10 primes)) 45 | -------------------------------------------------------------------------------- /chapters/3/3.5.5/monte-carlo.clj: -------------------------------------------------------------------------------- 1 | ;; GCD. 2 | 3 | (defn gcd [a b] 4 | (if (zero? b) 5 | a 6 | (recur b (mod a b)))) 7 | 8 | ;; Square Root. 9 | 10 | (defn sqrt [n] (Math/sqrt n)) 11 | 12 | ;; Random Number Generator represented as a computational object 13 | ;; with local, mutable and independent state (that is why we used 14 | ;; atoms here). 15 | 16 | (defn random [] 17 | (let [x (atom (rand-int 1000000000))] 18 | (fn [] (reset! x (rand-int 1000000000))))) 19 | 20 | ;; Stream (infinite sequence) of random numbers. 21 | 22 | (def random-numbers 23 | (repeatedly #((random)))) 24 | 25 | ;; Monte Carlo method. 26 | 27 | (defn monte-carlo [experiment-as-stream passed failed] 28 | (letfn [(next [passed failed] 29 | (cons (/ passed (+ passed failed)) 30 | (lazy-seq (monte-carlo (rest experiment-as-stream) 31 | passed 32 | failed))))] 33 | (if (first experiment-as-stream) 34 | (next (inc passed) failed) 35 | (next passed (inc failed))))) 36 | 37 | ;; Experiment - approximating `pi` with Caesaro test. 38 | ;; Stream (infinite sequence) of coprime numbers. 39 | 40 | (defn map-successive-pairs [f stream] 41 | (cons (f (first stream) (first (rest stream))) 42 | (lazy-seq (map-successive-pairs f (rest (rest stream)))))) 43 | 44 | (def caesaro-stream 45 | (map-successive-pairs #(= (gcd %1 %2) 1) random-numbers)) 46 | 47 | (def pi 48 | (map #(sqrt (/ 6.0 %)) 49 | (monte-carlo caesaro-stream 0 0))) 50 | 51 | (println (last (take 1000000 pi))) 52 | -------------------------------------------------------------------------------- /chapters/4/4.4.4/logic-example/src/logic_example/core.clj: -------------------------------------------------------------------------------- 1 | (ns logic-example.core 2 | (:use [clojure.core.logic.pldb])) 3 | 4 | ; In the logic programming we are creating *relations* and *facts*. 5 | ; Relation describes how to interpret *facts*, with certain associations. 6 | 7 | (db-rel father Father Child) 8 | (db-rel mother Mother Child) 9 | 10 | ; *Facts* are the truths, nothing more than a specific data structure 11 | ; which describes our state of knowledge. 12 | 13 | (def genealogy 14 | (db 15 | [father 'Adam 'Wiliam] 16 | [father 'Adam 'Thomas] 17 | [father 'Andrew 'Jessica] 18 | [father 'Andrew 'Mark] 19 | ; We are deliberately omitting Dorothy's father here. 20 | 21 | [mother 'Eve 'Wiliam] 22 | [mother 'Eve 'Thomas] 23 | [mother 'Eve 'Jessica] 24 | [mother 'Angie 'Mark] 25 | [mother 'Angie 'Dorothy])) 26 | 27 | ; Having *facts* and *relations* we can query them and thanks to them 28 | ; `unification` mechanism, based on defined relations and facts available 29 | ; in the database our logic engine will answer to that query with one, 30 | ; more or no results. 31 | 32 | (defn jessica-mother[] 33 | (with-db genealogy 34 | (run* [q] 35 | (mother q 'Jessica)))) 36 | 37 | ; user=> (logic-example.core/jessica-mother) 38 | ; (Eve) 39 | 40 | (defn adam-children [] 41 | (with-db genealogy 42 | (run* [q] 43 | (father 'Adam q)))) 44 | 45 | ; user=> (logic-example.core/dorothy-father) 46 | ; (Thomas Wiliam) 47 | 48 | (defn dorothy-father [] 49 | (with-db genealogy 50 | (run* [q] 51 | (father q 'Dorothy)))) 52 | 53 | ; user=> (logic-example.core/dorothy-father) 54 | ; () 55 | -------------------------------------------------------------------------------- /chapters/4/4.3.3/amb-example.clj: -------------------------------------------------------------------------------- 1 | ; Both `amb-let` and `amb-let-helper` implementations 2 | ; are shamelessly taken from: 3 | ; https://github.com/abeppu/toychest 4 | 5 | (defn amb-let-helper [bindings body] 6 | (if (< 0 (count bindings)) 7 | (let [[form expression] (take 2 bindings) 8 | more-bindings (drop 2 bindings) 9 | 10 | filtered-recurse (if (= :where (first more-bindings)) 11 | `(when ~(second more-bindings) 12 | ~(amb-let-helper (drop 2 more-bindings) body)) 13 | (amb-let-helper more-bindings body)) 14 | 15 | res (if (and (seq? expression) 16 | (= 'amb (first expression))) 17 | `(apply concat (for [~form ~(second expression)] 18 | ~filtered-recurse)) 19 | `(let [~form ~expression] 20 | ~filtered-recurse))] 21 | res) 22 | [body])) 23 | 24 | ; Macro definition. 25 | 26 | (defmacro amb-let [bindings body] 27 | (amb-let-helper bindings body)) 28 | 29 | ; Defining problem and its constraints. 30 | ; We would like to calculate all triples in range 100 that 31 | ; fullfilling following conditions: 32 | ; 33 | ; 2 < a < MAX 34 | ; a <= b < MAX 35 | ; b <= c < MAX 36 | ; 37 | ; a^2 + b^2 = c^2 38 | 39 | (defn triple [max] 40 | (amb-let [a (amb (range 1 max)) :where (> a 2) 41 | b (amb (range a max)) 42 | c (amb (range b max)) 43 | 44 | :where (= (+ (* a a) (* b b)) 45 | (* c c))] 46 | [a b c])) 47 | 48 | (println (triple 20)) 49 | -------------------------------------------------------------------------------- /chapters/2/2.3.3/set-as-unordered-list.clj: -------------------------------------------------------------------------------- 1 | ;; Constructors. 2 | 3 | (defn create-set [] (list)) 4 | 5 | ;; Operations. 6 | 7 | (defn element-of-set? [x set] 8 | (if (empty? set) false (boolean (some #(= x %) set)))) 9 | 10 | (defn adjoin-set [x set] 11 | (if (element-of-set? x set) set (conj set x))) 12 | 13 | (defn intersection-set [set1 set2] 14 | (letfn [(intersection-set-internal [set1 set2 result] 15 | (cond (or (empty? set1) (empty? set2)) result 16 | (element-of-set? (first set1) set2) (recur (rest set1) set2 (conj result (first set1))) 17 | :else (recur (rest set1) set2 result)))] 18 | (intersection-set-internal set1 set2 (create-set)))) 19 | 20 | ;; Exercise 2.59 21 | (defn union-set [set1 set2] 22 | (letfn [(union-set-internal [set result] 23 | (cond (empty? set) result 24 | (element-of-set? (first set) result) (recur (rest set) result) 25 | :else (recur (rest set) (conj result (first set)))))] 26 | (let [after-first (union-set-internal set1 (create-set))] 27 | (union-set-internal set2 after-first)))) 28 | 29 | ;; Main flow. 30 | 31 | (def basic-set (adjoin-set 1 (adjoin-set 2 (adjoin-set 4 (adjoin-set 5 (create-set)))))) 32 | (def another-set (adjoin-set 2 (adjoin-set 1 (create-set)))) 33 | 34 | (println "Set:" basic-set) 35 | 36 | (println "Contains 2:" (element-of-set? 2 basic-set)) 37 | (println "Contains 3:" (element-of-set? 3 basic-set)) 38 | 39 | (println "Sets intersection:" (intersection-set basic-set another-set)) 40 | (println "Sets intersection:" (intersection-set another-set basic-set)) 41 | 42 | (println "Sets union:" (union-set another-set basic-set)) 43 | (println "Sets union:" (union-set (adjoin-set 3 (create-set)) basic-set)) 44 | -------------------------------------------------------------------------------- /chapters/3/3.3.2/queue.clj: -------------------------------------------------------------------------------- 1 | ;; Constructors. 2 | 3 | (defn make-element [e next] 4 | (atom [e next])) 5 | 6 | (defn make-queue [] 7 | (atom [nil nil])) 8 | 9 | ;; Helpers. 10 | 11 | (defn value [e] (first @e)) 12 | (defn next-element [e] (second @e)) 13 | 14 | (defn front [q] (first @q)) 15 | (defn rear [q] (second @q)) 16 | 17 | (defn serialize-element [e] 18 | (str (value e) " <- ")) 19 | 20 | (defn print-queue [q] 21 | (letfn [(print-element [e] 22 | (if (nil? e) 23 | (print "END") 24 | (do (print (serialize-element e)) 25 | (recur (next-element e)))))] 26 | (print-element (front q)) 27 | (print "\n"))) 28 | 29 | (defn set-front-ptr! [q f] 30 | (reset! q [f (rear q)])) 31 | 32 | (defn set-rear-ptr! [q r] 33 | (reset! q [(front q) r])) 34 | 35 | (defn change-next [e n] 36 | (reset! e [(value e) n])) 37 | 38 | ;; Selectors. 39 | 40 | (defn empty-queue? [q] 41 | (nil? (front q))) 42 | 43 | (defn front-queue [q] 44 | (if (empty-queue? q) 45 | (assert false "Trying to get front of an empty queue.") 46 | (value (front q)))) 47 | 48 | ;; Modifiers. 49 | 50 | (defn insert-queue! [q v] 51 | (let [new (make-element v nil)] 52 | (if (empty-queue? q) 53 | (do (set-front-ptr! q new) 54 | (set-rear-ptr! q new)) 55 | (do (change-next (rear q) new) 56 | (set-rear-ptr! q new)))) 57 | q) 58 | 59 | (defn delete-queue! [q] 60 | (if (empty-queue? q) 61 | (assert false "Deleting element from an empty queue.") 62 | (set-front-ptr! q (next-element (front q)))) 63 | q) 64 | 65 | ;; Main program. 66 | 67 | (def q1 (make-queue)) 68 | 69 | (print-queue q1) 70 | 71 | (print-queue (insert-queue! q1 1)) 72 | (print-queue (insert-queue! q1 2)) 73 | (print-queue (insert-queue! q1 3)) 74 | (print-queue (insert-queue! q1 4)) 75 | (print-queue (insert-queue! q1 5)) 76 | 77 | (print-queue (delete-queue! q1)) 78 | (print-queue (delete-queue! q1)) 79 | (print-queue (delete-queue! q1)) 80 | (print-queue (delete-queue! q1)) 81 | (print-queue (delete-queue! q1)) 82 | -------------------------------------------------------------------------------- /chapters/2/2.1.4/intervals.clj: -------------------------------------------------------------------------------- 1 | ;; Data structure. 2 | 3 | (defn make-interval [a b] [a b]) 4 | 5 | ;; Exercise 2.7 6 | (defn lower-bound [i] (first i)) 7 | (defn upper-bound [i] (second i)) 8 | 9 | ;; Operations. 10 | 11 | (defn add-interval [x y] 12 | (make-interval (+ (lower-bound x) (lower-bound y)) 13 | (+ (upper-bound x) (upper-bound y)))) 14 | 15 | ;; Exercise 2.8 16 | (defn sub-interval [x y] 17 | (make-interval (- (lower-bound x) (lower-bound y)) 18 | (- (upper-bound x) (upper-bound y)))) 19 | 20 | (defn mul-interval [x y] 21 | (let [p1 (* (lower-bound x) (lower-bound y)) 22 | p2 (* (lower-bound x) (upper-bound y)) 23 | p3 (* (upper-bound x) (lower-bound y)) 24 | p4 (* (upper-bound x) (upper-bound y))] 25 | (make-interval (min p1 p2 p3 p4) 26 | (max p1 p2 p3 p4)))) 27 | 28 | (defn div-interval [x y] 29 | (mul-interval x 30 | (make-interval (/ 1.0 (upper-bound y)) 31 | (/ 1.0 (lower-bound y))))) 32 | 33 | ;; Exercise 2.9 34 | (defn width [i] 35 | (/ (Math/abs (- (upper-bound i) (lower-bound i))) 2.0)) 36 | 37 | (defn print-interval [i] 38 | (println (str (lower-bound i)) ".." (str (upper-bound i)))) 39 | 40 | (defn print-interval-by-center-and-margin [c m] 41 | (println (str c) "+/-" (str m))) 42 | 43 | ;; Exercise 2.11 44 | (defn make-center-width [c w] 45 | (make-interval (- c w) (+ c w))) 46 | 47 | (defn center [i] 48 | (/ (+ (lower-bound i) (upper-bound i)) 2.0)) 49 | 50 | ;; Exercise 2.12 51 | (defn make-center-percent [c p] 52 | (let [w (* c (/ p 100.0))] 53 | (make-center-width c w))) 54 | 55 | (defn percent [i] 56 | (* (/ (width i) (center i)) 100.0)) 57 | 58 | ;; Constants. 59 | 60 | (def interval (make-interval 2.0 2.5)) 61 | 62 | ;; Main flow. 63 | 64 | (println (width interval)) 65 | (print-interval-by-center-and-margin (center interval) (width interval)) 66 | 67 | (print-interval (make-center-width 2.0 1.0)) 68 | 69 | (print-interval interval) 70 | (print-interval (add-interval interval (make-interval 1.0 1.5))) 71 | 72 | (print-interval (make-center-percent 100 5)) 73 | (println (percent (make-center-percent 100 5))) 74 | -------------------------------------------------------------------------------- /chapters/2/2.3.2/deriv.clj: -------------------------------------------------------------------------------- 1 | ;; Required selectors for extracting 2 | ;; data from assumed data structures. 3 | 4 | (defn car [x] (first x)) 5 | (defn cdr [x] (rest x)) 6 | (defn cadr [x] (car (cdr x))) 7 | (defn caddr [x] (car (cdr (cdr x)))) 8 | 9 | ;; In our application pair is a: 10 | ;; '(+ 1 2) 11 | 12 | (defn pair? [x] (= (count x) 3)) 13 | 14 | ;; Basic predicates. 15 | 16 | (defn variable? [x] 17 | (symbol? x)) 18 | 19 | (defn same-variable? [v1 v2] 20 | (and (variable? v1) (variable? v2) (= v1 v2))) 21 | 22 | (defn =number? [exp num] 23 | (and (number? exp) (= exp num))) 24 | 25 | ;; Custom constructors for sum and product. 26 | 27 | (defn make-sum [a1 a2] 28 | (cond (=number? a1 0) a2 29 | (=number? a2 0) a1 30 | (and (number? a1) (number? a2)) (+ a1 a2) 31 | :else (list '+ a1 a2))) 32 | 33 | (defn make-product [m1 m2] 34 | (cond (or (=number? m1 0) (=number? m2 0)) 0 35 | (=number? m1 1) m2 36 | (=number? m2 1) m1 37 | (and (number? m1) (number? m2)) (* m1 m2) 38 | :else (list '* m1 m2))) 39 | 40 | ;; Predicate which detects sum. 41 | 42 | (defn sum? [x] 43 | (and (pair? x) (= (car x) '+))) 44 | 45 | ;; Selectors for addition. 46 | 47 | (defn addend [s] 48 | (cadr s)) 49 | 50 | (defn augend [s] 51 | (caddr s)) 52 | 53 | ;; Custom predicate which detects product. 54 | 55 | (defn product? [x] 56 | (and (pair? x) (= (car x) '*))) 57 | 58 | ;; Selectors for multiplication. 59 | 60 | (defn multiplier [p] 61 | (cadr p)) 62 | 63 | (defn multiplicand [p] 64 | (caddr p)) 65 | 66 | ;; Actual algorithm for symbolic derivation. 67 | ;; Please note how declarative this approach is, 68 | ;; how recursion actually helps to handle subsequent 69 | ;; cases and where the simplification mechanism is. 70 | 71 | (defn deriv [exp var] 72 | (cond (number? exp) 73 | 0 74 | (variable? exp) 75 | (if (same-variable? exp var) 1 0) 76 | (sum? exp) 77 | (make-sum (deriv (addend exp) var) 78 | (deriv (augend exp) var)) 79 | (product? exp) 80 | (make-sum 81 | (make-product (multiplier exp) 82 | (deriv (multiplicand exp) var)) 83 | (make-product (deriv (multiplier exp) var) 84 | (multiplicand exp))) 85 | :else (assert false "Unknown expression type."))) 86 | 87 | (println (deriv '(+ x 3) 'x)) 88 | (println (deriv '(* x y) 'x)) 89 | (println (deriv '(* (* x y) (+ x 3)) 'x)) 90 | -------------------------------------------------------------------------------- /chapters/4/4.1.1/eval-apply.clj: -------------------------------------------------------------------------------- 1 | (defn list-of-values [exps env] 2 | (if (no-operands? exps) 3 | (list) 4 | (cons (my-eval (first-operand exps) env) 5 | (list-of-values (rest-operands exps) env)))) 6 | 7 | (defn my-eval-if [exp env] 8 | (if (true? (my-eval (if-predicate exp) env)) 9 | (my-eval (if-consequent exp) env) 10 | (my-eval (if-alternative exp) env))) 11 | 12 | (defn my-eval-sequence [exps env] 13 | (cond (last-exp? exps) (my-eval (first-exp exps) env) 14 | :else (do (my-eval (first-exp exps) env) 15 | (my-eval-sequence (rest-exps exps) env)))) 16 | 17 | (defn my-eval-assignment [exp env] 18 | (set-variable-value! (assignment-variable exp) 19 | (my-eval (definition-value exp) env) 20 | env) 21 | :ok) 22 | 23 | (defn my-eval-definition [exp env] 24 | (define-variable! (definition-variable exp) 25 | (my-eval (definition-value exp) env) 26 | env) 27 | :ok) 28 | 29 | (defn my-eval [exp env] 30 | (cond (self-evaluating? exp) exp 31 | (variable? exp) (lookup-variable-value exp env) 32 | (quoted? exp) (text-of-quotation exp) 33 | (assignment? exp) (my-eval-assignment exp env) 34 | (definition? exp) (my-eval-definition exp env) 35 | (if? exp) (my-eval-if exp env) 36 | (lambda? exp) (make-procedure (lambda-parameters exp) 37 | (lambda-body exp) 38 | env) 39 | (do? exp) (my-eval-sequence (do-actions exp) env) 40 | (cond? exp) (my-eval (cond->if exp) env) 41 | (application? exp) (my-apply (my-eval (operator exp) env) 42 | (list-of-values (operands exp) env)) 43 | 44 | :else (assert false "Unknown expression in `my-eval`."))) 45 | 46 | (defn my-apply [proc args] 47 | (cond (primitive-procedure? proc) (my-apply-primitive-procedure proc args) 48 | (compound-procedure? proc) (my-eval-sequence (procedure-body proc) 49 | (extend-environment (procedure-parameters proc)) 50 | args 51 | (procedure-environment proc)) 52 | 53 | :else (assert false "Unknown procedure type in `my-apply`."))) 54 | -------------------------------------------------------------------------------- /chapters/3/3.3.2/3.23-dequeue.clj: -------------------------------------------------------------------------------- 1 | ;; Constructors. 2 | 3 | (defn make-element [v prev next] 4 | (atom [v prev next])) 5 | 6 | (defn make-deque [] 7 | (atom [nil nil])) 8 | 9 | ;; Helpers. 10 | 11 | (defn value [e] (nth @e 0)) 12 | (defn prev-element [e] (nth @e 1)) 13 | (defn next-element [e] (nth @e 2)) 14 | 15 | (defn front [dq] (first @dq)) 16 | (defn rear [dq] (second @dq)) 17 | 18 | (defn serialize-element [e] 19 | (str (value e) " <-> ")) 20 | 21 | (defn print-deque [dq] 22 | (letfn [(print-element [e] 23 | (if (nil? e) 24 | (print "END") 25 | (do (print (serialize-element e)) 26 | (recur (next-element e)))))] 27 | (print "BEGIN <-> ") 28 | (print-element (front dq)) 29 | (print "\n"))) 30 | 31 | (defn reversed-print-deque [dq] 32 | (letfn [(print-element [e] 33 | (if (nil? e) 34 | (print "BEGIN") 35 | (do (print (serialize-element e)) 36 | (recur (prev-element e)))))] 37 | (print "END <-> ") 38 | (print-element (rear dq)) 39 | (print "\n"))) 40 | 41 | (defn set-front-ptr! [dq f] 42 | (reset! dq [f (rear dq)])) 43 | 44 | (defn set-rear-ptr! [dq r] 45 | (reset! dq [(front dq) r])) 46 | 47 | (defn change-next [e n] 48 | (reset! e [(value e) (prev-element e) n])) 49 | 50 | (defn change-prev [e p] 51 | (reset! e [(value e) p (next-element e)])) 52 | 53 | ;; Selectors. 54 | 55 | (defn empty-deque? [dq] 56 | (nil? (front dq))) 57 | 58 | (defn front-deque [dq] 59 | (if (empty-deque? dq) 60 | (assert false "Trying to get front of an empty deque.") 61 | (value (front dq)))) 62 | 63 | (defn rear-deque [dq] 64 | (if (empty-deque? dq) 65 | (assert false "Trying to get rear of an empty deque.") 66 | (value (rear dq)))) 67 | 68 | ;; Modifiers. 69 | 70 | (defn front-insert-deque! [dq v] 71 | (let [new (make-element v nil nil)] 72 | (if (empty-deque? dq) 73 | (do (set-front-ptr! dq new) 74 | (set-rear-ptr! dq new)) 75 | (do (change-prev (front dq) new) 76 | (change-next new (front dq)) 77 | (set-front-ptr! dq new)))) 78 | dq) 79 | 80 | (defn rear-insert-deque! [dq v] 81 | (let [new (make-element v nil nil)] 82 | (if (empty-deque? dq) 83 | (do (set-front-ptr! dq new) 84 | (set-rear-ptr! dq new)) 85 | (do (change-next (rear dq) new) 86 | (change-prev new (rear dq)) 87 | (set-rear-ptr! dq new)))) 88 | dq) 89 | 90 | (defn front-delete-deque! [dq] 91 | (if (empty-deque? dq) 92 | (assert false "Trying to delete from front of an empty deque.") 93 | (do (when-not (nil? (next-element (front dq))) 94 | (change-prev (next-element (front dq)) nil)) 95 | (if (nil? (next-element (front dq))) 96 | (do (set-rear-ptr! dq nil) 97 | (set-front-ptr! dq nil)) 98 | (set-front-ptr! dq (next-element (front dq)))))) 99 | dq) 100 | 101 | (defn rear-delete-deque! [dq] 102 | (if (empty-deque? dq) 103 | (assert false "Trying to delete from rear of an empty deque.") 104 | (do (when-not (nil? (prev-element (rear dq))) 105 | (change-next (prev-element (rear dq)) nil)) 106 | (if (nil? (prev-element (rear dq))) 107 | (do (set-rear-ptr! dq nil) 108 | (set-front-ptr! dq nil)) 109 | (set-rear-ptr! dq (prev-element (rear dq)))))) 110 | dq) 111 | 112 | ;; Main program. 113 | 114 | (def dq1 (make-deque)) 115 | 116 | (print-deque dq1) 117 | 118 | (print-deque (front-insert-deque! dq1 1)) 119 | (print-deque (front-insert-deque! dq1 2)) 120 | (print-deque (front-insert-deque! dq1 3)) 121 | 122 | (reversed-print-deque dq1) 123 | 124 | (print-deque (rear-insert-deque! dq1 -3)) 125 | (print-deque (rear-insert-deque! dq1 -2)) 126 | (print-deque (rear-insert-deque! dq1 -1)) 127 | 128 | (reversed-print-deque dq1) 129 | 130 | (print-deque (front-delete-deque! dq1)) 131 | (print-deque (rear-delete-deque! dq1)) 132 | (print-deque (front-delete-deque! dq1)) 133 | 134 | (reversed-print-deque dq1) 135 | 136 | (print-deque (rear-delete-deque! dq1)) 137 | (print-deque (front-delete-deque! dq1)) 138 | (print-deque (rear-delete-deque! dq1)) 139 | 140 | (reversed-print-deque dq1) 141 | (print-deque dq1) 142 | -------------------------------------------------------------------------------- /chapters/3/3.3.4/electronic-circuit.clj: -------------------------------------------------------------------------------- 1 | ;; Helpers. 2 | 3 | (defn invoke-all [procedures] 4 | (doall (map #(%) procedures))) 5 | 6 | ;; Signals. 7 | 8 | (defn get-signal [wire] (wire :get-signal)) 9 | (defn set-signal! [wire v] ((wire :set-signal!) v)) 10 | (defn add-action! [wire p] ((wire :add-action!) p)) 11 | 12 | ;; Wires. 13 | 14 | (defn make-wire [] 15 | (let [signal (atom false) 16 | effects (atom (list))] 17 | (letfn [(set-signal! [new] 18 | (if (not (= signal new)) 19 | (do (reset! signal new) 20 | (invoke-all @effects)) 21 | :done)) 22 | 23 | (add-action! [procedure] 24 | (swap! effects conj procedure) 25 | (procedure)) 26 | 27 | (dispatch [action] 28 | (condp = action 29 | :get-signal @signal 30 | :set-signal! set-signal! 31 | :add-action! add-action! 32 | (assert false (str "Unknown operation " action " in make-wire."))))] 33 | dispatch))) 34 | 35 | ;; Agenda. 36 | 37 | (defn make-queue [] 38 | (atom (clojure.lang.PersistentQueue/EMPTY))) 39 | 40 | (defn insert-queue! [q v] 41 | (swap! q conj v)) 42 | 43 | (defn delete-queue! [q] 44 | (swap! q pop)) 45 | 46 | (defn empty-queue? [q] 47 | (or (nil? q) 48 | (empty? @q))) 49 | 50 | (defn front-queue [q] 51 | (first @q)) 52 | 53 | (defn make-segment [time queue] 54 | (atom {:time time :queue queue})) 55 | 56 | (defn segment-time [segment] 57 | (:time @segment)) 58 | 59 | (defn segment-queue [segment] 60 | (:queue @segment)) 61 | 62 | (defn make-agenda [] 63 | (atom {:current 0 :segments nil})) 64 | 65 | (defn current-time [agenda] 66 | (:current @agenda)) 67 | 68 | (defn segments [agenda] 69 | (:segments @agenda)) 70 | 71 | (defn set-current-time! [agenda t] 72 | (swap! agenda assoc :current t)) 73 | 74 | (defn set-segments! [agenda s] 75 | (swap! agenda assoc :segments s)) 76 | 77 | (defn first-segment [agenda] 78 | (first (segments agenda))) 79 | 80 | (defn rest-segments [agenda] 81 | (rest (segments agenda))) 82 | 83 | (defn empty-agenda? [agenda] 84 | (empty? (segments agenda))) 85 | 86 | (defn add-to-agenda! [time action agenda] 87 | (letfn [(belongs-before? [slices] 88 | (or (empty? slices) 89 | (< time (segment-time (first slices))))) 90 | 91 | (make-new-time-segment [time action] 92 | (let [q (make-queue)] 93 | (insert-queue! q action) 94 | (make-segment time q))) 95 | 96 | (insert-to-segments! [slices index] 97 | (let [[before after] (split-at index slices)] 98 | (if (empty? after) 99 | (set-segments! agenda (vec (concat slices 100 | (list (make-new-time-segment time action))))) 101 | 102 | (if (= (segment-time (first after)) time) 103 | (insert-queue! (segment-queue (first after)) 104 | action) 105 | 106 | (if (belongs-before? after) 107 | (set-segments! agenda (vec (concat before 108 | (list (make-new-time-segment time action)) 109 | after))) 110 | 111 | (recur slices (inc index)))))))] 112 | (let [slices (segments agenda)] 113 | (if (belongs-before? slices) 114 | (set-segments! agenda (into [] (conj slices (make-new-time-segment time action)))) 115 | (insert-to-segments! slices 1))))) 116 | 117 | (defn remove-first-agenda-item! [agenda] 118 | (let [q (segment-queue (first-segment agenda))] 119 | (delete-queue! q) 120 | (if (empty-queue? q) 121 | (set-segments! agenda (rest-segments agenda))))) 122 | 123 | (defn first-agenda-item [agenda] 124 | (if (empty-agenda? agenda) 125 | (assert false "Getting first item from an empty agenda.") 126 | (let [nearest (first-segment agenda)] 127 | (set-current-time! agenda (segment-time nearest)) 128 | (front-queue (segment-queue nearest))))) 129 | 130 | (def the-agenda (make-agenda)) 131 | 132 | (defn step [] 133 | (if (empty-agenda? the-agenda) 134 | :done 135 | (let [first-item (first-agenda-item the-agenda)] 136 | (first-item) 137 | (remove-first-agenda-item! the-agenda) 138 | (recur)))) 139 | 140 | ;; Propagation and probes. 141 | 142 | (defn propagation [delay action] 143 | (add-to-agenda! (+ delay (current-time the-agenda)) 144 | action 145 | the-agenda)) 146 | 147 | (defn probe [name wire] 148 | (add-action! wire 149 | (fn [] (println (str name " " (current-time the-agenda) 150 | " New value = " (get-signal wire)))))) 151 | 152 | ;; Gates. 153 | 154 | (def not-gate-delay 2) 155 | (def and-gate-delay 3) 156 | (def or-gate-delay 5) 157 | 158 | (defn not-gate [input output] 159 | (letfn [(not-input [] 160 | (let [new (not (get-signal input))] 161 | (propagation not-gate-delay #(set-signal! output new))))] 162 | (add-action! input not-input) 163 | :ok)) 164 | 165 | (defn and-gate [a1 a2 output] 166 | (letfn [(and-input [] 167 | (let [new (and (get-signal a1) (get-signal a2))] 168 | (propagation and-gate-delay #(set-signal! output new))))] 169 | (add-action! a1 and-input) 170 | (add-action! a2 and-input) 171 | :ok)) 172 | 173 | ;; Exercise 3.28 174 | 175 | (defn or-gate [a1 a2 output] 176 | (letfn [(or-input [] 177 | (let [new (or (get-signal a1) (get-signal a2))] 178 | (propagation or-gate-delay #(set-signal! output new))))] 179 | (add-action! a1 or-input) 180 | (add-action! a2 or-input) 181 | :ok)) 182 | 183 | ;; Adders. 184 | 185 | (defn half-adder [a b s c] 186 | (let [d (make-wire) 187 | e (make-wire)] 188 | (or-gate a b d) 189 | (and-gate a b c) 190 | (not-gate c e) 191 | (and-gate d e s) 192 | :ok)) 193 | 194 | (defn full-adder [a b c-in sum c-out] 195 | (let [s (make-wire) 196 | c1 (make-wire) 197 | c2 (make-wire)] 198 | (half-adder b c-in s c1) 199 | (half-adder a s sum c2) 200 | (or-gate c1 c2 c-out) 201 | :ok)) 202 | 203 | ;; Simulation. 204 | 205 | (def input-1 (make-wire)) 206 | (def input-2 (make-wire)) 207 | (def sum (make-wire)) 208 | (def carry (make-wire)) 209 | 210 | (probe :sum sum) 211 | (probe :carry carry) 212 | 213 | (half-adder input-1 input-2 sum carry) 214 | 215 | (set-signal! input-1 true) 216 | (step) 217 | 218 | (set-signal! input-2 true) 219 | (step) 220 | --------------------------------------------------------------------------------