Mercurial > lasercutter
comparison src/clojure/test_clojure/multimethods.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
9:35cf337adfcf | 10:ef7dbbd6452c |
---|---|
1 ; Copyright (c) Rich Hickey. All rights reserved. | |
2 ; The use and distribution terms for this software are covered by the | |
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
4 ; which can be found in the file epl-v10.html at the root of this distribution. | |
5 ; By using this software in any fashion, you are agreeing to be bound by | |
6 ; the terms of this license. | |
7 ; You must not remove this notice, or any other, from this software. | |
8 | |
9 ; Author: Frantisek Sodomka, Robert Lachlan | |
10 | |
11 (ns clojure.test-clojure.multimethods | |
12 (:use clojure.test [clojure.test-clojure.helpers :only (with-var-roots)]) | |
13 (:require [clojure.set :as set])) | |
14 | |
15 ; http://clojure.org/multimethods | |
16 | |
17 ; defmulti | |
18 ; defmethod | |
19 ; remove-method | |
20 ; prefer-method | |
21 ; methods | |
22 ; prefers | |
23 | |
24 (defmacro for-all | |
25 [& args] | |
26 `(dorun (for ~@args))) | |
27 | |
28 (defn hierarchy-tags | |
29 "Return all tags in a derivation hierarchy" | |
30 [h] | |
31 (set/select | |
32 #(instance? clojure.lang.Named %) | |
33 (reduce into #{} (map keys (vals h))))) | |
34 | |
35 (defn transitive-closure | |
36 "Return all objects reachable by calling f starting with o, | |
37 not including o itself. f should return a collection." | |
38 [o f] | |
39 (loop [results #{} | |
40 more #{o}] | |
41 (let [new-objects (set/difference more results)] | |
42 (if (seq new-objects) | |
43 (recur (set/union results more) (reduce into #{} (map f new-objects))) | |
44 (disj results o))))) | |
45 | |
46 (defn tag-descendants | |
47 "Set of descedants which are tags (i.e. Named)." | |
48 [& args] | |
49 (set/select | |
50 #(instance? clojure.lang.Named %) | |
51 (or (apply descendants args) #{}))) | |
52 | |
53 (defn assert-valid-hierarchy | |
54 [h] | |
55 (let [tags (hierarchy-tags h)] | |
56 (testing "ancestors are the transitive closure of parents" | |
57 (for-all [tag tags] | |
58 (is (= (transitive-closure tag #(parents h %)) | |
59 (or (ancestors h tag) #{}))))) | |
60 (testing "ancestors are transitive" | |
61 (for-all [tag tags] | |
62 (is (= (transitive-closure tag #(ancestors h %)) | |
63 (or (ancestors h tag) #{}))))) | |
64 (testing "tag descendants are transitive" | |
65 (for-all [tag tags] | |
66 (is (= (transitive-closure tag #(tag-descendants h %)) | |
67 (or (tag-descendants h tag) #{}))))) | |
68 (testing "a tag isa? all of its parents" | |
69 (for-all [tag tags | |
70 :let [parents (parents h tag)] | |
71 parent parents] | |
72 (is (isa? h tag parent)))) | |
73 (testing "a tag isa? all of its ancestors" | |
74 (for-all [tag tags | |
75 :let [ancestors (ancestors h tag)] | |
76 ancestor ancestors] | |
77 (is (isa? h tag ancestor)))) | |
78 (testing "all my descendants have me as an ancestor" | |
79 (for-all [tag tags | |
80 :let [descendants (descendants h tag)] | |
81 descendant descendants] | |
82 (is (isa? h descendant tag)))) | |
83 (testing "there are no cycles in parents" | |
84 (for-all [tag tags] | |
85 (is (not (contains? (transitive-closure tag #(parents h %)) tag))))) | |
86 (testing "there are no cycles in descendants" | |
87 (for-all [tag tags] | |
88 (is (not (contains? (descendants h tag) tag))))))) | |
89 | |
90 (def family | |
91 (reduce #(apply derive (cons %1 %2)) (make-hierarchy) | |
92 [[::parent-1 ::ancestor-1] | |
93 [::parent-1 ::ancestor-2] | |
94 [::parent-2 ::ancestor-2] | |
95 [::child ::parent-2] | |
96 [::child ::parent-1]])) | |
97 | |
98 (deftest cycles-are-forbidden | |
99 (testing "a tag cannot be its own parent" | |
100 (is (thrown-with-msg? Throwable #"\(not= tag parent\)" | |
101 (derive family ::child ::child)))) | |
102 (testing "a tag cannot be its own ancestor" | |
103 (is (thrown-with-msg? Throwable #"Cyclic derivation: :clojure.test-clojure.multimethods/child has :clojure.test-clojure.multimethods/ancestor-1 as ancestor" | |
104 (derive family ::ancestor-1 ::child))))) | |
105 | |
106 (deftest using-diamond-inheritance | |
107 (let [diamond (reduce #(apply derive (cons %1 %2)) (make-hierarchy) | |
108 [[::mammal ::animal] | |
109 [::bird ::animal] | |
110 [::griffin ::mammal] | |
111 [::griffin ::bird]]) | |
112 bird-no-more (underive diamond ::griffin ::bird)] | |
113 (assert-valid-hierarchy diamond) | |
114 (assert-valid-hierarchy bird-no-more) | |
115 (testing "a griffin is a mammal, indirectly through mammal and bird" | |
116 (is (isa? diamond ::griffin ::animal))) | |
117 (testing "a griffin is a bird" | |
118 (is (isa? diamond ::griffin ::bird))) | |
119 (testing "after underive, griffin is no longer a bird" | |
120 (is (not (isa? bird-no-more ::griffin ::bird)))) | |
121 (testing "but it is still an animal, via mammal" | |
122 (is (isa? bird-no-more ::griffin ::animal))))) | |
123 | |
124 (deftest derivation-world-bridges-to-java-inheritance | |
125 (let [h (derive (make-hierarchy) java.util.Map ::map)] | |
126 (testing "a Java class can be isa? a tag" | |
127 (is (isa? h java.util.Map ::map))) | |
128 (testing "if a Java class isa? a tag, so are its subclasses..." | |
129 (is (isa? h java.util.HashMap ::map))) | |
130 (testing "...but not its superclasses!" | |
131 (is (not (isa? h java.util.Collection ::map)))))) | |
132 | |
133 (deftest global-hierarchy-test | |
134 (with-var-roots {#'clojure.core/global-hierarchy (make-hierarchy)} | |
135 (assert-valid-hierarchy @#'clojure.core/global-hierarchy) | |
136 (testing "when you add some derivations..." | |
137 (derive ::lion ::cat) | |
138 (derive ::manx ::cat) | |
139 (assert-valid-hierarchy @#'clojure.core/global-hierarchy)) | |
140 (testing "...isa? sees the derivations" | |
141 (is (isa? ::lion ::cat)) | |
142 (is (not (isa? ::cat ::lion)))) | |
143 (testing "... you can traverse the derivations" | |
144 (is (= #{::manx ::lion} (descendants ::cat))) | |
145 (is (= #{::cat} (parents ::manx))) | |
146 (is (= #{::cat} (ancestors ::manx)))) | |
147 (testing "then, remove a derivation..." | |
148 (underive ::manx ::cat)) | |
149 (testing "... traversals update accordingly" | |
150 (is (= #{::lion} (descendants ::cat))) | |
151 (is (nil? (parents ::manx))) | |
152 (is (nil? (ancestors ::manx)))))) | |
153 | |
154 #_(defmacro for-all | |
155 "Better than the actual for-all, if only it worked." | |
156 [& args] | |
157 `(reduce | |
158 #(and %1 %2) | |
159 (map true? (for ~@args)))) | |
160 |