diff options
| -rw-r--r-- | src/clojure/contrib/accumulators.clj | 139 | ||||
| -rw-r--r-- | src/clojure/contrib/types.clj | 56 | ||||
| -rw-r--r-- | src/clojure/contrib/types/examples.clj | 60 |
3 files changed, 158 insertions, 97 deletions
diff --git a/src/clojure/contrib/accumulators.clj b/src/clojure/contrib/accumulators.clj index f06badf7..d32dbda6 100644 --- a/src/clojure/contrib/accumulators.clj +++ b/src/clojure/contrib/accumulators.clj @@ -1,7 +1,7 @@ ;; Accumulators ;; by Konrad Hinsen -;; last updated March 2, 2009 +;; last updated March 11, 2009 ;; This module defines various accumulators (list, vector, map, ;; sum, product, counter, and combinations thereof) with a common @@ -19,7 +19,7 @@ ;; remove this notice, or any other, from this software. (ns clojure.contrib.accumulators - (:use [clojure.contrib.types :only (deftype get-value get-values)]) + (:use [clojure.contrib.types :only (deftype)]) (:use [clojure.contrib.def :only (defvar defvar- defmacro-)])) (defmulti add @@ -135,31 +135,17 @@ ; (defmacro- defacc [name op empty doc-string] - (let [type-name (symbol (str name "-type")) + (let [type-tag (keyword (str *ns*) (str name)) empty-symbol (symbol (str "empty-" name))] `(let [op# ~op] - (deftype ~type-name (~name ~'v)) + (deftype ~type-tag ~name + (fn [~'x] {:value ~'x}) + (fn [~'x] (list (:value ~'x)))) (defvar ~empty-symbol (~name ~empty) ~doc-string) - (defmethod combine ~type-name [& vs#] - (~name (apply op# (map clojure.contrib.types/get-value vs#)))) - (defmethod add ~type-name [v# e#] - (~name (op# (clojure.contrib.types/get-value v#) e#)))))) - -;; (defmacro- defacc -;; [name op empty doc-string] -;; (let [struct-tag (keyword (str name)) -;; meta-tag (keyword (str *ns*) (str name)) -;; empty-symbol (symbol (str "empty-" name))] -;; `(let [op# ~op -;; meta-data# {::accumulator ~meta-tag} -;; struct-basis# (create-struct ~struct-tag) -;; get-value# (accessor struct-basis# ~struct-tag) -;; make-fn# (fn [n#] (with-meta (struct struct-basis# n#) meta-data#))] -;; (defvar ~empty-symbol (make-fn# ~empty) ~doc-string) -;; (defmethod combine ~meta-tag [& vs#] -;; (make-fn# (apply op# (map get-value# vs#)))) -;; (defmethod add ~meta-tag [v# e#] -;; (make-fn# (op# (get-value# v#) e#)))))) + (defmethod combine ~type-tag [& vs#] + (~name (apply op# (map :value vs#)))) + (defmethod add ~type-tag [v# e#] + (~name (op# (:value v#) e#)))))) (defacc sum + 0 "An empty sum accumulator. Only numbers can be added.") @@ -188,23 +174,24 @@ ; Numeric min-max accumulator ; (combination of minimum and maximum) ; -(deftype min-max-type - (min-max min max)) +(deftype ::min-max min-max + (fn [min max] {:min min :max max}) + (fn [mm] (list (:min mm) (:max mm)))) (defvar empty-min-max (min-max nil nil) "An empty min-max accumulator, combining minimum and maximum. Only numbers can be added.") -(defmethod combine min-max-type +(defmethod combine ::min-max [& vs] - (let [values (map get-values vs) - total-min (apply min (map first values)) - total-max (apply max (map second values))] + (let [total-min (apply min (map :min vs)) + total-max (apply max (map :max vs))] (min-max total-min total-max))) -(defmethod add min-max-type +(defmethod add ::min-max [v e] - (let [[min-v max-v] (get-values v) + (let [min-v (:min v) + max-v (:max v) new-min (if (nil? min-v) e (min min-v e)) new-max (if (nil? max-v) e (max max-v e))] (min-max new-min new-max))) @@ -212,63 +199,57 @@ ; ; Counter accumulator ; -(let [type-tag ::counter - meta-map {:type type-tag}] +(deftype ::counter counter) - (defvar empty-counter (with-meta {} meta-map) - "An empty counter accumulator. Its value is a map that stores for - every item the number of times it was added.") +(defvar empty-counter (counter {}) + "An empty counter accumulator. Its value is a map that stores for + every item the number of times it was added.") - (defmethod combine type-tag - [v & vs] - (letfn [(add-item [counter [item n]] - (assoc counter item (+ n (get counter item 0)))) - (add-two [c1 c2] (reduce add-item c1 c2))] - (reduce add-two v vs))) +(defmethod combine ::counter + [v & vs] + (letfn [(add-item [cntr [item n]] + (assoc cntr item (+ n (get cntr item 0)))) + (add-two [c1 c2] (reduce add-item c1 c2))] + (reduce add-two v vs))) - (defmethod add type-tag - [v e] - (assoc v e (inc (get v e 0))))) +(defmethod add ::counter + [v e] + (assoc v e (inc (get v e 0)))) ; ; Counter accumulator with total count ; +(deftype ::counter-with-total counter-with-total) +(derive ::counter-with-total ::counter) -(let [type-tag ::counter-with-total - meta-map {:type type-tag}] - - (derive type-tag ::counter) - - (defvar empty-counter-with-total - (with-meta {:total 0} meta-map) - "An empty counter-with-total accumulator. It works like the counter - accumulator, except that the total number of items added is stored as the - value of the key :totall.") +(defvar empty-counter-with-total + (counter-with-total {:total 0}) + "An empty counter-with-total accumulator. It works like the counter + accumulator, except that the total number of items added is stored as the + value of the key :total.") - (defmethod add type-tag - [v e] - (assoc v e (inc (get v e 0)) - :total (inc (:total v))))) +(defmethod add ::counter-with-total + [v e] + (assoc v e (inc (get v e 0)) + :total (inc (:total v)))) ; ; Accumulator n-tuple ; -(let [type-tag ::tuple - meta-map {:type type-tag} - make (fn [s] (with-meta (into [] s) meta-map))] - - (defn empty-tuple - "Returns an accumulator tuple with the supplied empty-accumulators - as its value. Accumulator tuples consist of several accumulators that - work in parallel. Added items must be sequences whose number of elements - matches the number of sub-accumulators." - [empty-accumulators] - (make empty-accumulators)) - - (defmethod combine ::tuple - [& vs] - (make (map combine vs))) - - (defmethod add ::tuple - [v e] - (make (map add v e)))) +(deftype ::tuple acc-tuple) + +(defn empty-tuple + "Returns an accumulator tuple with the supplied empty-accumulators + as its value. Accumulator tuples consist of several accumulators that + work in parallel. Added items must be sequences whose number of elements + matches the number of sub-accumulators." + [empty-accumulators] + (acc-tuple (into [] empty-accumulators))) + +(defmethod combine ::tuple + [& vs] + (acc-tuple (vec (map combine vs)))) + +(defmethod add ::tuple + [v e] + (acc-tuple (vec (map add v e)))) diff --git a/src/clojure/contrib/types.clj b/src/clojure/contrib/types.clj index 38f13cb2..53cdb816 100644 --- a/src/clojure/contrib/types.clj +++ b/src/clojure/contrib/types.clj @@ -1,7 +1,7 @@ -;; Algebraic data types +;; Data types ;; by Konrad Hinsen -;; last updated February 26, 2009 +;; last updated March 12, 2009 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved. The use ;; and distribution terms for this software are covered by the Eclipse @@ -12,11 +12,46 @@ ;; remove this notice, or any other, from this software. (ns clojure.contrib.types - "Algebraic data types") + "General and algebraic data types + + NOTE: This library is experimental. It may change significantly + with future release.") + +; +; Data type definition +; +(defmulti deconstruct type) +(defmethod deconstruct :default [x] (list x)) + +(defmacro deftype + "Define a data type by a type tag (a namespace-qualified keyword) + and a symbol naming the constructor function. Optionally, a pair + of constructor and deconstructor functions can be given as well, + the defaults are clojure.core/identity and clojure.core/list. + The full constructor associated with constructor-name calls the + constructor function and attaches the type tag to its result + as metadata. The deconstructor function must return the arguments + to be passed to the constructor in order to create an equivalent + object. It is used for printing and matching." + ([type-tag constructor-name] + `(deftype ~type-tag ~constructor-name identity list)) + ([type-tag constructor-name constructor deconstructor] + `(do + (derive ~type-tag ::type) + (let [meta-map# {:type ~type-tag ::constructor (quote ~constructor-name)}] + (def ~constructor-name + (comp (fn [~'x] (with-meta ~'x meta-map#)) ~constructor)) + (defmethod deconstruct ~type-tag [~'x] + (~deconstructor (with-meta ~'x {}))))))) + +(defmethod print-method ::type [o w] + (print-method (cons (::constructor ^o) (deconstruct o)) w)) ; ; Defining algebraic types ; +(derive ::adt ::type) + (defn- qualified-symbol [s] (symbol (str *ns*) (str s))) @@ -38,15 +73,13 @@ (with-meta [(quote ~(qualified-symbol name)) ~@args] ~meta-map-symbol)))))) -(defmacro deftype - "Define the algebraic data type name by an exhaustive list of constructors. +(defmacro defadt + "Define an algebraic data type name by an exhaustive list of constructors. Each constructor can be a symbol (argument-free constructor) or a list consisting of a tag symbol followed by the argument symbols. - The data type itself is a keyword declared as deriving from - :clojure.contrib.types/adt." - [name & constructors] - (let [type-tag (qualified-keyword name) - meta-map-symbol (gensym "mm") + The data type tag must be a keyword." + [type-tag & constructors] + (let [meta-map-symbol (gensym "mm") accessor1 (if (and (= 1 (count constructors)) (seq? (first constructors)) (= 2 (count (first constructors)))) @@ -60,7 +93,6 @@ nil)] `(let [~meta-map-symbol {:type ~type-tag}] (derive ~type-tag ::adt) - (def ~name ~type-tag) ~@(map (partial constructor-code meta-map-symbol) constructors) ~accessor1 ~accessor2 @@ -72,7 +104,7 @@ (defn- unqualified-symbol [s] (let [s-str (str s)] - (symbol (.substring s-str (inc (.indexOf s-str (int \/))))))) + (symbol (subs s-str (inc (.indexOf s-str (int \/))))))) (defmethod print-method ::adt [o w] (if (symbol? o) diff --git a/src/clojure/contrib/types/examples.clj b/src/clojure/contrib/types/examples.clj index 5a39938f..e38d6425 100644 --- a/src/clojure/contrib/types/examples.clj +++ b/src/clojure/contrib/types/examples.clj @@ -7,12 +7,60 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ns clojure.contrib.types.examples - (:use [clojure.contrib.types :only (deftype match get-value get-values)])) + (:use [clojure.contrib.types + :only (deftype defadt match get-value get-values)])) ; -; A simple tree structure +; Multisets implemented as maps to integers ; -(deftype tree + +; 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) + +; Some set operations generalized to multisets +; Note that the multiset constructor is not called anywhere, as the +; map operations all preserve the metadata. +(defmulti my-conj (fn [& args] (type (first args)))) + +(defmethod my-conj :default + [& args] + (apply clojure.core/conj args)) + +(defmethod my-conj ::multiset + ([ms x] + (assoc ms x (inc (get ms x 0)))) + ([ms x & xs] + (reduce my-conj (my-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: +(my-conj #{} :a :a :b :c) +(my-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)) @@ -52,7 +100,7 @@ (into {} (for [[k v] m] [k (f v)]))) ; Trees -(defmethod fmap tree +(defmethod fmap ::tree [f t] (match t empty-tree empty-tree @@ -67,7 +115,7 @@ ; ; Nonsense examples to illustrate all the features of match ; -(deftype foo +(defadt ::foo (bar a b c)) (defn foo-to-int @@ -97,7 +145,7 @@ (get-value (bar 1 2 3)) ; fails (get-values (bar 1 2 3)) -(deftype sum-type +(defadt ::sum (sum x)) (get-value (sum 42)) |