clojure 1.0.0

data/lib/clojure/set.clj

@@ -0,0 +1,148 @@
+;   Copyright (c) Rich Hickey. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(ns clojure.set)
+
+(defn- bubble-max-key [k coll]
+  "Move a maximal element of coll according to fn k (which returns a number) 
+   to the front of coll."
+  (let [max (apply max-key k coll)]
+    (cons max (remove #(identical? max %) coll))))
+
+(defn union
+  "Return a set that is the union of the input sets"
+  ([] #{})
+  ([s1] s1)
+  ([s1 s2]
+     (if (< (count s1) (count s2))
+       (reduce conj s2 s1)
+       (reduce conj s1 s2)))
+  ([s1 s2 & sets]
+     (let [bubbled-sets (bubble-max-key count (conj sets s2 s1))]
+       (reduce into (first bubbled-sets) (rest bubbled-sets)))))
+
+(defn intersection
+  "Return a set that is the intersection of the input sets"
+  ([s1] s1)
+  ([s1 s2]
+     (if (< (count s2) (count s1))
+       (recur s2 s1)
+       (reduce (fn [result item]
+                   (if (contains? s2 item)
+		     result
+                     (disj result item)))
+	       s1 s1)))
+  ([s1 s2 & sets] 
+     (let [bubbled-sets (bubble-max-key #(- (count %)) (conj sets s2 s1))]
+       (reduce intersection (first bubbled-sets) (rest bubbled-sets)))))
+
+(defn difference
+  "Return a set that is the first set without elements of the remaining sets"
+  ([s1] s1)
+  ([s1 s2] 
+     (if (< (count s1) (count s2))
+       (reduce (fn [result item] 
+                   (if (contains? s2 item) 
+                     (disj result item) 
+                     result))
+               s1 s1)
+       (reduce disj s1 s2)))
+  ([s1 s2 & sets] 
+     (reduce difference s1 (conj sets s2))))
+
+
+(defn select
+  "Returns a set of the elements for which pred is true"
+  [pred xset]
+    (reduce (fn [s k] (if (pred k) s (disj s k)))
+            xset xset))
+
+(defn project
+  "Returns a rel of the elements of xrel with only the keys in ks"
+  [xrel ks]
+    (set (map #(select-keys % ks) xrel)))
+
+(defn rename-keys
+  "Returns the map with the keys in kmap renamed to the vals in kmap"
+  [map kmap]
+    (reduce 
+     (fn [m [old new]]
+       (if (not= old new)
+         (-> m (assoc new (m old)) (dissoc old))
+         m)) 
+     map kmap))
+
+(defn rename
+  "Returns a rel of the maps in xrel with the keys in kmap renamed to the vals in kmap"
+  [xrel kmap]
+    (set (map #(rename-keys % kmap) xrel)))
+
+(defn index
+  "Returns a map of the distinct values of ks in the xrel mapped to a
+  set of the maps in xrel with the corresponding values of ks."
+  [xrel ks]
+    (reduce
+     (fn [m x]
+       (let [ik (select-keys x ks)]
+         (assoc m ik (conj (get m ik #{}) x))))
+     {} xrel))
+   
+(defn map-invert
+  "Returns the map with the vals mapped to the keys."
+  [m] (reduce (fn [m [k v]] (assoc m v k)) {} m))
+
+(defn join
+  "When passed 2 rels, returns the rel corresponding to the natural
+  join. When passed an additional keymap, joins on the corresponding
+  keys."
+  ([xrel yrel] ;natural join
+   (if (and (seq xrel) (seq yrel))
+     (let [ks (intersection (set (keys (first xrel))) (set (keys (first yrel))))
+           [r s] (if (<= (count xrel) (count yrel))
+                   [xrel yrel]
+                   [yrel xrel])
+           idx (index r ks)]
+       (reduce (fn [ret x]
+                 (let [found (idx (select-keys x ks))]
+                   (if found
+                     (reduce #(conj %1 (merge %2 x)) ret found)
+                     ret)))
+               #{} s))
+     #{}))
+  ([xrel yrel km] ;arbitrary key mapping
+   (let [[r s k] (if (<= (count xrel) (count yrel))
+                   [xrel yrel (map-invert km)]
+                   [yrel xrel km])
+         idx (index r (vals k))]
+     (reduce (fn [ret x]
+               (let [found (idx (rename-keys (select-keys x (keys k)) k))]
+                 (if found
+                   (reduce #(conj %1 (merge %2 x)) ret found)
+                   ret)))
+             #{} s))))
+
+(comment
+(refer 'set)
+(def xs #{{:a 11 :b 1 :c 1 :d 4}
+         {:a 2 :b 12 :c 2 :d 6}
+         {:a 3 :b 3 :c 3 :d 8 :f 42}})
+
+(def ys #{{:a 11 :b 11 :c 11 :e 5}
+         {:a 12 :b 11 :c 12 :e 3}
+         {:a 3 :b 3 :c 3 :e 7 }})
+
+(join xs ys)
+(join xs (rename ys {:b :yb :c :yc}) {:a :a})
+
+(union #{:a :b :c} #{:c :d :e })
+(difference #{:a :b :c} #{:c :d :e})
+(intersection #{:a :b :c} #{:c :d :e})
+
+(index ys [:b])
+)
+

data/lib/clojure/version.properties

@@ -0,0 +1,5 @@
+clojure.version.major=1
+clojure.version.minor=0
+clojure.version.incremental=0
+clojure.version.qualifier=
+clojure.version.interim=false

data/lib/clojure/xml.clj

@@ -0,0 +1,115 @@
+;   Copyright (c) Rich Hickey. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(ns clojure.xml
+    (:import (org.xml.sax ContentHandler Attributes SAXException)
+             (javax.xml.parsers SAXParser SAXParserFactory)))
+
+(def *stack*)
+(def *current*)
+(def *state*) ; :element :chars :between
+(def *sb*)
+
+(defstruct element :tag :attrs :content)
+
+(def tag (accessor element :tag))
+(def attrs (accessor element :attrs))
+(def content (accessor element :content))
+
+(def content-handler
+  (let [push-content (fn [e c]
+                       (assoc e :content (conj (or (:content e) []) c)))
+        push-chars (fn []
+                     (when (and (= *state* :chars)
+                                (some (complement #(. Character (isWhitespace %))) (str *sb*)))
+                       (set! *current* (push-content *current* (str *sb*)))))]
+    (new clojure.lang.XMLHandler
+         (proxy [ContentHandler] []
+           (startElement [uri local-name q-name #^Attributes atts]
+             (let [attrs (fn [ret i]
+                           (if (neg? i)
+                             ret
+                             (recur (assoc ret 
+                                           (. clojure.lang.Keyword (intern (symbol (. atts (getQName i)))))
+                                           (. atts (getValue i)))
+                                    (dec i))))
+                   e (struct element 
+                             (. clojure.lang.Keyword (intern (symbol q-name)))
+                             (when (pos? (. atts (getLength)))
+                               (attrs {} (dec (. atts (getLength))))))]
+               (push-chars)
+               (set! *stack* (conj *stack* *current*))
+               (set! *current* e)
+               (set! *state* :element))
+             nil)
+           (endElement [uri local-name q-name]
+             (push-chars)
+             (set! *current* (push-content (peek *stack*) *current*))
+             (set! *stack* (pop *stack*))
+             (set! *state* :between)
+             nil)
+           (characters [ch start length]
+             (when-not (= *state* :chars)
+               (set! *sb* (new StringBuilder)))
+             (let [#^StringBuilder sb *sb*]
+               (. sb (append ch start length))
+               (set! *state* :chars))
+             nil)
+           (setDocumentLocator [locator])
+           (startDocument [])
+           (endDocument [])
+           (startPrefixMapping [prefix uri])
+           (endPrefixMapping [prefix])
+           (ignorableWhitespace [ch start length])
+           (processingInstruction [target data])
+           (skippedEntity [name])
+           ))))
+
+(defn startparse-sax [s ch]
+  (.. SAXParserFactory (newInstance) (newSAXParser) (parse s ch)))
+
+(defn parse
+  "Parses and loads the source s, which can be a File, InputStream or
+  String naming a URI. Returns a tree of the xml/element struct-map,
+  which has the keys :tag, :attrs, and :content. and accessor fns tag,
+  attrs, and content. Other parsers can be supplied by passing
+  startparse, a fn taking a source and a ContentHandler and returning
+  a parser"
+  ([s] (parse s startparse-sax))
+  ([s startparse]
+    (binding [*stack* nil
+              *current* (struct element)
+              *state* :between
+              *sb* nil]
+      (startparse s content-handler)
+      ((:content *current*) 0)))) 
+
+(defn emit-element [e]
+  (if (instance? String e)
+    (println e)
+    (do
+      (print (str "<" (name (:tag e))))
+      (when (:attrs e)
+	(doseq [attr (:attrs e)]
+	  (print (str " " (name (key attr)) "='" (val attr)"'"))))
+      (if (:content e)
+	(do
+	  (println ">")
+	  (doseq [c (:content e)]
+	    (emit-element c))
+	  (println (str "</" (name (:tag e)) ">")))
+	(println "/>")))))
+
+(defn emit [x]
+  (println "<?xml version='1.0' encoding='UTF-8'?>")
+  (emit-element x))
+
+;(export '(tag attrs content parse element emit emit-element))
+
+;(load-file "/Users/rich/dev/clojure/src/xml.clj")
+;(def x (xml/parse "http://arstechnica.com/journals.rssx"))

data/lib/clojure/zip.clj

@@ -0,0 +1,278 @@
+;   Copyright (c) Rich Hickey. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+;functional hierarchical zipper, with navigation, editing and enumeration
+;see Huet
+
+(ns clojure.zip
+    (:refer-clojure :exclude (replace remove next)))
+
+(defn zipper
+  "Creates a new zipper structure. 
+
+  branch? is a fn that, given a node, returns true if can have
+  children, even if it currently doesn't.
+
+  children is a fn that, given a branch node, returns a seq of its
+  children.
+
+  make-node is a fn that, given an existing node and a seq of
+  children, returns a new branch node with the supplied children.
+  root is the root node."  
+  [branch? children make-node root]
+    #^{:zip/branch? branch? :zip/children children :zip/make-node make-node} 
+    [root nil])
+
+(defn seq-zip
+  "Returns a zipper for nested sequences, given a root sequence"
+  [root]
+    (zipper seq? identity (fn [node children] children) root))
+
+(defn vector-zip
+  "Returns a zipper for nested vectors, given a root vector"
+  [root]
+    (zipper vector? seq (fn [node children] (apply vector children)) root))
+
+(defn xml-zip
+  "Returns a zipper for xml elements (as from xml/parse),
+  given a root element"
+  [root]
+    (zipper (complement string?) 
+            (comp seq :content)
+            (fn [node children]
+              (assoc node :content (and children (apply vector children))))
+            root))
+
+(defn node
+  "Returns the node at loc"
+  [loc] (loc 0))
+
+(defn branch?
+  "Returns true if the node at loc is a branch"
+  [loc]
+    ((:zip/branch? ^loc) (node loc)))
+
+(defn children
+  "Returns a seq of the children of node at loc, which must be a branch"
+  [loc]
+    ((:zip/children ^loc) (node loc)))
+
+(defn make-node
+  "Returns a new branch node, given an existing node and new
+  children. The loc is only used to supply the constructor."
+  [loc node children]
+    ((:zip/make-node ^loc) node children))
+
+(defn path
+  "Returns a seq of nodes leading to this loc"
+  [loc]
+    (:pnodes (loc 1)))
+
+(defn lefts
+  "Returns a seq of the left siblings of this loc"
+  [loc]
+    (seq (:l (loc 1))))
+
+(defn rights
+  "Returns a seq of the right siblings of this loc"
+  [loc]
+    (:r (loc 1)))
+
+
+(defn down
+  "Returns the loc of the leftmost child of the node at this loc, or
+  nil if no children"
+  [loc]
+    (let [[node path] loc
+          [c & cnext :as cs] (children loc)]
+      (when cs
+        (with-meta [c {:l [] 
+                       :pnodes (if path (conj (:pnodes path) node) [node]) 
+                       :ppath path 
+                       :r cnext}] ^loc))))
+
+(defn up
+  "Returns the loc of the parent of the node at this loc, or nil if at
+  the top"
+  [loc]
+    (let [[node {l :l, ppath :ppath, pnodes :pnodes r :r, changed? :changed?, :as path}] loc]
+      (when pnodes
+        (let [pnode (peek pnodes)]
+          (with-meta (if changed?
+                       [(make-node loc pnode (concat l (cons node r))) 
+                        (and ppath (assoc ppath :changed? true))]
+                       [pnode ppath])
+                     ^loc)))))
+
+(defn root
+  "zips all the way up and returns the root node, reflecting any
+ changes."
+  [loc]
+    (if (= :end (loc 1))
+      (node loc)
+      (let [p (up loc)]
+        (if p
+          (recur p)
+          (node loc)))))
+
+(defn right
+  "Returns the loc of the right sibling of the node at this loc, or nil"
+  [loc]
+    (let [[node {l :l  [r & rnext :as rs] :r :as path}] loc]
+      (when (and path rs)
+        (with-meta [r (assoc path :l (conj l node) :r rnext)] ^loc))))
+
+(defn rightmost
+  "Returns the loc of the rightmost sibling of the node at this loc, or self"
+  [loc]
+    (let [[node {l :l r :r :as path}] loc]
+      (if (and path r)
+        (with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] ^loc)
+        loc)))
+
+(defn left
+  "Returns the loc of the left sibling of the node at this loc, or nil"
+  [loc]
+    (let [[node {l :l r :r :as path}] loc]
+      (when (and path (seq l))
+        (with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] ^loc))))
+
+(defn leftmost
+  "Returns the loc of the leftmost sibling of the node at this loc, or self"
+  [loc]
+    (let [[node {l :l r :r :as path}] loc]
+      (if (and path (seq l))
+        (with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] ^loc)
+        loc)))
+
+(defn insert-left
+  "Inserts the item as the left sibling of the node at this loc,
+ without moving"
+  [loc item]
+    (let [[node {l :l :as path}] loc]
+      (if (nil? path)
+        (throw (new Exception "Insert at top"))
+        (with-meta [node (assoc path :l (conj l item) :changed? true)] ^loc))))
+
+(defn insert-right
+  "Inserts the item as the right sibling of the node at this loc,
+  without moving"
+  [loc item]
+    (let [[node {r :r :as path}] loc]
+      (if (nil? path)
+        (throw (new Exception "Insert at top"))
+        (with-meta [node (assoc path :r (cons item r) :changed? true)] ^loc))))
+
+(defn replace
+  "Replaces the node at this loc, without moving"
+  [loc node]
+    (let [[_ path] loc]
+      (with-meta [node (assoc path :changed? true)] ^loc)))
+
+(defn edit
+  "Replaces the node at this loc with the value of (f node args)"
+  [loc f & args]
+    (replace loc (apply f (node loc) args)))
+
+(defn insert-child
+  "Inserts the item as the leftmost child of the node at this loc,
+  without moving"
+  [loc item]
+    (replace loc (make-node loc (node loc) (cons item (children loc)))))
+
+(defn append-child
+  "Inserts the item as the rightmost child of the node at this loc,
+  without moving"
+  [loc item]
+    (replace loc (make-node loc (node loc) (concat (children loc) [item]))))
+
+(defn next
+  "Moves to the next loc in the hierarchy, depth-first. When reaching
+  the end, returns a distinguished loc detectable via end?. If already
+  at the end, stays there."
+  [loc]
+    (if (= :end (loc 1))
+      loc
+      (or 
+       (and (branch? loc) (down loc))
+       (right loc)
+       (loop [p loc]
+         (if (up p)
+           (or (right (up p)) (recur (up p)))
+           [(node p) :end])))))
+
+(defn prev
+  "Moves to the previous loc in the hierarchy, depth-first. If already
+  at the root, returns nil."
+  [loc]
+    (if-let [lloc (left loc)]
+      (loop [loc lloc]
+        (if-let [child (and (branch? loc) (down loc))]
+          (recur (rightmost child))
+          loc))
+      (up loc)))
+
+(defn end?
+  "Returns true if loc represents the end of a depth-first walk"
+  [loc]
+    (= :end (loc 1)))
+
+(defn remove
+  "Removes the node at loc, returning the loc that would have preceded
+  it in a depth-first walk."
+  [loc]
+    (let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc]
+      (if (nil? path)
+        (throw (new Exception "Remove at top"))
+        (if (pos? (count l))
+          (loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] ^loc)]
+            (if-let [child (and (branch? loc) (down loc))]
+              (recur (rightmost child))
+              loc))
+          (with-meta [(make-node loc (peek pnodes) rs) 
+                      (and ppath (assoc ppath :changed? true))]
+                     ^loc)))))
+  
+(comment
+
+(load-file "/Users/rich/dev/clojure/src/zip.clj")
+(refer 'zip)
+(def data '[[a * b] + [c * d]])
+(def dz (vector-zip data))
+
+(right (down (right (right (down dz)))))
+(lefts (right (down (right (right (down dz))))))
+(rights (right (down (right (right (down dz))))))
+(up (up (right (down (right (right (down dz)))))))
+(path (right (down (right (right (down dz))))))
+
+(-> dz down right right down right)
+(-> dz down right right down right (replace '/) root)
+(-> dz next next (edit str) next next next (replace '/) root)
+(-> dz next next next next next next next next next remove root)
+(-> dz next next next next next next next next next remove (insert-right 'e) root)
+(-> dz next next next next next next next next next remove up (append-child 'e) root)
+
+(end? (-> dz next next next next next next next next next remove next))
+
+(-> dz next remove next remove root)
+
+(loop [loc dz]
+  (if (end? loc)
+    (root loc)
+    (recur (next (if (= '* (node loc)) 
+                   (replace loc '/)
+                   loc)))))
+
+(loop [loc dz]
+  (if (end? loc)
+    (root loc)
+    (recur (next (if (= '* (node loc)) 
+                   (remove loc)
+                   loc)))))
+)