Restore examples lost during modules split, a6a92b9b3d2bfd9a56e1e5e9cfba706d1aeeaae5

1 files changed, 152 insertions, 0 deletions

diff --git a/modules/types/src/examples/clojure/examples/types.clj b/modules/types/src/examples/clojure/examples/types.clj
new file mode 100644
index 00000000..57bcb54e
--- /dev/null
+++ b/modules/types/src/examples/clojure/examples/types.clj
@@ -0,0 +1,152 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Application examples for data types
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(ns
+  #^{:author "Konrad Hinsen"
+     :skip-wiki true
+     :doc "Examples for data type definitions"}
+  examples.types
+  (:refer-clojure :exclude (deftype))
+  (:use [clojure.contrib.types
+	 :only (deftype defadt match)])
+  (:require [clojure.contrib.generic.collection :as gc])
+  (:require [clojure.contrib.generic.functor :as gf]))
+
+;
+; Multisets implemented as maps to integers
+;
+
+; The most basic type definition. A more elaborate version could add
+; a constructor that verifies that its argument is a map with integer values.
+(deftype ::multiset multiset
+  "Multiset (demo implementation)")
+
+; Some set operations generalized to multisets
+; Note that the multiset constructor is nowhere called explicitly, as the
+; map operations all preserve the metadata.
+(defmethod gc/conj ::multiset
+  ([ms x]
+   (assoc ms x (inc (get ms x 0))))
+  ([ms x & xs]
+    (reduce gc/conj (gc/conj ms x) xs)))
+
+(defmulti union (fn [& sets] (type (first sets))))
+
+(defmethod union clojure.lang.IPersistentSet
+  [& sets]
+  (apply clojure.set/union sets))
+
+; Note: a production-quality implementation should accept standard sets
+; and perhaps other collections for its second argument.
+(defmethod union ::multiset
+  ([ms] ms)
+  ([ms1 ms2]
+     (letfn [(add-item [ms [item n]]
+		       (assoc ms item (+ n (get ms item 0))))]
+       (reduce add-item ms1 ms2)))
+  ([ms1 ms2 & mss]
+     (reduce union (union ms1 ms2) mss)))
+
+; Let's use it:
+(gc/conj #{} :a :a :b :c)
+(gc/conj (multiset {}) :a :a :b :c)
+
+(union #{:a :b} #{:b :c})
+(union (multiset {:a 1 :b 1}) (multiset {:b 1 :c 2}))
+
+;
+; A simple tree structure defined as an algebraic data type
+;
+(defadt ::tree
+  empty-tree
+  (leaf value)
+  (node left-tree right-tree))
+
+(def a-tree (node (leaf :a) 
+		  (node (leaf :b)
+			(leaf :c))))
+
+(defn depth
+  [t]
+  (match t
+    empty-tree  0
+    (leaf _)    1
+    (node l r)  (inc (max (depth l) (depth r)))))
+
+(depth empty-tree)
+(depth (leaf 42))
+(depth a-tree)
+
+; Algebraic data types with multimethods: fmap on a tree
+(defmethod gf/fmap ::tree
+  [f t]
+  (match t
+    empty-tree  empty-tree
+    (leaf v)    (leaf (f v))
+    (node l r)  (node (gf/fmap f l) (gf/fmap f r))))
+
+(gf/fmap str a-tree)
+
+;
+; Nonsense examples to illustrate all the features of match
+; for type constructors.
+;
+(defadt ::foo
+  (bar a b c))
+
+(defn foo-to-int
+  [a-foo]
+  (match a-foo
+    (bar x x x)  x
+    (bar 0 x y)  (+ x y)
+    (bar 1 2 3)  -1
+    (bar a b 1)  (* a b)
+    :else        42))
+
+(foo-to-int (bar 0 0 0))    ; 0
+(foo-to-int (bar 0 5 6))    ; 11
+(foo-to-int (bar 1 2 3))    ; -1
+(foo-to-int (bar 3 3 1))    ; 9
+(foo-to-int (bar 0 3 1))    ; 4
+(foo-to-int (bar 10 20 30)) ; 42
+
+;
+; Match can also be used for lists, vectors, and maps. Note that since
+; algebraic data types are represented as maps, they can be matched
+; either with their type constructor and positional arguments, or
+; with a map template.
+;
+
+; Tree depth once again with map templates
+(defn depth
+  [t]
+  (match t
+    empty-tree  0
+    {:value _}  1
+    {:left-tree l :right-tree r}  (inc (max (depth l) (depth r)))))
+
+(depth empty-tree)
+(depth (leaf 42))
+(depth a-tree)
+
+; Match for lists, vectors, and maps:
+
+(for [x ['(1 2 3)
+	 [1 2 3]
+	 {:x 1 :y 2 :z 3}
+	 '(1 1 1)
+	 [2 1 2]
+	 {:x 1 :y 1 :z 2}]]
+  (match x
+    '(a a a)  	 'list-of-three-equal-values
+    '(a b c)  	 'list
+    [a a a]   	 'vector-of-three-equal-values
+    [a b a]   	 'vector-of-three-with-first-and-last-equal
+    [a b c]      'vector
+    {:x a :y z}  'map-with-x-equal-y
+    {}           'any-map))