Permalink
Browse files

first cut at changes for Clojure SVN 1094+, my contribs and ones they…

… depend on now load again
  • Loading branch information...
1 parent db748f4 commit 6f7a77e9cdc8df4f58fd86eed0dcd0dd6fc2d6fd @scgilardi scgilardi committed Nov 12, 2008
@@ -0,0 +1,31 @@
+;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and
+;; distribution terms for this software are covered by the Common Public
+;; License 1.0 (http://opensource.org/licenses/cpl.php) which can be found
+;; in the file CPL.TXT 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.
+;;
+;; File: cond.clj
+;;
+;; scgilardi (gmail)
+;; 2 October 2008
+
+(ns clojure.contrib.cond)
+
+(defmacro cond-let
+ "Takes a binding-form and a set of test/expr pairs. Evaluates each test
+ one at a time. If a test returns logical true, cond-let evaluates and
+ returns expr with binding-form bound to the value of test and doesn't
+ evaluate any of the other tests or exprs. To provide a default value
+ either provide a literal that evaluates to logical true and is
+ binding-compatible with binding-form, or use :else as the test and don't
+ refer to any parts of binding-form in the expr. (cond-let binding-form)
+ returns nil."
+ [binding-form & clauses]
+ (when-let [[test expr & more] clauses]
+ (if (= test :else)
+ expr
+ `(if ~test
+ (let [~binding-form ~test] ~expr)
+ (cond-let ~binding-form ~@more)))))
@@ -0,0 +1,75 @@
+;; Copyright (c) Stephen C. Gilardi. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
+;; which can be found in the file CPL.TXT 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.
+;;
+;; File: def.clj
+;;
+;; def.clj provides variants of def that make including doc strings and
+;; making private definitions more succinct.
+;;
+;; scgilardi (gmail)
+;; 17 May 2008
+
+(ns clojure.contrib.def)
+
+(defmacro init-once
+ "Initializes a var exactly once. The var must already exist.
+ (NOTE: Since SVN 1008, Clojure includes defonce. Please use that instead
+ of init-once.)"
+ [var init]
+ `(let [v# (resolve '~var)]
+ (when-not (.isBound v#)
+ (.bindRoot v# ~init))))
+
+(defmacro defvar
+ "Defines a var with an optional intializer and doc string"
+ ([name]
+ (list `def name))
+ ([name init]
+ (list `def name init))
+ ([name init doc]
+ (list `def (with-meta name (assoc (meta name) :doc doc)) init)))
+
+(defmacro defunbound
+ "Defines an unbound var with optional doc string"
+ ([name]
+ (list `def name))
+ ([name doc]
+ (list `def (with-meta name (assoc (meta name) :doc doc)))))
+
+(defmacro defmacro-
+ "Same as defmacro but yields a private definition"
+ [name & decls]
+ (list* `defmacro (with-meta name (assoc (meta name) :private true)) decls))
+
+(defmacro defvar-
+ "Same as defvar but yields a private definition"
+ [name & decls]
+ (list* `defvar (with-meta name (assoc (meta name) :private true)) decls))
+
+(defmacro defunbound-
+ "Same as defunbound but yields a private definition"
+ [name & decls]
+ (list* `defunbound (with-meta name (assoc (meta name) :private true)) decls))
+
+(defmacro defstruct-
+ "Same as defstruct but yields a private definition"
+ [name & decls]
+ (list* `defstruct (with-meta name (assoc (meta name) :private true)) decls))
+
+(defmacro defalias
+ "Defines an alias for a var: a new var with the same value and metadata
+ as another with the exception of :namespace, :name, :file, :line, and
+ optionally :doc which are those of new var."
+ ([name orig]
+ `(let [v# (def ~name ~orig)]
+ (. v# (setMeta (merge (meta #'~orig) (meta #'~name))))
+ v#))
+ ([name orig doc]
+ `(let [v# (def ~name ~orig)]
+ (. v# (setMeta (merge (meta #'~orig) (assoc (meta #'~name) :doc ~doc))))
+ v#)))
@@ -0,0 +1,79 @@
+;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and
+;; distribution terms for this software are covered by the Common Public
+;; License 1.0 (http://opensource.org/licenses/cpl.php) which can be found
+;; in the file CPL.TXT 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.
+;;
+;; except.clj
+;;
+;; Provides functions that make it easy to specify the class and message
+;; when throwing an Exception or Error. The optional message is formatted
+;; using clojure/format.
+;;
+;; scgilardi (gmail)
+;; Created 07 July 2008
+
+(ns clojure.contrib.except
+ (:import (clojure.lang Reflector)))
+
+(declare throwable)
+
+(defn throwf
+ "Throws an Exception or Error with an optional message formatted using
+ clojure/format. All arguments are optional:
+
+ class? format? format-args*
+
+ - class defaults to Exception, if present it must name a kind of
+ Throwable
+ - format is a format string for clojure/format
+ - format-args are objects that correspond to format specifiers in
+ format."
+ [& args]
+ (throw (throwable args)))
+
+(defn throw-if
+ "Throws an Exception or Error if test is true. args are those documented
+ for throwf."
+ [test & args]
+ (when test
+ (throw (throwable args))))
+
+;; throw-if-not is synonymous with assert, but clojure/assert exists
+
+(defn throw-if-not
+ "Throws an Exception or Error if test is false. args are those documented
+ for throwf."
+ [test & args]
+ (when-not test
+ (throw (throwable args))))
+
+(defn throw-arg
+ "Throws an IllegalArgumentException. All arguments are optional:
+
+ format? format-args*
+
+ - format is a format string for clojure/format
+ - format-args are objects that correspond to format specifiers in
+ format."
+ [& args]
+ (throw (throwable (cons IllegalArgumentException args))))
+
+(defn- throwable
+ "Constructs a Throwable with an optional formatted message. Its stack
+ trace will begin with our caller's caller. Args are as described for
+ throwf except throwable accepts them as list rather than inline."
+ [args]
+ (let [[class & [fmt & fmt-args]] (if (class? (first args))
+ args
+ (cons Exception args))
+ ctor-args (into-array (if fmt [(apply format fmt fmt-args)] []))
+ throwable (Reflector/invokeConstructor class ctor-args)
+ our-prefix "clojure.contrib.except.throwable"
+ not-us? #(not (.startsWith (.getClassName %) our-prefix))
+ raw-trace (.getStackTrace throwable)
+ edited-trace (into-array (drop 3 (drop-while not-us? raw-trace)))]
+ (.setStackTrace throwable edited-trace)
+ throwable))
@@ -0,0 +1,92 @@
+;;; fcase.clj -- simple variants of "case" for Clojure
+
+;; by Stuart Sierra <mail@stuartsierra.com>
+;; April 7, 2008
+
+;; Copyright (c) 2008 Stuart Sierra. All rights reserved. The use and
+;; distribution terms for this software are covered by the Common
+;; Public License 1.0 (http://www.opensource.org/licenses/cpl1.0.php)
+;; which can be found in the file CPL.TXT 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.
+
+
+;; This file defines a generic "case" macro called "fcase" which takes
+;; the equality-testing function as an argument. It also defines a
+;; traditional "case" macro that tests using "=" and variants that
+;; test for regular expressions and class membership.
+
+
+(ns clojure.contrib.fcase)
+
+
+(defmacro fcase
+ "Generic switch/case macro. 'fcase' is short for 'function case'.
+
+ The 'compare-fn' is a fn of two arguments.
+
+ The 'test-expr-clauses' are value-expression pairs without
+ surrounding parentheses, like in Clojure's 'cond'.
+
+ The 'case-value' is evaluated once and cached. Then, 'compare-fn'
+ is called once for each clause, with the clause's test value as its
+ first argument and 'case-value' as its second argument. If
+ 'compare-fn' returns logical true, the clause's expression is
+ evaluated and returned. If 'compare-fn' returns false/nil, we go to
+ the next test value.
+
+ If 'test-expr-clauses' contains an odd number of items, the last
+ item is the default expression evaluated if no case-value matches.
+ If there is no default expression and no case-value matches, fcase
+ returns nil.
+
+ See specific forms of this macro in 'case' and 're-case'.
+
+ The test expressions in 'fcase' are always evaluated linearly, in
+ order. For a large number of case expressions it may be more
+ efficient to use a hash lookup."
+ [compare-fn case-value &
+ test-expr-clauses]
+ (let [test-val-sym (gensym "test_val")
+ test-fn-sym (gensym "test_fn")
+ cond-loop (fn this [clauses]
+ (cond
+ (>= (count clauses) 2)
+ (list 'if (list test-fn-sym (first clauses) test-val-sym)
+ (second clauses)
+ (this (rest (rest clauses))))
+ (= (count clauses) 1) (first clauses)))]
+ (list 'let [test-val-sym case-value, test-fn-sym compare-fn]
+ (cond-loop test-expr-clauses))))
+
+(defmacro case
+ "Like cond, but test-value is compared against the value of each
+ test expression with =. If they are equal, executes the \"body\"
+ expression. Optional last expression is executed if none of the
+ test expressions match."
+ [test-value & clauses]
+ `(fcase = ~test-value ~@clauses))
+
+(defmacro re-case
+ "Like case, but the test expressions are regular expressions, tested
+ with re-find."
+ [test-value & clauses]
+ `(fcase re-find ~test-value ~@clauses))
+
+(defmacro instance-case
+ "Like case, but the test expressions are Java class names, tested with
+ 'instance?'."
+ [test-value & clauses]
+ `(fcase instance? ~test-value ~@clauses))
+
+(defn- in-case-test [test-seq case-value]
+ (some (fn [item] (= item case-value))
+ test-seq))
+
+(defmacro in-case
+ "Like case, but test expressions are sequences. The test expression
+ is true if any item in the sequence is equal (tested with '=') to
+ the test value."
+ [test-value & clauses]
+ `(fcase in-case-test ~test-value ~@clauses))
@@ -0,0 +1,94 @@
+;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and
+;; distribution terms for this software are covered by the Common Public
+;; License 1.0 (http://opensource.org/licenses/cpl.php) which can be found
+;; in the file CPL.TXT 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.
+;;
+;; lazy-seqs
+;;
+;; == Lazy sequences ==
+;;
+;; primes - based on the "naive" implemention described in [1] plus a
+;; small "wheel" which eliminates multiples of 2, 3, 5, and
+;; 7 from consideration by incrementing past them. Also inspired
+;; by code from Christophe Grand in [2].
+;;
+;; fibs - based on code from Rich Hickey at the Clojure wiki [3]
+;;
+;; powers-of-2 - all the powers of 2
+;;
+;; == Lazy sequence functions ==
+;;
+;; rotations - returns a lazy seq of all the rotations of a seq
+;;
+;; permutations - returns a lazy seq of all the permutations of a seq
+;;
+;; [1] http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf
+;; [2] http://clj-me.blogspot.com/2008/06/primes.html
+;; [3] http://en.wikibooks.org/wiki/Clojure_Programming#Examples
+;;
+;; scgilardi (gmail)
+;; Created 07 June 2008
+
+(ns clojure.contrib.lazy-seqs
+ (:use clojure.contrib.def))
+
+(defvar primes
+ (lazy-cat [2 3 5 7]
+ (let [primes-from
+ (fn primes-from [n [f & r]]
+ (if (some #(zero? (rem n %))
+ (take-while #(<= (* % %) n) primes))
+ (recur (+ n f) r)
+ (lazy-cons n (primes-from (+ n f) r))))
+ wheel (cycle [2 4 2 4 6 2 6 4 2 4 6 6 2 6 4 2
+ 6 4 6 8 4 2 4 2 4 8 6 4 6 2 4 6
+ 2 6 6 4 2 4 6 2 6 4 2 4 2 10 2 10])]
+ (primes-from 11 wheel)))
+ "A lazy sequence of all the prime numbers.")
+
+(defvar fibs
+ (lazy-cat [0 1]
+ (let [rest-fn
+ (fn rest-fn [a b]
+ (let [next (+ a b)]
+ (lazy-cons next (rest-fn b next))))]
+ (rest-fn 0 1)))
+ "A lazy sequence of all the fibonacci numbers.")
+
+(defvar powers-of-2
+ (lazy-cons 1 (map #(bit-shift-left % 1) powers-of-2))
+ "A lazy sequence of all the powers of 2")
+
+(defn rotations
+ "Returns a lazy seq of all rotations of a seq"
+ [x]
+ (if (seq x)
+ (map
+ (fn [n _]
+ (lazy-cat (drop n x) (take n x)))
+ (iterate inc 0) x)
+ (list nil)))
+
+(defn permutations
+ "Returns a lazy seq of all permutations of a seq"
+ [x]
+ (if (seq x)
+ (mapcat
+ (fn [[f & r]]
+ (map #(cons f %) (permutations r)))
+ (rotations x))
+ (list nil)))
+
+(defn combinations
+ "Returns a lazy seq of all combinations built of one item from each seq given.
+ See also (doc for)"
+ [& acs]
+ (let [step (fn step [head [s & cs :as acs]]
+ (if acs
+ (mapcat #(step (conj head %) cs) s)
+ (list head)))]
+ (when acs
+ (step [] acs))))
Oops, something went wrong.

0 comments on commit 6f7a77e

Please sign in to comment.