;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;

 ;; Application examples for data types

 ;;

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

 (ns

   #^{:author "Konrad Hinsen"

      :skip-wiki true

      :doc "Examples for data type definitions"}

   clojure.contrib.types.examples

   (: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))