Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Adding source from ch9

  • Loading branch information...
commit ad5c469d01ea7b4aadb780f3ac1ea8106b1c7e7b 1 parent 1310b71
@fogus fogus authored
View
17 src/joy/chess.clj
@@ -35,3 +35,20 @@
index (+ f r)]
(board index)))
+
+;; fluent move example from section 9.4.2
+
+(defrecord Move [from to castle? promotion]
+ Object
+ (toString [this]
+ (str "Move " (:from this)
+ " to " (:to this)
+ (if (:castle? this) " castle"
+ (if-let [p (:promotion this)]
+ (str " promote to " p)
+ "")))))
+
+(defn build-move [& {:keys [from to castle? promotion]}]
+ {:pre [from to]}
+ (Move. from to castle? promotion))
+
View
48 src/joy/contracts.clj
@@ -0,0 +1,48 @@
+(ns joy.contracts
+ "The contracts example from chapter 8.")
+
+
+(declare collect-bodies)
+
+(defmacro defcontract
+ [& forms]
+ (let [name (if (symbol? (first forms)) ;; #1_defcontract: Check if name was supplied
+ (first forms)
+ nil)
+ body (collect-bodies (if name
+ (rest forms) ;; #3_defcontract: Process rest if so
+ forms))]
+ (list* 'fn name body))) ;; #4_defcontract: Build fn form
+
+(declare build-contract)
+
+
+(defn collect-bodies [forms]
+ (for [form (partition 3 forms)]
+ (build-contract form)))
+
+
+(defn build-contract [c]
+ (let [args (first c)] ;; #1_build-contract: Grab args
+ (list ;; #2_build-contract: Build list...
+ (into '[f] args) ;; #3_build-contract: Include HOF + args
+ (apply merge
+ (for [con (rest c)]
+ (cond (= (first con) 'require) ;; #4_build-contract: Process "requires"
+ (assoc {} :pre (vec (rest con)))
+ (= (first con) 'ensure) ;; #5_build-contract: Process "ensures"
+ (assoc {} :post (vec (rest con)))
+ :else (throw (Exception. (str "Unknown tag " (first con)))))))
+ (list* 'f args)))) ;; #6_build-contract: Build call to f
+
+
+(def doubler-contract ;; #1_contract_comp: Define a contract
+ (defcontract doubler
+ [x]
+ (require
+ (pos? x))
+ (ensure
+ (= (* 2 x) %))))
+
+(def times2 (partial doubler-contract #(* 2 %))) ;; #2_contract_comp: Test correct fn
+ ;; [compose_contract]: Composition of contract function and constrained function
View
73 src/joy/fixo.clj
@@ -0,0 +1,73 @@
+(ns joy.fixo
+ "The persistent binary tree made from records in section 9.3")
+
+(defrecord TreeNode [val l r]) ;;# Define a record type
+
+(defn xconj [t v] ;;# Add to a tree
+ (cond
+ (nil? t) (TreeNode. v nil nil)
+ (< v (:val t)) (TreeNode. (:val t) (xconj (:l t) v) (:r t))
+ :else (TreeNode. (:val t) (:l t) (xconj (:r t) v))))
+
+(defn xseq [t] ;;# Convert trees to seqs
+ (when t
+ (concat (xseq (:l t)) [(:val t)] (xseq (:r t)))))
+
+
+(defprotocol FIXO
+ (fixo-push [fixo value])
+ (fixo-pop [fixo])
+ (fixo-peek [fixo]))
+
+(extend-type TreeNode
+ FIXO
+ (fixo-push [node value]
+ (xconj node value)))
+
+(extend-type clojure.lang.IPersistentVector
+ FIXO
+ (fixo-push [vector value]
+ (conj vector value)))
+
+(extend-type nil
+ FIXO
+ (fixo-push [t v]
+ (TreeNode. v nil nil)))
+
+(extend-type TreeNode
+ FIXO
+ (fixo-push [node value] ;;# Delegate to xconj
+ (xconj node value))
+ (fixo-peek [node] ;;# Walk down left nodes to find smallest
+ (if (:l node)
+ (recur (:l node))
+ (:val node)))
+ (fixo-pop [node] ;;# Build new path down left to removed item
+ (if (:l node)
+ (TreeNode. (:val node) (fixo-pop (:l node)) (:r node))
+ (:r node))))
+
+(extend-type clojure.lang.IPersistentVector
+ FIXO
+ (fixo-push [vector value] ;;# fixo-push is vector's conj
+ (conj vector value))
+ (fixo-peek [vector] ;;# peek is peek
+ (peek vector))
+ (fixo-pop [vector] ;;# pop is pop
+ (pop vector)))
+
+(defn fixo-into [c1 c2]
+ (reduce fixo-push c1 c2))
+
+(defn fixed-fixo
+ ([limit] (fixed-fixo limit []))
+ ([limit vector]
+ (reify FIXO
+ (fixo-push [this value]
+ (if (< (count vector) limit)
+ (fixed-fixo limit (conj vector value))
+ this))
+ (fixo-peek [_]
+ (peek vector))
+ (fixo-pop [_]
+ (pop vector)))))
View
46 src/joy/macros.clj
@@ -100,49 +100,3 @@
(finally
(~close-fn ~(binding 0))))))
-;; contracts
-
-(declare collect-bodies)
-
-(defmacro defcontract
- [& forms]
- (let [name (if (symbol? (first forms)) ;; #1_defcontract: Check if name was supplied
- (first forms)
- nil)
- body (collect-bodies (if name
- (rest forms) ;; #3_defcontract: Process rest if so
- forms))]
- (list* 'fn name body))) ;; #4_defcontract: Build fn form
-
-(declare build-contract)
-
-
-(defn collect-bodies [forms]
- (for [form (partition 3 forms)]
- (build-contract form)))
-
-
-(defn build-contract [c]
- (let [args (first c)] ;; #1_build-contract: Grab args
- (list ;; #2_build-contract: Build list...
- (into '[f] args) ;; #3_build-contract: Include HOF + args
- (apply merge
- (for [con (rest c)]
- (cond (= (first con) 'require) ;; #4_build-contract: Process "requires"
- (assoc {} :pre (vec (rest con)))
- (= (first con) 'ensure) ;; #5_build-contract: Process "ensures"
- (assoc {} :post (vec (rest con)))
- :else (throw (Exception. (str "Unknown tag " (first con)))))))
- (list* 'f args)))) ;; #6_build-contract: Build call to f
-
-
-(def doubler-contract ;; #1_contract_comp: Define a contract
- (defcontract doubler
- [x]
- (require
- (pos? x))
- (ensure
- (= (* 2 x) %))))
-
-(def times2 (partial doubler-contract #(* 2 %))) ;; #2_contract_comp: Test correct fn
- ;; [compose_contract]: Composition of contract function and constrained function
View
37 src/joy/types.clj
@@ -0,0 +1,37 @@
+(ns joy.types
+ "The example of using deftype from section 9.3.3")
+
+(deftype InfiniteConstant [i]
+ clojure.lang.ISeq
+ (seq [this]
+ (lazy-seq (cons i (seq this)))))
+
+(deftype TreeNode [val l r]
+ FIXO ;;# Implement FIXO methods inline
+ (fixo-push [_ v]
+ (if (< v val)
+ (TreeNode. val (fixo-push l v) r)
+ (TreeNode. val l (fixo-push r v))))
+ (fixo-peek [_]
+ (if l
+ (fixo-peek l) ;;# Call method instead of using recur
+ val))
+ (fixo-pop [_]
+ (if l
+ (TreeNode. val (fixo-pop l) r)
+ r))
+
+ clojure.lang.IPersistentStack ;;# Implement interfaces
+ (cons [this v] (fixo-push this v))
+ (peek [this] (fixo-peek this))
+ (pop [this] (fixo-pop this))
+
+ clojure.lang.Seqable
+ (seq [t]
+ (concat (seq l) [val] (seq r))))
+
+(extend-type nil
+ FIXO
+ (fixo-push [t v]
+ (TreeNode. v nil nil))) ;;# Redefine to use new TreeNode
+
View
16 src/joy/udp.clj
@@ -0,0 +1,16 @@
+(ns joy.udp
+ "The Universal Design Pattern (UDP) example from section 9.2."
+ (:refer-clojure :exclude [get]))
+
+(defn beget [o p] (assoc o ::prototype p))
+
+(def put assoc)
+
+(defn get [m k]
+ (when m
+ (if-let [[_ v] (find m k)]
+ v
+ (recur (::prototype m) k))))
+
+(def clone (partial beget {}))
+
View
7 test/joyofclojure/test/core.clj
@@ -1,6 +1 @@
-(ns joyofclojure.test.core
- (:use [joyofclojure.core] :reload)
- (:use [clojure.test]))
-
-(deftest replace-me ;; FIXME: write
- (is false "No tests have been written."))
+(ns joyofclojure.test.core)
View
52 test/joyofclojure/test/test_udp.clj
@@ -0,0 +1,52 @@
+(ns joyofclojure.test.test-udp
+ (:use [clojure.test :only [deftest is]])
+ (:refer-clojure :exclude [get])
+ (:use joy.udp :reload))
+
+
+(def cat {:likes-dogs true, :ocd-bathing true})
+(def morris (beget {:likes-9lives true} cat))
+(def post-traumatic-morris (beget {:likes-dogs nil} morris))
+
+(deftest test-get
+ (is (get cat :likes-dogs))
+ (is (get morris :likes-dogs))
+ (is (not (get post-traumatic-morris :likes-dogs))))
+
+
+(defmulti compiler :os)
+(defmethod compiler ::unix [m] (get m :c-compiler))
+(defmethod compiler ::osx [m] (get m :c-compiler))
+
+
+(def unix {:os ::unix, :c-compiler "cc", :home "/home", :dev "/dev"})
+(def osx (-> (clone unix) (put :os ::osx) (put :c-compiler "gcc") (put :home "/Users")))
+
+(deftest test-proto-lookup-simple
+ (is (= "cc" (compiler unix)))
+ (is (= "gcc" (compiler osx))))
+
+
+(defmulti home :os)
+(defmethod home ::unix [m] (get m :home))
+
+(deftest test-proto-lookup-derived
+ (is (= "/home" (home unix)))
+ (is (thrown? IllegalArgumentException (home osx)))
+ (is (= "/Users" (do
+ (derive ::osx ::unix)
+ (home osx))))
+ (is (isa? ::osx ::unix)))
+
+
+(defmethod home ::bsd [m] "/home")
+
+(deftest test-proto-lookup-derived-prefer
+ (is (thrown? IllegalArgumentException (do (derive ::osx ::bsd)
+ (home osx))))
+ (is (= "/Users" (do (prefer-method home ::unix ::bsd)
+ (home osx))))
+ (is (= "/home" (home {:os ::bsd})))
+ (is (thrown? IllegalArgumentException (do (remove-method home ::bsd)
+ (home {:os ::bsd}))))
+ (is (= "/Users" (home osx))))
Please sign in to comment.
Something went wrong with that request. Please try again.