pax_global_header00006660000000000000000000000064116110257000014503gustar00rootroot0000000000000052 comment=ba43ec197cd5855ecccf56127dd4702d8c49a27d clojure-contrib_1.2.0.orig/000077500000000000000000000000001161102570000156255ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/README.txt000066400000000000000000000054221161102570000173260ustar00rootroot00000000000000= Clojure-contrib = The user contributions library, clojure.contrib, is a collection of namespaces each of which implements features that we believe may be useful to a large part of the Clojure community. Clojure-contrib is open source under the Eclipse Public License and is copyrighted by Rich Hickey and the various contributors. Download releases from http://code.google.com/p/clojure-contrib/downloads The official source repository for clojure-contrib is http://github.com/richhickey/clojure-contrib Documentation and APIs are available at http://richhickey.github.com/clojure-contrib/ Issues are maintained in the Assembla space at http://www.assembla.com/spaces/clojure-contrib General discussion occurs in the Clojure Google group at http://groups.google.com/group/clojure and developer discussions are in the Clojure Dev Google group at http://groups.google.com/group/clojure-dev Compiled JARs of development snapshots are available at http://build.clojure.org/ = Building Clojure-contrib = If you downloaded a release distribution or pre-compiled JAR, you don't need to do anything. If you downloaded the sources from Github, you will need Apache Maven (2.0 or higher) to run the build. See http://maven.apache.org/ Run the following command in this directory: mvn package This will produce the file target/clojure-contrib-${VERSION}.jar that you can add to your Java classpath. Additional build commands are available: mvn clojure:repl To start a Clojure REPL (Read-Eval-Print Loop) mvn compile To compile sources without building a JAR mvn test To run unit tests mvn assembly:assembly To build ZIP/tar distributions containing source and JARs To skip the testing phase when building, add "-Dmaven.test.skip=true" to the mvn command line. == Compiling with Local clojure.jar == If you want to compile/build with a customized clojure.jar file, use the following command: mvn package -Dclojure.jar=/path/to/clojure.jar The /path/to/clojure.jar MUST be an absolute path. Maven will still download other dependencices, such as clojure-maven-plugin. = Clojure-contrib Versions = Versions of clojure-contrib are matched to versions of Clojure. If you are using Clojure 1.0, use clojure-contrib 1.0.* If you are using Clojure 1.1, use clojure-contrib 1.1.* If you are using Clojure from the "master" branch on Github, use clojure-contrib from the "master" branch on Github. If you are using Clojure from the "new" branch on Github, use clojure-contrib from the "new" branch on Github. = Clojure-contrib Committers = The following people are committers to the official clojure-contrib repositiory: Tom Faulhaber Stephen Gilardi Christophe Grand Rich Hickey Konrad Hinsen Stuart Holloway Chris Houser David Miller Stuart Sierra Frantisek Sodomka clojure-contrib_1.2.0.orig/Revisions000066400000000000000000000006321161102570000175320ustar00rootroot000000000000002008-08-16 All namespace-directory-aware libs have been moved to src/clojure/contrib. Please udpate your clojure classpaths accordingly. 2008-08-16 Revision 134 is the last to contain non-namespace-directory-aware libs at the top level of this repository. At the time of this writing, Clojure's SVN version is 1001. 2009-05-04 Revision 756 is the one that was current at the time Clojure 1.0.0 was released. clojure-contrib_1.2.0.orig/clojurescript/000077500000000000000000000000001161102570000205155ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/MANIFEST.MF000066400000000000000000000001301161102570000221410ustar00rootroot00000000000000Manifest-Version: 1.0 Main-Class: clojure.contrib.clojurescript.applet Class-Path: . clojure-contrib_1.2.0.orig/clojurescript/README.txt000066400000000000000000000022361161102570000222160ustar00rootroot00000000000000This directory contains work in progress on what may eventually become ClojureScript. It currently allows code written in a very small subset of Clojure to be automatically translated to JavaScript. tojs.clj is Clojure code to translate Clojure forms to Javascript. It was used to generate core.js from clojure's own core.clj and core_print.clj. To run any of the tests from the command line, do something like: java -cp ~/build/clojure/clojure.jar:/home/chouser/proj/clojure-contrib/src:src \ clojure.main src/clojure/contrib/clojurescript/cli.clj -- \ tests/t03.cljs > t03.js Now that you've got the .js file, you can test using Rhino: /usr/bin/java -jar /usr/share/java/js.jar \ -f src/clojure/contrib/clojurescript/rt.js \ -f src/clojure/contrib/clojurescript/core.js \ -f t03.js To build the applet from the compiled .class files, don't forget to: - Extract clojure code into the classes dir (cd classes; jar -x < ~/build/clojure/clojure.jar) - Produce the jar: jar cmf MANIFEST.MF clojurescript-applet.jar -C classes . There's plenty more to do. If you'd like to help, contact the Clojure Google group: clojure@googlegroups.com --Chouser 12 Jan 2009 clojure-contrib_1.2.0.orig/clojurescript/hashtopology.js000066400000000000000000000013411161102570000235720ustar00rootroot00000000000000// display topology of hashmaps, for debugging function maptop(x,d) { d = d || ""; var d2 = d + " "; var c = x.constructor.classname; print(d+c); switch(c) { case "PersistentHashMap": maptop(x._root,d2); break; case "BitmapIndexedNode": case "FullNode": for( var i = 0; i < x.nodes.length; ++i ) { maptop(x.nodes[i],d2); } break; case "HashCollisionNode": for( var i = 0; i < x.leaves.length; ++i ) { maptop(x.leaves[i],d2); } break; case "LeafNode": print( d2 + x.key() + " : " + x.val() ); break; } } y = clojure.lang.PersistentHashMap.EMPTY; for( var i = 0; i < 10; ++i ) { y = y.assoc( "a" + String.fromCharCode( 48 + i ), i ); maptop( y ); } clojure-contrib_1.2.0.orig/clojurescript/src/000077500000000000000000000000001161102570000213045ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/src/clojure/000077500000000000000000000000001161102570000227475ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/000077500000000000000000000000001161102570000244075ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript.clj000066400000000000000000000344051161102570000277770ustar00rootroot00000000000000; Copyright (c) Chris Houser, Sep 2008-Jan 2009. 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. ; Reads Clojure code and emits equivalent JavaScript (ns clojure.contrib.clojurescript (:import (clojure.lang Compiler Compiler$C Compiler$BodyExpr Compiler$DefExpr Compiler$InstanceMethodExpr)) (:require [clojure.contrib.duck-streams :as ds])) (defn- vstr [v] (let [sb (StringBuilder.) lvl (fn lvl [v] (doseq [i v] (if (vector? i) (lvl i) (.append sb (str i)))))] (lvl v) (str sb))) (def *debug-fn-names* true) (def *debug-comments* true) (def *eval-defmacro* true) ; used internally (def *has-recur*) (def *local-names* {}) (defmulti #^{:private true} tojs (fn [e ctx] (class e))) (defn- fnmethod [fm maxm ctx] (let [lm (into {} (for [[lb lb] (.locals fm)] [lb (str (.name lb) "_" (.idx lb))])) thisfn (first (filter #(= 0 (.idx %)) (keys lm))) [body has-recur] (binding [*has-recur* false] [(tojs (.body fm) (merge-with merge ctx {:localmap lm})) *has-recur*]) mparm (into {} (for [p (.reqParms maxm)] [(.idx p) p])) inits (concat (when has-recur ["_cnt" "_rtn"]) (vals (reduce dissoc lm (conj (.reqParms fm) thisfn (.restParm fm)))) (when (:fnname ctx) [(str (lm thisfn) "=arguments.callee")]) (when (not= fm maxm) (for [lb (.reqParms fm) :when (not= (.name lb) (.name (mparm (.idx lb))))] [(lm lb) "=arguments[" (dec (.idx lb)) "]"])) (when-let [lb (.restParm fm)] [(str (lm lb) "=clojure.JS.rest_args(this,arguments," (count (.reqParms fm)) ")")]))] (.reqParms maxm) (vstr [(when (seq inits) [(apply vector "var " (interpose "," inits)) ";\n"]) (if has-recur ["do{_cnt=0;_rtn=" body "\n}while(_cnt);return _rtn;"] ["return (" body ")"])]))) (defmethod tojs clojure.lang.Compiler$FnExpr [e ctx] (let [maxm (or (.variadicMethod e) (-> (into (sorted-map) (for [fm (.methods e) :when (not= fm (.variadicMethod e))] [(count (.reqParms fm)) fm])) last val)) manym (< 1 (count (.methods e))) newctx (assoc ctx :fnname (.thisName e)) [methods local-names] (binding [*local-names* *local-names*] [(into {} (for [fm (.methods e)] [fm (fnmethod fm maxm newctx)])) *local-names*])] (vstr [(when (.variadicMethod e) ["clojure.JS.variadic(" (count (.reqParms maxm)) ","]) "(function" (when *debug-fn-names* [" __" (.replaceAll (.name e) "[\\W_]+" "_")]) "(" (vec (interpose "," (for [lb (.reqParms maxm)] [(.name lb) "_" (.idx lb)]))) "){" ;"\n//" (vec (interpose "," (vals local-names))) "\n" (when manym ["switch(arguments.length){" (vec (for [[fm body] methods :when (not= fm maxm)] ["\ncase " (count (.reqParms fm)) ":" body])) "}"]) "\n" (methods maxm) "})" (when (.variadicMethod e) ")") ]))) (defmethod tojs clojure.lang.Compiler$BodyExpr [e ctx] (apply str (interpose ",\n" (map #(tojs % ctx) (.exprs e))))) (defmethod tojs clojure.lang.Compiler$LetExpr [e ctx] (let [inits (vec (interpose ",\n" (for [bi (.bindingInits e)] ["(" ((:localmap ctx) (.binding bi)) "=" (tojs (.init bi) ctx) ")"])))] (if (.isLoop e) (binding [*has-recur* false] (vstr ["((function" (when *debug-fn-names* " __loop") "(){var _rtn,_cnt;" inits ";" "do{_cnt=0;\n_rtn=" (tojs (.body e) ctx) "}while(_cnt);return _rtn;})())"])) (vstr ["(" inits ",\n" (tojs (.body e) ctx) ")"])))) (defmethod tojs clojure.lang.Compiler$VectorExpr [e ctx] (vstr ["clojure.JS.lit_vector([" (vec (interpose "," (map #(tojs % ctx) (.args e)))) "])"])) (defn- const-str [c] (cond (or (instance? Character c) (string? c)) (pr-str (str c)) (keyword? c) (str "clojure.core.keyword(\"" (namespace c) "\",\"" (name c) "\")") (symbol? c) (str "clojure.core.symbol(\"" c "\")") (class? c) (.getCanonicalName c) (list? c) (vstr ["clojure.JS.lit_list([" (vec (interpose "," (map const-str c))) "])"]) (fn? c) (str \" c \") (instance? java.util.regex.Pattern c) (str "(/" (.replace (str c) "/" "\\/") "/)") :else (str "(" c ")"))) (defmethod tojs clojure.lang.Compiler$ConstantExpr [e ctx] (const-str (.v e))) (def js-reserved '#{import boolean short byte char class}) (defn- var-munge [x] (let [n (-> x str Compiler/munge (.replace "." "_DOT_"))] (if (js-reserved (symbol n)) (str n "_") n))) (defn- var-parts [e] (let [{:keys [name ns]} (meta (.var e))] [(Compiler/munge (str (.getName ns))) (var-munge name)])) (defmethod tojs clojure.lang.Compiler$UnresolvedVarExpr [e ctx] (vstr ["clojure.JS.resolveVar(\"" (var-munge (name (.symbol e))) "\"," (Compiler/munge (name (.name *ns*))) ")"])) (defmethod tojs clojure.lang.Compiler$VarExpr [e ctx] (let [[vns vname] (var-parts e)] (if (and (= vns "clojurescript.js") (#{"this"} vname)) vname (str vns "." vname)))) (defmethod tojs clojure.lang.Compiler$TheVarExpr [e ctx] (let [[vns vname] (var-parts e)] (str vns "._var_" vname))) (defmethod tojs clojure.lang.Compiler$AssignExpr [e ctx] (let [target (.target e)] (if (instance? clojure.lang.Compiler$InstanceFieldExpr target) (vstr ["(" (tojs (.target target) ctx) "." (var-munge (.fieldName target)) "=" (tojs (.val e) ctx) ")"]) (let [[vns vname] (var-parts target)] (str vns "._var_" vname ".set(" (tojs (.val e) ctx) ")"))))) (defmethod tojs clojure.lang.Compiler$DefExpr [e ctx] (let [[vns vname] (var-parts e)] (str "clojure.JS.def(" vns ",\"" vname "\"," (tojs (.init e) ctx) ")"))) (defmethod tojs clojure.lang.Compiler$InvokeExpr [e ctx] (vstr [(tojs (.fexpr e) ctx) ".apply(null,[" (vec (interpose "," (map #(tojs % ctx) (.args e)))) "])"])) (defmethod tojs clojure.lang.Compiler$LocalBindingExpr [e ctx] (let [local-name ((:localmap ctx) (.b e))] (set! *local-names* (assoc *local-names* (.b e) local-name)) local-name)) (defmethod tojs clojure.lang.Compiler$NilExpr [e ctx] "null") (defmethod tojs clojure.lang.Compiler$EmptyExpr [e ctx] (str (.getCanonicalName (class (.coll e))) ".EMPTY")) (defmethod tojs clojure.lang.Compiler$StringExpr [e ctx] (const-str (.str e))) (defmethod tojs clojure.lang.Compiler$KeywordExpr [e ctx] (const-str (.k e))) (defmethod tojs clojure.lang.Compiler$StaticFieldExpr [e ctx] (str "clojure.JS.getOrRun(" (.getCanonicalName (.c e)) ",\"" (var-munge (.fieldName e)) "\")")) (defmethod tojs clojure.lang.Compiler$StaticMethodExpr [e ctx] (vstr [(.getCanonicalName (.c e)) "." (.methodName e) "(" (vec (interpose "," (map #(tojs % ctx) (.args e)))) ")"])) (defmethod tojs clojure.lang.Compiler$NewExpr [e ctx] (vstr ["(new " (.getCanonicalName (.c e)) "(" (vec (interpose "," (map #(tojs % ctx) (.args e)))) "))"])) (defmethod tojs clojure.lang.Compiler$InstanceMethodExpr [e ctx] (vstr ["(" (tojs (.target e) ctx) ")." (var-munge (.methodName e)) "(" (vec (interpose "," (map #(tojs % ctx) (.args e)))) ")"])) (defmethod tojs clojure.lang.Compiler$InstanceFieldExpr [e ctx] (vstr ["clojure.JS.getOrRun(" (tojs (.target e) ctx) ",\"" (var-munge (.fieldName e)) "\")"])) (defmethod tojs clojure.lang.Compiler$IfExpr [e ctx] (str "((" (tojs (.testExpr e) ctx) ")?(" (tojs (.thenExpr e) ctx) "):(" (tojs (.elseExpr e) ctx) "))")) (defmethod tojs clojure.lang.Compiler$RecurExpr [e ctx] (set! *has-recur* true) (vstr ["(_cnt=1,_rtn=[" (vec (interpose "," (map #(tojs % ctx) (.args e)))) "]" (vec (map #(str "," ((:localmap ctx) %1) "=_rtn[" %2 "]") (.loopLocals e) (iterate inc 0))) ")"])) (defmethod tojs clojure.lang.Compiler$MapExpr [e ctx] (vstr ["clojure.core.hash_map(" (vec (interpose "," (map #(tojs % ctx) (.keyvals e)))) ")"])) (defmethod tojs clojure.lang.Compiler$SetExpr [e ctx] (vstr ["clojure.core.hash_set(" (vec (interpose "," (map #(tojs % ctx) (.keys e)))) ")"])) (defmethod tojs clojure.lang.Compiler$BooleanExpr [e ctx] (if (.val e) "true" "false")) (defmethod tojs clojure.lang.Compiler$ThrowExpr [e ctx] (vstr ["(function" (when *debug-fn-names* " __throw") "(){throw " (tojs (.excExpr e) ctx) "})()"])) (defmethod tojs clojure.lang.Compiler$TryExpr [e ctx] (vstr ["(function" (when *debug-fn-names* " __try") "(){try{var _rtn=(" (tojs (.tryExpr e) ctx) ")}" (when (seq (.catchExprs e)) (when (not= 1 (count (.catchExprs e))) (throw (Exception. "tojs only supports one catch clause per try"))) (let [cc (first (.catchExprs e))] ["\ncatch(" ((:localmap ctx) (.lb cc)) "){_rtn=" (tojs (.handler cc) ctx) "}"])) (when (.finallyExpr e) ["\nfinally{" (tojs (.finallyExpr e) ctx) "}"]) "return _rtn})()"])) (defmulti toclj class) (defmethod toclj clojure.lang.Compiler$KeywordExpr [e] (.k e)) (defmethod toclj clojure.lang.Compiler$StringExpr [e] (.str e)) (defmethod toclj clojure.lang.Compiler$ConstantExpr [e] (.v e)) (def skip-def '#{;-- implemented directly in clj.js seq instance? assoc apply refer first rest import hash-map count find keys vals get class contains? print-method class? number? string? integer? nth to-array cons keyword symbol load ;-- not supported yet make-array to-array-2d re-pattern re-matcher re-groups re-seq re-matches re-find format ;-- macros defined without using defmacro let loop fn defn defmacro ;-- will probably never be supported in clojurescript eval resolve ns-resolve await await-for macroexpand macroexpand-1 load-reader load-string special-symbol? bigint bigdec floats doubles ints longs float-array double-array int-array long-array aset-int aset-long aset-boolean aset-float aset-double aset-short aset-char aset-byte slurp seque decimal? float? pmap primitives-classnames}) (def skip-method #{"java.lang.Class"}) (defn formtojs [f] (when-not (and (coll? f) (= 'definline (first f))) (let [expr (binding [*allow-unresolved-vars* true *compiler-analyze-only* true *private-compiler-loader* (clojure.lang.RT/baseLoader)] (Compiler/analyze Compiler$C/STATEMENT `((fn [] ~f)))) mainexpr (-> expr .fexpr .methods first .body .exprs first) defmacro? (and (instance? Compiler$BodyExpr mainexpr) (instance? Compiler$DefExpr (first (.exprs mainexpr))) (instance? Compiler$InstanceMethodExpr (second (.exprs mainexpr))) (= "setMacro" (.methodName (second (.exprs mainexpr)))))] (if defmacro? (when *eval-defmacro* (eval f) nil) (when-not (or (and (instance? Compiler$DefExpr mainexpr) (skip-def (:name (meta (.var mainexpr))))) (and (instance? Compiler$InstanceMethodExpr mainexpr) (or (= "setMacro" (.methodName mainexpr)) (and (= "addMethod" (.methodName mainexpr)) (skip-method (tojs (first (.args mainexpr)) nil))))) (and (instance? Compiler$BodyExpr mainexpr) (instance? Compiler$DefExpr (first (.exprs mainexpr))) (instance? Compiler$InstanceMethodExpr (second (.exprs mainexpr))) (= "setMacro" (.methodName (second (.exprs mainexpr)))))) (tojs expr {:localmap {}})))))) (defn filetojs [filename & optseq] (let [reader (java.io.PushbackReader. (ds/reader filename)) opts (apply array-map optseq)] (binding [*ns* (create-ns 'user) *debug-fn-names* (:debug-fn-names opts true) *debug-comments* (:debug-comments opts true) *eval-defmacro* (:eval-defmacro opts true)] (loop [] (let [f (read reader false reader false)] (when-not (identical? f reader) (if-let [js (formtojs f)] (do (when *debug-comments* (println "\n//======") (print "//") (prn f) (println "//---")) (println (str js ";")) (when (and (coll? f) (or (= 'ns (first f)) (= 'in-ns (first f)))) (eval f))) (when *debug-comments* (print "// Skipping: ") (prn f))) (recur))))))) clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/000077500000000000000000000000001161102570000272775ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/applet.clj000066400000000000000000000023741161102570000312640ustar00rootroot00000000000000; Copyright (c) Chris Houser, Jan 2009. 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. ; Applet that provides Clojure-to-JavaScript functionality to a browser (ns clojure.contrib.clojurescript.applet (:import (java.io PrintWriter StringReader)) (:gen-class :extends java.applet.Applet :methods [[tojs [String] Object]]) (:use [clojure.contrib.clojurescript :only (formtojs filetojs)]) (:require [clojure.contrib.duck-streams :as ds])) (defn -tojs [this cljstr] (try ["js" (with-out-str (filetojs (StringReader. cljstr) :debug-fn-names false :debug-comments false :eval-defmacro true))] (catch Throwable e (if (= (.getMessage e) "EOF while reading") ["incomplete"] ["err" (with-out-str (.printStackTrace e (PrintWriter. *out*)))])))) clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/cli.clj000066400000000000000000000044741161102570000305510ustar00rootroot00000000000000; Copyright (c) Chris Houser, Sep 2008-Jan 2009. 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. ; Command Line Interface for generating JavaScript from Clojure code. (ns clojure.contrib.clojurescript.cli (:import (java.io PrintWriter StringReader) (java.net URLDecoder)) (:use [clojure.contrib.command-line :only (with-command-line)] [clojure.contrib.clojurescript :only (formtojs filetojs)]) (:require [clojure.contrib.duck-streams :as ds])) (defn mkcore [] (binding [*out* (ds/writer "core.js")] (doseq [file ["clojure/core.clj" "clojure/core_print.clj"]] (filetojs (.getResourceAsStream (clojure.lang.RT/baseLoader) file))))) (defn simple-tests [] (println (formtojs '(defn foo ([a b c & d] (prn 3 a b c)) ([c] ;(String/asd "hello") ;(.foo 55) (let [[a b] [1 2]] (prn a b c) "hi"))))) (println (formtojs '(defn foo [a] (prn "hi") (let [a 5] (let [a 10] (prn "yo") (prn a)) (prn a)) (prn a)))) (println (formtojs '(defn x [] (conj [] (loop [i 5] (if (pos? i) (recur (- i 2)) i)))))) ;(println (formtojs '(binding [*out* 5] (set! *out* 10)))) (println (formtojs '(.replace "a/b/c" "/" "."))) (println (formtojs '(.getName ":foo"))) (println (formtojs '(list '(1 "str" 'sym :key) 4 "str2" 6 #{:set 9 8}))) (println (formtojs '(fn forever[] (forever)))) (println (formtojs '(fn forever[] (loop [] (recur)))))) (when-not *compile-files* (with-command-line *command-line-args* "clojurescript.cli -- Compile ClojureScript to JavaScript" [[simple? "Runs some simple built-in tests"] [mkcore? "Generates a core.js file"] [v? verbose? "Includes extra fn names and comments in js"] filenames] (cond simple? (simple-tests) mkcore? (mkcore) :else (doseq [filename filenames] (filetojs filename :debug-fn-names v? :debug-comments v?))))) clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/core.js000066400000000000000000011577631161102570000306110ustar00rootroot00000000000000 //====== //(ns clojure.core) //--- (function __user_fn_520(){ return (clojure.core.in_ns.apply(null,[clojure.core.symbol("clojure.core")]))}).apply(null,[]); //====== //(def unquote) //--- (function __clojure_core_fn_526(){ return (clojure.JS.def(clojure.core,"unquote",null))}).apply(null,[]); //====== //(def list (. clojure.lang.PersistentList creator)) //--- (function __clojure_core_fn_529(){ return (clojure.JS.def(clojure.core,"list",clojure.JS.getOrRun(clojure.lang.PersistentList,"creator")))}).apply(null,[]); // Skipping: (def cons (fn* cons [x seq] (. clojure.lang.RT (cons x seq)))) // Skipping: (def let (fn* let [& decl] (cons (quote let*) decl))) // Skipping: (def loop (fn* loop [& decl] (cons (quote loop*) decl))) // Skipping: (def fn (fn* fn [& decl] (cons (quote fn*) decl))) // Skipping: (def first (fn first [coll] (. clojure.lang.RT (first coll)))) // Skipping: (def rest (fn rest [x] (. clojure.lang.RT (rest x)))) //====== //(def conj (fn conj ([coll x] (. clojure.lang.RT (conj coll x))) ([coll x & xs] (if xs (recur (conj coll x) (first xs) (rest xs)) (conj coll x))))) //--- (function __clojure_core_fn_562(){ return (clojure.JS.def(clojure.core,"conj",clojure.JS.variadic(2,(function __clojure_core_fn_562_conj_564(coll_1,x_2){switch(arguments.length){ case 2:var conj_0=arguments.callee; return (clojure.lang.RT.conj(coll_1,x_2))} var _cnt,_rtn,conj_0=arguments.callee,xs_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((xs_3)?((_cnt=1,_rtn=[conj_0.apply(null,[coll_1,x_2]),clojure.core.first.apply(null,[xs_3]),clojure.core.rest.apply(null,[xs_3])],coll_1=_rtn[0],x_2=_rtn[1],xs_3=_rtn[2])):(conj_0.apply(null,[coll_1,x_2]))) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(def second (fn second [x] (first (rest x)))) //--- (function __clojure_core_fn_567(){ return (clojure.JS.def(clojure.core,"second",(function __clojure_core_fn_567_second_569(x_1){ var second_0=arguments.callee; return (clojure.core.first.apply(null,[clojure.core.rest.apply(null,[x_1])]))})))}).apply(null,[]); //====== //(def ffirst (fn ffirst [x] (first (first x)))) //--- (function __clojure_core_fn_572(){ return (clojure.JS.def(clojure.core,"ffirst",(function __clojure_core_fn_572_ffirst_574(x_1){ var ffirst_0=arguments.callee; return (clojure.core.first.apply(null,[clojure.core.first.apply(null,[x_1])]))})))}).apply(null,[]); //====== //(def rfirst (fn rfirst [x] (rest (first x)))) //--- (function __clojure_core_fn_577(){ return (clojure.JS.def(clojure.core,"rfirst",(function __clojure_core_fn_577_rfirst_579(x_1){ var rfirst_0=arguments.callee; return (clojure.core.rest.apply(null,[clojure.core.first.apply(null,[x_1])]))})))}).apply(null,[]); //====== //(def frest (fn frest [x] (first (rest x)))) //--- (function __clojure_core_fn_582(){ return (clojure.JS.def(clojure.core,"frest",(function __clojure_core_fn_582_frest_584(x_1){ var frest_0=arguments.callee; return (clojure.core.first.apply(null,[clojure.core.rest.apply(null,[x_1])]))})))}).apply(null,[]); //====== //(def rrest (fn rrest [x] (rest (rest x)))) //--- (function __clojure_core_fn_587(){ return (clojure.JS.def(clojure.core,"rrest",(function __clojure_core_fn_587_rrest_589(x_1){ var rrest_0=arguments.callee; return (clojure.core.rest.apply(null,[clojure.core.rest.apply(null,[x_1])]))})))}).apply(null,[]); // Skipping: (def seq (fn seq [coll] (. clojure.lang.RT (seq coll)))) // Skipping: (def instance? (fn instance? [c x] (. c (isInstance x)))) //====== //(def seq? (fn seq? [x] (instance? clojure.lang.ISeq x))) //--- (function __clojure_core_fn_602(){ return (clojure.JS.def(clojure.core,"seq_QMARK_",(function __clojure_core_fn_602_seq_QMARK_604(x_1){ var seq_QMARK__0=arguments.callee; return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.ISeq,x_1]))})))}).apply(null,[]); // Skipping: (def string? (fn string? [x] (instance? String x))) //====== //(def map? (fn map? [x] (instance? clojure.lang.IPersistentMap x))) //--- (function __clojure_core_fn_612(){ return (clojure.JS.def(clojure.core,"map_QMARK_",(function __clojure_core_fn_612_map_QMARK_614(x_1){ var map_QMARK__0=arguments.callee; return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.IPersistentMap,x_1]))})))}).apply(null,[]); //====== //(def vector? (fn vector? [x] (instance? clojure.lang.IPersistentVector x))) //--- (function __clojure_core_fn_617(){ return (clojure.JS.def(clojure.core,"vector_QMARK_",(function __clojure_core_fn_617_vector_QMARK_619(x_1){ var vector_QMARK__0=arguments.callee; return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.IPersistentVector,x_1]))})))}).apply(null,[]); //====== //(def sigs (fn [fdecl] (if (seq? (first fdecl)) (loop [ret [] fdecl fdecl] (if fdecl (recur (conj ret (first (first fdecl))) (rest fdecl)) (seq ret))) (list (first fdecl))))) //--- (function __clojure_core_fn_622(){ return (clojure.JS.def(clojure.core,"sigs",(function __clojure_core_fn_622_sigs_624(fdecl_1){ var ret_2,fdecl_3; return (((clojure.core.seq_QMARK_.apply(null,[clojure.core.first.apply(null,[fdecl_1])]))?(((function __loop(){var _rtn,_cnt;(ret_2=clojure.lang.PersistentVector.EMPTY), (fdecl_3=fdecl_1);do{_cnt=0; _rtn=((fdecl_3)?((_cnt=1,_rtn=[clojure.core.conj.apply(null,[ret_2,clojure.core.first.apply(null,[clojure.core.first.apply(null,[fdecl_3])])]),clojure.core.rest.apply(null,[fdecl_3])],ret_2=_rtn[0],fdecl_3=_rtn[1])):(clojure.core.seq.apply(null,[ret_2])))}while(_cnt);return _rtn;})())):(clojure.core.list.apply(null,[clojure.core.first.apply(null,[fdecl_1])]))))})))}).apply(null,[]); // Skipping: (def assoc (fn assoc ([map key val] (. clojure.lang.RT (assoc map key val))) ([map key val & kvs] (let [ret (assoc map key val)] (if kvs (recur ret (first kvs) (second kvs) (rrest kvs)) ret))))) //====== //(def meta (fn meta [x] (if (instance? clojure.lang.IMeta x) (. x (meta))))) //--- (function __clojure_core_fn_633(){ return (clojure.JS.def(clojure.core,"meta",(function __clojure_core_fn_633_meta_635(x_1){ var meta_0=arguments.callee; return (((clojure.core.instance_QMARK_.apply(null,[clojure.lang.IMeta,x_1]))?((x_1).meta()):(null)))})))}).apply(null,[]); //====== //(def with-meta (fn with-meta [x m] (. x (withMeta m)))) //--- (function __clojure_core_fn_638(){ return (clojure.JS.def(clojure.core,"with_meta",(function __clojure_core_fn_638_with_meta_640(x_1,m_2){ var with_meta_0=arguments.callee; return ((x_1).withMeta(m_2))})))}).apply(null,[]); //====== //(def last (fn last [s] (if (rest s) (recur (rest s)) (first s)))) //--- (function __clojure_core_fn_643(){ return (clojure.JS.def(clojure.core,"last",(function __clojure_core_fn_643_last_645(s_1){ var _cnt,_rtn,last_0=arguments.callee; do{_cnt=0;_rtn=((clojure.core.rest.apply(null,[s_1]))?((_cnt=1,_rtn=[clojure.core.rest.apply(null,[s_1])],s_1=_rtn[0])):(clojure.core.first.apply(null,[s_1]))) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(def butlast (fn butlast [s] (loop [ret [] s s] (if (rest s) (recur (conj ret (first s)) (rest s)) (seq ret))))) //--- (function __clojure_core_fn_648(){ return (clojure.JS.def(clojure.core,"butlast",(function __clojure_core_fn_648_butlast_650(s_1){ var ret_2,s_3,butlast_0=arguments.callee; return (((function __loop(){var _rtn,_cnt;(ret_2=clojure.lang.PersistentVector.EMPTY), (s_3=s_1);do{_cnt=0; _rtn=((clojure.core.rest.apply(null,[s_3]))?((_cnt=1,_rtn=[clojure.core.conj.apply(null,[ret_2,clojure.core.first.apply(null,[s_3])]),clojure.core.rest.apply(null,[s_3])],ret_2=_rtn[0],s_3=_rtn[1])):(clojure.core.seq.apply(null,[ret_2])))}while(_cnt);return _rtn;})()))})))}).apply(null,[]); // Skipping: (def defn (fn defn [name & fdecl] (let [m (if (string? (first fdecl)) {:doc (first fdecl)} {}) fdecl (if (string? (first fdecl)) (rest fdecl) fdecl) m (if (map? (first fdecl)) (conj m (first fdecl)) m) fdecl (if (map? (first fdecl)) (rest fdecl) fdecl) fdecl (if (vector? (first fdecl)) (list fdecl) fdecl) m (if (map? (last fdecl)) (conj m (last fdecl)) m) fdecl (if (map? (last fdecl)) (butlast fdecl) fdecl) m (conj {:arglists (list (quote quote) (sigs fdecl))} m)] (list (quote def) (with-meta name (conj (if (meta name) (meta name) {}) m)) (cons (quote clojure.core/fn) fdecl))))) // Skipping: (. (var defn) (setMacro)) //====== //(defn cast "Throws a ClassCastException if x is not a c, else returns x." [c x] (. c (cast x))) //--- (function __clojure_core_fn_661(){ return (clojure.JS.def(clojure.core,"cast",(function __clojure_core_fn_661_cast_663(c_1,x_2){ return ((c_1).cast(x_2))})))}).apply(null,[]); // Skipping: (defn to-array "Returns an array of Objects containing the contents of coll, which\n can be any Collection. Maps to java.util.Collection.toArray()." [coll] (. clojure.lang.RT (toArray coll))) //====== //(defn vector "Creates a new vector containing the args." ([] []) ([& args] (. clojure.lang.LazilyPersistentVector (create args)))) //--- (function __clojure_core_fn_673(){ return (clojure.JS.def(clojure.core,"vector",clojure.JS.variadic(0,(function __clojure_core_fn_673_vector_675(){switch(arguments.length){ case 0:return (clojure.lang.PersistentVector.EMPTY)} var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.LazilyPersistentVector.create(args_1))}))))}).apply(null,[]); //====== //(defn vec "Creates a new vector containing the contents of coll." ([coll] (. clojure.lang.LazilyPersistentVector (createOwning (to-array coll))))) //--- (function __clojure_core_fn_680(){ return (clojure.JS.def(clojure.core,"vec",(function __clojure_core_fn_680_vec_682(coll_1){ return (clojure.lang.LazilyPersistentVector.createOwning(clojure.core.to_array.apply(null,[coll_1])))})))}).apply(null,[]); // Skipping: (defn hash-map "keyval => key val\n Returns a new hash map with supplied mappings." ([] {}) ([& keyvals] (. clojure.lang.PersistentHashMap (create keyvals)))) //====== //(defn hash-set "Returns a new hash set with supplied keys." ([] #{}) ([& keys] (. clojure.lang.PersistentHashSet (create keys)))) //--- (function __clojure_core_fn_693(){ return (clojure.JS.def(clojure.core,"hash_set",clojure.JS.variadic(0,(function __clojure_core_fn_693_hash_set_695(){switch(arguments.length){ case 0:return (clojure.lang.PersistentHashSet.EMPTY)} var keys_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.PersistentHashSet.create(keys_1))}))))}).apply(null,[]); //====== //(defn sorted-map "keyval => key val\n Returns a new sorted map with supplied mappings." ([& keyvals] (. clojure.lang.PersistentTreeMap (create keyvals)))) //--- (function __clojure_core_fn_700(){ return (clojure.JS.def(clojure.core,"sorted_map",clojure.JS.variadic(0,(function __clojure_core_fn_700_sorted_map_702(){ var keyvals_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.PersistentTreeMap.create(keyvals_1))}))))}).apply(null,[]); //====== //(defn sorted-set "Returns a new sorted set with supplied keys." ([& keys] (. clojure.lang.PersistentTreeSet (create keys)))) //--- (function __clojure_core_fn_706(){ return (clojure.JS.def(clojure.core,"sorted_set",clojure.JS.variadic(0,(function __clojure_core_fn_706_sorted_set_708(){ var keys_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.PersistentTreeSet.create(keys_1))}))))}).apply(null,[]); //====== //(defn sorted-map-by "keyval => key val\n Returns a new sorted map with supplied mappings, using the supplied comparator." ([comparator & keyvals] (. clojure.lang.PersistentTreeMap (create comparator keyvals)))) //--- (function __clojure_core_fn_712(){ return (clojure.JS.def(clojure.core,"sorted_map_by",clojure.JS.variadic(1,(function __clojure_core_fn_712_sorted_map_by_714(comparator_1){ var keyvals_2=clojure.JS.rest_args(this,arguments,1); return (clojure.lang.PersistentTreeMap.create(comparator_1,keyvals_2))}))))}).apply(null,[]); // Skipping: (def defmacro (fn [name & args] (list (quote do) (cons (quote clojure.core/defn) (cons name args)) (list (quote .) (list (quote var) name) (quote (setMacro)))))) // Skipping: (. (var defmacro) (setMacro)) // Skipping: (defmacro when "Evaluates test. If logical true, evaluates body in an implicit do." [test & body] (list (quote if) test (cons (quote do) body))) // Skipping: (defmacro when-not "Evaluates test. If logical false, evaluates body in an implicit do." [test & body] (list (quote if) test nil (cons (quote do) body))) //====== //(defn nil? "Returns true if x is nil, false otherwise." {:tag Boolean} [x] (identical? x nil)) //--- (function __clojure_core_fn_745(){ return (clojure.JS.def(clojure.core,"nil_QMARK_",(function __clojure_core_fn_745_nil_QMARK_747(x_1){ return (clojure.core.identical_QMARK_.apply(null,[x_1,null]))})))}).apply(null,[]); //====== //(defn false? "Returns true if x is the value false, false otherwise." {:tag Boolean} [x] (identical? x false)) //--- (function __clojure_core_fn_751(){ return (clojure.JS.def(clojure.core,"false_QMARK_",(function __clojure_core_fn_751_false_QMARK_753(x_1){ return (clojure.core.identical_QMARK_.apply(null,[x_1,false]))})))}).apply(null,[]); //====== //(defn true? "Returns true if x is the value true, false otherwise." {:tag Boolean} [x] (identical? x true)) //--- (function __clojure_core_fn_757(){ return (clojure.JS.def(clojure.core,"true_QMARK_",(function __clojure_core_fn_757_true_QMARK_759(x_1){ return (clojure.core.identical_QMARK_.apply(null,[x_1,true]))})))}).apply(null,[]); //====== //(defn not "Returns true if x is logical false, false otherwise." {:tag Boolean} [x] (if x false true)) //--- (function __clojure_core_fn_763(){ return (clojure.JS.def(clojure.core,"not",(function __clojure_core_fn_763_not_765(x_1){ return (((x_1)?(false):(true)))})))}).apply(null,[]); //====== //(defn str "With no args, returns the empty string. With one arg x, returns\n x.toString(). (str nil) returns the empty string. With more than\n one arg, returns the concatenation of the str values of the args." {:tag String} ([] "") ([x] (if (nil? x) "" (. x (toString)))) ([x & ys] ((fn [sb more] (if more (recur (. sb (append (str (first more)))) (rest more)) (str sb))) (clojure.lang.RT/makeStringBuilder (str x)) ys))) //--- (function __clojure_core_fn_769(){ return (clojure.JS.def(clojure.core,"str",clojure.JS.variadic(1,(function __clojure_core_fn_769_str_771(x_1){switch(arguments.length){ case 0:return ("") case 1:return (((clojure.core.nil_QMARK_.apply(null,[x_1]))?(""):((x_1).toString())))} var ys_2=clojure.JS.rest_args(this,arguments,1); return ((function __clojure_core_fn_769_str_771_fn_775(sb_1,more_2){ var _cnt,_rtn; do{_cnt=0;_rtn=((more_2)?((_cnt=1,_rtn=[(sb_1).append(clojure.core.str.apply(null,[clojure.core.first.apply(null,[more_2])])),clojure.core.rest.apply(null,[more_2])],sb_1=_rtn[0],more_2=_rtn[1])):(clojure.core.str.apply(null,[sb_1]))) }while(_cnt);return _rtn;}).apply(null,[clojure.lang.RT.makeStringBuilder(clojure.core.str.apply(null,[x_1])),ys_2]))}))))}).apply(null,[]); //====== //(defn symbol? "Return true if x is a Symbol" [x] (instance? clojure.lang.Symbol x)) //--- (function __clojure_core_fn_780(){ return (clojure.JS.def(clojure.core,"symbol_QMARK_",(function __clojure_core_fn_780_symbol_QMARK_782(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Symbol,x_1]))})))}).apply(null,[]); //====== //(defn keyword? "Return true if x is a Keyword" [x] (instance? clojure.lang.Keyword x)) //--- (function __clojure_core_fn_786(){ return (clojure.JS.def(clojure.core,"keyword_QMARK_",(function __clojure_core_fn_786_keyword_QMARK_788(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Keyword,x_1]))})))}).apply(null,[]); // Skipping: (defn symbol "Returns a Symbol with the given namespace and name." ([name] (if (symbol? name) name (. clojure.lang.Symbol (intern name)))) ([ns name] (. clojure.lang.Symbol (intern ns name)))) // Skipping: (defn keyword "Returns a Keyword with the given namespace and name. Do not use :\n in the keyword strings, it will be added automatically." ([name] (if (keyword? name) name (. clojure.lang.Keyword (intern nil name)))) ([ns name] (. clojure.lang.Keyword (intern ns name)))) //====== //(defn gensym "Returns a new symbol with a unique name. If a prefix string is\n supplied, the name is prefix# where # is some unique number. If\n prefix is not supplied, the prefix is 'G__'." ([] (gensym "G__")) ([prefix-string] (. clojure.lang.Symbol (intern (str prefix-string (str (. clojure.lang.RT (nextID)))))))) //--- (function __clojure_core_fn_806(){ return (clojure.JS.def(clojure.core,"gensym",(function __clojure_core_fn_806_gensym_808(prefix_string_1){switch(arguments.length){ case 0:return (clojure.core.gensym.apply(null,["G__"]))} return (clojure.lang.Symbol.intern(clojure.core.str.apply(null,[prefix_string_1,clojure.core.str.apply(null,[clojure.lang.RT.nextID()])])))})))}).apply(null,[]); // Skipping: (defmacro cond "Takes a set of test/expr pairs. It evaluates each test one at a\n time. If a test returns logical true, cond evaluates and returns\n the value of the corresponding expr and doesn't evaluate any of the\n other tests or exprs. (cond) returns nil." [& clauses] (when clauses (list (quote if) (first clauses) (if (rest clauses) (second clauses) (throw (IllegalArgumentException. "cond requires an even number of forms"))) (cons (quote clojure.core/cond) (rest (rest clauses)))))) //====== //(defn spread {:private true} [arglist] (cond (nil? arglist) nil (nil? (rest arglist)) (seq (first arglist)) :else (cons (first arglist) (spread (rest arglist))))) //--- (function __clojure_core_fn_822(){ return (clojure.JS.def(clojure.core,"spread",(function __clojure_core_fn_822_spread_824(arglist_1){ return (((clojure.core.nil_QMARK_.apply(null,[arglist_1]))?(null):(((clojure.core.nil_QMARK_.apply(null,[clojure.core.rest.apply(null,[arglist_1])]))?(clojure.core.seq.apply(null,[clojure.core.first.apply(null,[arglist_1])])):(((clojure.core.keyword("","else"))?(clojure.core.cons.apply(null,[clojure.core.first.apply(null,[arglist_1]),clojure.core.spread.apply(null,[clojure.core.rest.apply(null,[arglist_1])])])):(null)))))))})))}).apply(null,[]); // Skipping: (defn apply "Applies fn f to the argument list formed by prepending args to argseq." {:arglists (quote ([f args* argseq]))} [f & args] (. f (applyTo (spread args)))) //====== //(defn vary-meta "Returns an object of the same type and value as obj, with\n (apply f (meta obj) args) as its metadata." [obj f & args] (with-meta obj (apply f (meta obj) args))) //--- (function __clojure_core_fn_834(){ return (clojure.JS.def(clojure.core,"vary_meta",clojure.JS.variadic(2,(function __clojure_core_fn_834_vary_meta_836(obj_1,f_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.with_meta.apply(null,[obj_1,clojure.core.apply.apply(null,[f_2,clojure.core.meta.apply(null,[obj_1]),args_3])]))}))))}).apply(null,[]); //====== //(defn list* "Creates a new list containing the item prepended to more." [item & more] (spread (cons item more))) //--- (function __clojure_core_fn_840(){ return (clojure.JS.def(clojure.core,"list_STAR_",clojure.JS.variadic(1,(function __clojure_core_fn_840_list_STAR_842(item_1){ var more_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.spread.apply(null,[clojure.core.cons.apply(null,[item_1,more_2])]))}))))}).apply(null,[]); // Skipping: (defmacro delay "Takes a body of expressions and yields a Delay object that will\n invoke the body only the first time it is forced (with force), and\n will cache the result and return it on all subsequent force calls" [& body] (list (quote new) (quote clojure.lang.Delay) (list* (quote clojure.core/fn) [] body))) //====== //(defn delay? "returns true if x is a Delay created with delay" [x] (instance? clojure.lang.Delay x)) //--- (function __clojure_core_fn_855(){ return (clojure.JS.def(clojure.core,"delay_QMARK_",(function __clojure_core_fn_855_delay_QMARK_857(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Delay,x_1]))})))}).apply(null,[]); //====== //(defn force "If x is a Delay, returns the (possibly cached) value of its expression, else returns x" [x] (. clojure.lang.Delay (force x))) //--- (function __clojure_core_fn_861(){ return (clojure.JS.def(clojure.core,"force",(function __clojure_core_fn_861_force_863(x_1){ return (clojure.lang.Delay.force(x_1))})))}).apply(null,[]); //====== //(defn fnseq "Returns a seq object whose first is first and whose rest is the\n value produced by calling restfn with no arguments. restfn will be\n called at most once per step in the sequence, e.g. calling rest\n repeatedly on the head of the seq calls restfn once - the value it\n yields is cached." [first restfn] (new clojure.lang.FnSeq first restfn)) //--- (function __clojure_core_fn_867(){ return (clojure.JS.def(clojure.core,"fnseq",(function __clojure_core_fn_867_fnseq_869(first_1,restfn_2){ return ((new clojure.lang.FnSeq(first_1,restfn_2)))})))}).apply(null,[]); // Skipping: (defmacro lazy-cons "Expands to code which produces a seq object whose first is\n first-expr and whose rest is rest-expr, neither of which is\n evaluated until first/rest is called. Each expr will be evaluated at most\n once per step in the sequence, e.g. calling first/rest repeatedly on the\n same node of the seq evaluates first/rest-expr once - the values they yield are\n cached." [first-expr & rest-expr] (list (quote new) (quote clojure.lang.LazyCons) (list (quote clojure.core/fn) (list [] first-expr) (list* [(gensym)] rest-expr)))) //====== //(defn cache-seq "Given a seq s, returns a lazy seq that will touch each element of s\n at most once, caching the results." [s] (when s (clojure.lang.CachedSeq. s))) //--- (function __clojure_core_fn_882(){ return (clojure.JS.def(clojure.core,"cache_seq",(function __clojure_core_fn_882_cache_seq_884(s_1){ return (((s_1)?((new clojure.lang.CachedSeq(s_1))):(null)))})))}).apply(null,[]); //====== //(defn concat "Returns a lazy seq representing the concatenation of\tthe elements in the supplied colls." ([] nil) ([x] (seq x)) ([x y] (if (seq x) (lazy-cons (first x) (concat (rest x) y)) (seq y))) ([x y & zs] (let [cat (fn cat [xys zs] (if (seq xys) (lazy-cons (first xys) (cat (rest xys) zs)) (when zs (recur (first zs) (rest zs)))))] (cat (concat x y) zs)))) //--- (function __clojure_core_fn_888(){ return (clojure.JS.def(clojure.core,"concat",clojure.JS.variadic(2,(function __clojure_core_fn_888_concat_890(x_1,y_2){switch(arguments.length){ case 0:return (null) case 1:return (clojure.core.seq.apply(null,[x_1])) case 2:return (((clojure.core.seq.apply(null,[x_1]))?((new clojure.lang.LazyCons((function __clojure_core_fn_888_concat_890_fn_895(G__894_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[x_1]))} return (clojure.core.concat.apply(null,[clojure.core.rest.apply(null,[x_1]),y_2]))})))):(clojure.core.seq.apply(null,[y_2]))))} var cat_4,zs_3=clojure.JS.rest_args(this,arguments,2); return (((cat_4=(function __clojure_core_fn_888_concat_890_cat_900(xys_1,zs_2){ var _cnt,_rtn,cat_0=arguments.callee; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[xys_1]))?((new clojure.lang.LazyCons((function __clojure_core_fn_888_concat_890_cat_900_fn_902(G__901_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[xys_1]))} return (cat_0.apply(null,[clojure.core.rest.apply(null,[xys_1]),zs_2]))})))):(((zs_2)?((_cnt=1,_rtn=[clojure.core.first.apply(null,[zs_2]),clojure.core.rest.apply(null,[zs_2])],xys_1=_rtn[0],zs_2=_rtn[1])):(null)))) }while(_cnt);return _rtn;})), cat_4.apply(null,[clojure.core.concat.apply(null,[x_1,y_2]),zs_3])))}))))}).apply(null,[]); // Skipping: (defmacro if-not "Evaluates test. If logical false, evaluates and returns then expr, otherwise else expr, if supplied, else nil." ([test then] (clojure.core/concat (clojure.core/list (quote clojure.core/if-not)) (clojure.core/list test) (clojure.core/list then) (clojure.core/list (quote nil)))) ([test then else] (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/not)) (clojure.core/list test))) (clojure.core/list then) (clojure.core/list else)))) //====== //(defn = "Equality. Returns true if x equals y, false if not. Same as\n Java x.equals(y) except it also works for nil, and compares\n numbers and collections in a type-independent manner. Clojure's immutable data\n structures define equals() (and thus =) as a value, not an identity,\n comparison." {:tag Boolean, :inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Util)) (clojure.core/list (quote clojure.core/equiv)) (clojure.core/list x) (clojure.core/list y))), :inline-arities #{2}} ([x] true) ([x y] (clojure.lang.Util/equiv x y)) ([x y & more] (if (= x y) (if (rest more) (recur y (first more) (rest more)) (= y (first more))) false))) //--- (function __clojure_core_fn_920(){ return (clojure.JS.def(clojure.core,"_EQ_",clojure.JS.variadic(2,(function __clojure_core_fn_920_EQ_925(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.lang.Util.equiv(x_1,y_2))} var _cnt,_rtn,more_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((clojure.lang.Util.equiv(x_1,y_2))?(((clojure.core.rest.apply(null,[more_3]))?((_cnt=1,_rtn=[y_2,clojure.core.first.apply(null,[more_3]),clojure.core.rest.apply(null,[more_3])],x_1=_rtn[0],y_2=_rtn[1],more_3=_rtn[2])):(clojure.lang.Util.equiv(y_2,clojure.core.first.apply(null,[more_3]))))):(false)) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn not= "Same as (not (= obj1 obj2))" {:tag Boolean} ([x] false) ([x y] (not (= x y))) ([x y & more] (not (apply = x y more)))) //--- (function __clojure_core_fn_931(){ return (clojure.JS.def(clojure.core,"not_EQ_",clojure.JS.variadic(2,(function __clojure_core_fn_931_not_EQ_933(x_1,y_2){switch(arguments.length){ case 1:return (false) case 2:return (clojure.core.not.apply(null,[clojure.lang.Util.equiv(x_1,y_2)]))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.not.apply(null,[clojure.core.apply.apply(null,[clojure.core._EQ_,x_1,y_2,more_3])]))}))))}).apply(null,[]); //====== //(defn compare "Comparator. Returns 0 if x equals y, -1 if x is logically 'less\n than' y, else 1. Same as Java x.compareTo(y) except it also works\n for nil, and compares numbers and collections in a type-independent\n manner. x must implement Comparable" {:tag Integer, :inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Util)) (clojure.core/list (quote clojure.core/compare)) (clojure.core/list x) (clojure.core/list y)))} [x y] (. clojure.lang.Util (compare x y))) //--- (function __clojure_core_fn_939(){ return (clojure.JS.def(clojure.core,"compare",(function __clojure_core_fn_939_compare_944(x_1,y_2){ return (clojure.lang.Util.compare(x_1,y_2))})))}).apply(null,[]); // Skipping: (defmacro and "Evaluates exprs one at a time, from left to right. If a form\n returns logical false (nil or false), and returns that value and\n doesn't evaluate any of the other expressions, otherwise it returns\n the value of the last expr. (and) returns true." ([] true) ([x] x) ([x & rest] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote and__948__auto__)) (clojure.core/list x)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (quote and__948__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/and)) rest)) (clojure.core/list (quote and__948__auto__))))))) // Skipping: (defmacro or "Evaluates exprs one at a time, from left to right. If a form\n returns a logical true value, or returns that value and doesn't\n evaluate any of the other expressions, otherwise it returns the\n value of the last expression. (or) returns nil." ([] nil) ([x] x) ([x & rest] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote or__962__auto__)) (clojure.core/list x)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (quote or__962__auto__)) (clojure.core/list (quote or__962__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/or)) rest))))))) //====== //(defn reduce "f should be a function of 2 arguments. If val is not supplied,\n returns the result of applying f to the first 2 items in coll, then\n applying f to that result and the 3rd item, etc. If coll contains no\n items, f must accept no arguments as well, and reduce returns the\n result of calling f with no arguments. If coll has only 1 item, it\n is returned and f is not called. If val is supplied, returns the\n result of applying f to val and the first item in coll, then\n applying f to that result and the 2nd item, etc. If coll contains no\n items, returns val and f is not called." ([f coll] (let [s (seq coll)] (if s (if (instance? clojure.lang.IReduce s) (. s (reduce f)) (reduce f (first s) (rest s))) (f)))) ([f val coll] (let [s (seq coll)] (if (instance? clojure.lang.IReduce s) (. s (reduce f val)) ((fn [f val s] (if s (recur f (f val (first s)) (rest s)) val)) f val s))))) //--- (function __clojure_core_fn_976(){ return (clojure.JS.def(clojure.core,"reduce",(function __clojure_core_fn_976_reduce_978(f_1,val_2,coll_3){switch(arguments.length){ case 2:var s_3,coll_2=arguments[1]; return (((s_3=clojure.core.seq.apply(null,[coll_2])), ((s_3)?(((clojure.core.instance_QMARK_.apply(null,[clojure.lang.IReduce,s_3]))?((s_3).reduce(f_1)):(clojure.core.reduce.apply(null,[f_1,clojure.core.first.apply(null,[s_3]),clojure.core.rest.apply(null,[s_3])])))):(f_1.apply(null,[])))))} var s_4; return (((s_4=clojure.core.seq.apply(null,[coll_3])), ((clojure.core.instance_QMARK_.apply(null,[clojure.lang.IReduce,s_4]))?((s_4).reduce(f_1,val_2)):((function __clojure_core_fn_976_reduce_978_fn_981(f_1,val_2,s_3){ var _cnt,_rtn; do{_cnt=0;_rtn=((s_3)?((_cnt=1,_rtn=[f_1,f_1.apply(null,[val_2,clojure.core.first.apply(null,[s_3])]),clojure.core.rest.apply(null,[s_3])],f_1=_rtn[0],val_2=_rtn[1],s_3=_rtn[2])):(val_2)) }while(_cnt);return _rtn;}).apply(null,[f_1,val_2,s_4])))))})))}).apply(null,[]); //====== //(defn reverse "Returns a seq of the items in coll in reverse order. Not lazy." [coll] (reduce conj nil coll)) //--- (function __clojure_core_fn_986(){ return (clojure.JS.def(clojure.core,"reverse",(function __clojure_core_fn_986_reverse_988(coll_1){ return (clojure.core.reduce.apply(null,[clojure.core.conj,null,coll_1]))})))}).apply(null,[]); //====== //(defn + "Returns the sum of nums. (+) returns 0." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/add)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([] 0) ([x] (clojure.lang.RT/numberCast x)) ([x y] (. clojure.lang.Numbers (add x y))) ([x y & more] (reduce + (+ x y) more))) //--- (function __clojure_core_fn_992(){ return (clojure.JS.def(clojure.core,"_PLUS_",clojure.JS.variadic(2,(function __clojure_core_fn_992_PLUS_997(x_1,y_2){switch(arguments.length){ case 0:return ((0)) case 1:return (clojure.lang.RT.numberCast(x_1)) case 2:return (clojure.lang.Numbers.add(x_1,y_2))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.reduce.apply(null,[clojure.core._PLUS_,clojure.lang.Numbers.add(x_1,y_2),more_3]))}))))}).apply(null,[]); //====== //(defn * "Returns the product of nums. (*) returns 1." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/multiply)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([] 1) ([x] (clojure.lang.RT/numberCast x)) ([x y] (. clojure.lang.Numbers (multiply x y))) ([x y & more] (reduce * (* x y) more))) //--- (function __clojure_core_fn_1004(){ return (clojure.JS.def(clojure.core,"_STAR_",clojure.JS.variadic(2,(function __clojure_core_fn_1004_STAR_1009(x_1,y_2){switch(arguments.length){ case 0:return ((1)) case 1:return (clojure.lang.RT.numberCast(x_1)) case 2:return (clojure.lang.Numbers.multiply(x_1,y_2))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.reduce.apply(null,[clojure.core._STAR_,clojure.lang.Numbers.multiply(x_1,y_2),more_3]))}))))}).apply(null,[]); //====== //(defn / "If no denominators are supplied, returns 1/numerator,\n else returns numerator divided by all of the denominators." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/divide)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([x] (/ 1 x)) ([x y] (. clojure.lang.Numbers (divide x y))) ([x y & more] (reduce / (/ x y) more))) //--- (function __clojure_core_fn_1016(){ return (clojure.JS.def(clojure.core,"_SLASH_",clojure.JS.variadic(2,(function __clojure_core_fn_1016_SLASH_1021(x_1,y_2){switch(arguments.length){ case 1:return (clojure.lang.Numbers.divide((1),x_1)) case 2:return (clojure.lang.Numbers.divide(x_1,y_2))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.reduce.apply(null,[clojure.core._SLASH_,clojure.lang.Numbers.divide(x_1,y_2),more_3]))}))))}).apply(null,[]); //====== //(defn - "If no ys are supplied, returns the negation of x, else subtracts\n the ys from x and returns the result." {:inline (fn [& args] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/minus)) args)))), :inline-arities #{1 2}} ([x] (. clojure.lang.Numbers (minus x))) ([x y] (. clojure.lang.Numbers (minus x y))) ([x y & more] (reduce - (- x y) more))) //--- (function __clojure_core_fn_1027(){ return (clojure.JS.def(clojure.core,"_",clojure.JS.variadic(2,(function __clojure_core_fn_1027_1032(x_1,y_2){switch(arguments.length){ case 1:return (clojure.lang.Numbers.minus(x_1)) case 2:return (clojure.lang.Numbers.minus(x_1,y_2))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.reduce.apply(null,[clojure.core._,clojure.lang.Numbers.minus(x_1,y_2),more_3]))}))))}).apply(null,[]); //====== //(defn < "Returns non-nil if nums are in monotonically increasing order,\n otherwise false." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/lt)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([x] true) ([x y] (. clojure.lang.Numbers (lt x y))) ([x y & more] (if (< x y) (if (rest more) (recur y (first more) (rest more)) (< y (first more))) false))) //--- (function __clojure_core_fn_1038(){ return (clojure.JS.def(clojure.core,"_LT_",clojure.JS.variadic(2,(function __clojure_core_fn_1038_LT_1043(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.lang.Numbers.lt(x_1,y_2))} var _cnt,_rtn,more_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((clojure.lang.Numbers.lt(x_1,y_2))?(((clojure.core.rest.apply(null,[more_3]))?((_cnt=1,_rtn=[y_2,clojure.core.first.apply(null,[more_3]),clojure.core.rest.apply(null,[more_3])],x_1=_rtn[0],y_2=_rtn[1],more_3=_rtn[2])):(clojure.lang.Numbers.lt(y_2,clojure.core.first.apply(null,[more_3]))))):(false)) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn <= "Returns non-nil if nums are in monotonically non-decreasing order,\n otherwise false." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/lte)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([x] true) ([x y] (. clojure.lang.Numbers (lte x y))) ([x y & more] (if (<= x y) (if (rest more) (recur y (first more) (rest more)) (<= y (first more))) false))) //--- (function __clojure_core_fn_1049(){ return (clojure.JS.def(clojure.core,"_LT__EQ_",clojure.JS.variadic(2,(function __clojure_core_fn_1049_LT_EQ_1054(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.lang.Numbers.lte(x_1,y_2))} var _cnt,_rtn,more_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((clojure.lang.Numbers.lte(x_1,y_2))?(((clojure.core.rest.apply(null,[more_3]))?((_cnt=1,_rtn=[y_2,clojure.core.first.apply(null,[more_3]),clojure.core.rest.apply(null,[more_3])],x_1=_rtn[0],y_2=_rtn[1],more_3=_rtn[2])):(clojure.lang.Numbers.lte(y_2,clojure.core.first.apply(null,[more_3]))))):(false)) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn > "Returns non-nil if nums are in monotonically decreasing order,\n otherwise false." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/gt)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([x] true) ([x y] (. clojure.lang.Numbers (gt x y))) ([x y & more] (if (> x y) (if (rest more) (recur y (first more) (rest more)) (> y (first more))) false))) //--- (function __clojure_core_fn_1060(){ return (clojure.JS.def(clojure.core,"_GT_",clojure.JS.variadic(2,(function __clojure_core_fn_1060_GT_1065(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.lang.Numbers.gt(x_1,y_2))} var _cnt,_rtn,more_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((clojure.lang.Numbers.gt(x_1,y_2))?(((clojure.core.rest.apply(null,[more_3]))?((_cnt=1,_rtn=[y_2,clojure.core.first.apply(null,[more_3]),clojure.core.rest.apply(null,[more_3])],x_1=_rtn[0],y_2=_rtn[1],more_3=_rtn[2])):(clojure.lang.Numbers.gt(y_2,clojure.core.first.apply(null,[more_3]))))):(false)) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn >= "Returns non-nil if nums are in monotonically non-increasing order,\n otherwise false." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/gte)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([x] true) ([x y] (. clojure.lang.Numbers (gte x y))) ([x y & more] (if (>= x y) (if (rest more) (recur y (first more) (rest more)) (>= y (first more))) false))) //--- (function __clojure_core_fn_1071(){ return (clojure.JS.def(clojure.core,"_GT__EQ_",clojure.JS.variadic(2,(function __clojure_core_fn_1071_GT_EQ_1076(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.lang.Numbers.gte(x_1,y_2))} var _cnt,_rtn,more_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((clojure.lang.Numbers.gte(x_1,y_2))?(((clojure.core.rest.apply(null,[more_3]))?((_cnt=1,_rtn=[y_2,clojure.core.first.apply(null,[more_3]),clojure.core.rest.apply(null,[more_3])],x_1=_rtn[0],y_2=_rtn[1],more_3=_rtn[2])):(clojure.lang.Numbers.gte(y_2,clojure.core.first.apply(null,[more_3]))))):(false)) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn == "Returns non-nil if nums all have the same value, otherwise false" {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/equiv)) (clojure.core/list x) (clojure.core/list y))))), :inline-arities #{2}} ([x] true) ([x y] (. clojure.lang.Numbers (equiv x y))) ([x y & more] (if (== x y) (if (rest more) (recur y (first more) (rest more)) (== y (first more))) false))) //--- (function __clojure_core_fn_1082(){ return (clojure.JS.def(clojure.core,"_EQ__EQ_",clojure.JS.variadic(2,(function __clojure_core_fn_1082_EQ_EQ_1087(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.lang.Numbers.equiv(x_1,y_2))} var _cnt,_rtn,more_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((clojure.lang.Numbers.equiv(x_1,y_2))?(((clojure.core.rest.apply(null,[more_3]))?((_cnt=1,_rtn=[y_2,clojure.core.first.apply(null,[more_3]),clojure.core.rest.apply(null,[more_3])],x_1=_rtn[0],y_2=_rtn[1],more_3=_rtn[2])):(clojure.lang.Numbers.equiv(y_2,clojure.core.first.apply(null,[more_3]))))):(false)) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn max "Returns the greatest of the nums." ([x] x) ([x y] (if (> x y) x y)) ([x y & more] (reduce max (max x y) more))) //--- (function __clojure_core_fn_1093(){ return (clojure.JS.def(clojure.core,"max",clojure.JS.variadic(2,(function __clojure_core_fn_1093_max_1095(x_1,y_2){switch(arguments.length){ case 1:return (x_1) case 2:return (((clojure.lang.Numbers.gt(x_1,y_2))?(x_1):(y_2)))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.reduce.apply(null,[clojure.core.max,clojure.core.max.apply(null,[x_1,y_2]),more_3]))}))))}).apply(null,[]); //====== //(defn min "Returns the least of the nums." ([x] x) ([x y] (if (< x y) x y)) ([x y & more] (reduce min (min x y) more))) //--- (function __clojure_core_fn_1101(){ return (clojure.JS.def(clojure.core,"min",clojure.JS.variadic(2,(function __clojure_core_fn_1101_min_1103(x_1,y_2){switch(arguments.length){ case 1:return (x_1) case 2:return (((clojure.lang.Numbers.lt(x_1,y_2))?(x_1):(y_2)))} var more_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.reduce.apply(null,[clojure.core.min,clojure.core.min.apply(null,[x_1,y_2]),more_3]))}))))}).apply(null,[]); //====== //(defn inc "Returns a number one greater than num." {:inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/inc)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (inc x))) //--- (function __clojure_core_fn_1109(){ return (clojure.JS.def(clojure.core,"inc",(function __clojure_core_fn_1109_inc_1114(x_1){ return (clojure.lang.Numbers.inc(x_1))})))}).apply(null,[]); //====== //(defn dec "Returns a number one less than num." {:inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/dec)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (dec x))) //--- (function __clojure_core_fn_1118(){ return (clojure.JS.def(clojure.core,"dec",(function __clojure_core_fn_1118_dec_1123(x_1){ return (clojure.lang.Numbers.dec(x_1))})))}).apply(null,[]); //====== //(defn unchecked-inc "Returns a number one greater than x, an int or long. \n Note - uses a primitive operator subject to overflow." {:inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_inc)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (unchecked_inc x))) //--- (function __clojure_core_fn_1127(){ return (clojure.JS.def(clojure.core,"unchecked_inc",(function __clojure_core_fn_1127_unchecked_inc_1132(x_1){ return (clojure.lang.Numbers.unchecked_inc(x_1))})))}).apply(null,[]); //====== //(defn unchecked-dec "Returns a number one less than x, an int or long. \n Note - uses a primitive operator subject to overflow." {:inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_dec)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (unchecked_dec x))) //--- (function __clojure_core_fn_1136(){ return (clojure.JS.def(clojure.core,"unchecked_dec",(function __clojure_core_fn_1136_unchecked_dec_1141(x_1){ return (clojure.lang.Numbers.unchecked_dec(x_1))})))}).apply(null,[]); //====== //(defn unchecked-negate "Returns the negation of x, an int or long. \n Note - uses a primitive operator subject to overflow." {:inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_negate)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (unchecked_negate x))) //--- (function __clojure_core_fn_1145(){ return (clojure.JS.def(clojure.core,"unchecked_negate",(function __clojure_core_fn_1145_unchecked_negate_1150(x_1){ return (clojure.lang.Numbers.unchecked_negate(x_1))})))}).apply(null,[]); //====== //(defn unchecked-add "Returns the sum of x and y, both int or long. \n Note - uses a primitive operator subject to overflow." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_add)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers (unchecked_add x y))) //--- (function __clojure_core_fn_1154(){ return (clojure.JS.def(clojure.core,"unchecked_add",(function __clojure_core_fn_1154_unchecked_add_1159(x_1,y_2){ return (clojure.lang.Numbers.unchecked_add(x_1,y_2))})))}).apply(null,[]); //====== //(defn unchecked-subtract "Returns the difference of x and y, both int or long. \n Note - uses a primitive operator subject to overflow." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_subtract)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers (unchecked_subtract x y))) //--- (function __clojure_core_fn_1163(){ return (clojure.JS.def(clojure.core,"unchecked_subtract",(function __clojure_core_fn_1163_unchecked_subtract_1168(x_1,y_2){ return (clojure.lang.Numbers.unchecked_subtract(x_1,y_2))})))}).apply(null,[]); //====== //(defn unchecked-multiply "Returns the product of x and y, both int or long. \n Note - uses a primitive operator subject to overflow." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_multiply)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers (unchecked_multiply x y))) //--- (function __clojure_core_fn_1172(){ return (clojure.JS.def(clojure.core,"unchecked_multiply",(function __clojure_core_fn_1172_unchecked_multiply_1177(x_1,y_2){ return (clojure.lang.Numbers.unchecked_multiply(x_1,y_2))})))}).apply(null,[]); //====== //(defn unchecked-divide "Returns the division of x by y, both int or long. \n Note - uses a primitive operator subject to truncation." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_divide)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers (unchecked_divide x y))) //--- (function __clojure_core_fn_1181(){ return (clojure.JS.def(clojure.core,"unchecked_divide",(function __clojure_core_fn_1181_unchecked_divide_1186(x_1,y_2){ return (clojure.lang.Numbers.unchecked_divide(x_1,y_2))})))}).apply(null,[]); //====== //(defn unchecked-remainder "Returns the remainder of division of x by y, both int or long. \n Note - uses a primitive operator subject to truncation." {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked_remainder)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers (unchecked_remainder x y))) //--- (function __clojure_core_fn_1190(){ return (clojure.JS.def(clojure.core,"unchecked_remainder",(function __clojure_core_fn_1190_unchecked_remainder_1195(x_1,y_2){ return (clojure.lang.Numbers.unchecked_remainder(x_1,y_2))})))}).apply(null,[]); //====== //(defn pos? "Returns true if num is greater than zero, else false" {:tag Boolean, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/isPos)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (isPos x))) //--- (function __clojure_core_fn_1199(){ return (clojure.JS.def(clojure.core,"pos_QMARK_",(function __clojure_core_fn_1199_pos_QMARK_1204(x_1){ return (clojure.lang.Numbers.isPos(x_1))})))}).apply(null,[]); //====== //(defn neg? "Returns true if num is less than zero, else false" {:tag Boolean, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/isNeg)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (isNeg x))) //--- (function __clojure_core_fn_1208(){ return (clojure.JS.def(clojure.core,"neg_QMARK_",(function __clojure_core_fn_1208_neg_QMARK_1213(x_1){ return (clojure.lang.Numbers.isNeg(x_1))})))}).apply(null,[]); //====== //(defn zero? "Returns true if num is zero, else false" {:tag Boolean, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/isZero)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (isZero x))) //--- (function __clojure_core_fn_1217(){ return (clojure.JS.def(clojure.core,"zero_QMARK_",(function __clojure_core_fn_1217_zero_QMARK_1222(x_1){ return (clojure.lang.Numbers.isZero(x_1))})))}).apply(null,[]); //====== //(defn quot "quot[ient] of dividing numerator by denominator." [num div] (. clojure.lang.Numbers (quotient num div))) //--- (function __clojure_core_fn_1226(){ return (clojure.JS.def(clojure.core,"quot",(function __clojure_core_fn_1226_quot_1228(num_1,div_2){ return (clojure.lang.Numbers.quotient(num_1,div_2))})))}).apply(null,[]); //====== //(defn rem "remainder of dividing numerator by denominator." [num div] (. clojure.lang.Numbers (remainder num div))) //--- (function __clojure_core_fn_1232(){ return (clojure.JS.def(clojure.core,"rem",(function __clojure_core_fn_1232_rem_1234(num_1,div_2){ return (clojure.lang.Numbers.remainder(num_1,div_2))})))}).apply(null,[]); //====== //(defn rationalize "returns the rational value of num" [num] (. clojure.lang.Numbers (rationalize num))) //--- (function __clojure_core_fn_1238(){ return (clojure.JS.def(clojure.core,"rationalize",(function __clojure_core_fn_1238_rationalize_1240(num_1){ return (clojure.lang.Numbers.rationalize(num_1))})))}).apply(null,[]); //====== //(defn bit-not "Bitwise complement" {:inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/not)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers not x)) //--- (function __clojure_core_fn_1244(){ return (clojure.JS.def(clojure.core,"bit_not",(function __clojure_core_fn_1244_bit_not_1249(x_1){ return (clojure.lang.Numbers.not(x_1))})))}).apply(null,[]); //====== //(defn bit-and "Bitwise and" {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/and)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers and x y)) //--- (function __clojure_core_fn_1253(){ return (clojure.JS.def(clojure.core,"bit_and",(function __clojure_core_fn_1253_bit_and_1258(x_1,y_2){ return (clojure.lang.Numbers.and(x_1,y_2))})))}).apply(null,[]); //====== //(defn bit-or "Bitwise or" {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/or)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers or x y)) //--- (function __clojure_core_fn_1262(){ return (clojure.JS.def(clojure.core,"bit_or",(function __clojure_core_fn_1262_bit_or_1267(x_1,y_2){ return (clojure.lang.Numbers.or(x_1,y_2))})))}).apply(null,[]); //====== //(defn bit-xor "Bitwise exclusive or" {:inline (fn [x y] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/xor)) (clojure.core/list x) (clojure.core/list y)))))} [x y] (. clojure.lang.Numbers xor x y)) //--- (function __clojure_core_fn_1271(){ return (clojure.JS.def(clojure.core,"bit_xor",(function __clojure_core_fn_1271_bit_xor_1276(x_1,y_2){ return (clojure.lang.Numbers.xor(x_1,y_2))})))}).apply(null,[]); //====== //(defn bit-and-not "Bitwise and with complement" [x y] (. clojure.lang.Numbers andNot x y)) //--- (function __clojure_core_fn_1280(){ return (clojure.JS.def(clojure.core,"bit_and_not",(function __clojure_core_fn_1280_bit_and_not_1282(x_1,y_2){ return (clojure.lang.Numbers.andNot(x_1,y_2))})))}).apply(null,[]); //====== //(defn bit-clear "Clear bit at index n" [x n] (. clojure.lang.Numbers clearBit x n)) //--- (function __clojure_core_fn_1286(){ return (clojure.JS.def(clojure.core,"bit_clear",(function __clojure_core_fn_1286_bit_clear_1288(x_1,n_2){ return (clojure.lang.Numbers.clearBit(x_1,n_2))})))}).apply(null,[]); //====== //(defn bit-set "Set bit at index n" [x n] (. clojure.lang.Numbers setBit x n)) //--- (function __clojure_core_fn_1292(){ return (clojure.JS.def(clojure.core,"bit_set",(function __clojure_core_fn_1292_bit_set_1294(x_1,n_2){ return (clojure.lang.Numbers.setBit(x_1,n_2))})))}).apply(null,[]); //====== //(defn bit-flip "Flip bit at index n" [x n] (. clojure.lang.Numbers flipBit x n)) //--- (function __clojure_core_fn_1298(){ return (clojure.JS.def(clojure.core,"bit_flip",(function __clojure_core_fn_1298_bit_flip_1300(x_1,n_2){ return (clojure.lang.Numbers.flipBit(x_1,n_2))})))}).apply(null,[]); //====== //(defn bit-test "Test bit at index n" [x n] (. clojure.lang.Numbers testBit x n)) //--- (function __clojure_core_fn_1304(){ return (clojure.JS.def(clojure.core,"bit_test",(function __clojure_core_fn_1304_bit_test_1306(x_1,n_2){ return (clojure.lang.Numbers.testBit(x_1,n_2))})))}).apply(null,[]); //====== //(defn bit-shift-left "Bitwise shift left" [x n] (. clojure.lang.Numbers shiftLeft x n)) //--- (function __clojure_core_fn_1310(){ return (clojure.JS.def(clojure.core,"bit_shift_left",(function __clojure_core_fn_1310_bit_shift_left_1312(x_1,n_2){ return (clojure.lang.Numbers.shiftLeft(x_1,n_2))})))}).apply(null,[]); //====== //(defn bit-shift-right "Bitwise shift right" [x n] (. clojure.lang.Numbers shiftRight x n)) //--- (function __clojure_core_fn_1316(){ return (clojure.JS.def(clojure.core,"bit_shift_right",(function __clojure_core_fn_1316_bit_shift_right_1318(x_1,n_2){ return (clojure.lang.Numbers.shiftRight(x_1,n_2))})))}).apply(null,[]); //====== //(defn even? "Returns true if n is even, throws an exception if n is not an integer" [n] (zero? (bit-and n 1))) //--- (function __clojure_core_fn_1322(){ return (clojure.JS.def(clojure.core,"even_QMARK_",(function __clojure_core_fn_1322_even_QMARK_1324(n_1){ return (clojure.lang.Numbers.isZero(clojure.lang.Numbers.and(n_1,(1))))})))}).apply(null,[]); //====== //(defn odd? "Returns true if n is odd, throws an exception if n is not an integer" [n] (not (even? n))) //--- (function __clojure_core_fn_1328(){ return (clojure.JS.def(clojure.core,"odd_QMARK_",(function __clojure_core_fn_1328_odd_QMARK_1330(n_1){ return (clojure.core.not.apply(null,[clojure.core.even_QMARK_.apply(null,[n_1])]))})))}).apply(null,[]); //====== //(defn complement "Takes a fn f and returns a fn that takes the same arguments as f,\n has the same effects, if any, and returns the opposite truth value." [f] (fn [& args] (not (apply f args)))) //--- (function __clojure_core_fn_1334(){ return (clojure.JS.def(clojure.core,"complement",(function __clojure_core_fn_1334_complement_1336(f_1){ return (clojure.JS.variadic(0,(function __clojure_core_fn_1334_complement_1336_fn_1338(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.not.apply(null,[clojure.core.apply.apply(null,[f_1,args_1])]))})))})))}).apply(null,[]); //====== //(defn constantly "Returns a function that takes any number of arguments and returns x." [x] (fn [& args] x)) //--- (function __clojure_core_fn_1343(){ return (clojure.JS.def(clojure.core,"constantly",(function __clojure_core_fn_1343_constantly_1345(x_1){ return (clojure.JS.variadic(0,(function __clojure_core_fn_1343_constantly_1345_fn_1347(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (x_1)})))})))}).apply(null,[]); //====== //(defn identity "Returns its argument." [x] x) //--- (function __clojure_core_fn_1352(){ return (clojure.JS.def(clojure.core,"identity",(function __clojure_core_fn_1352_identity_1354(x_1){ return (x_1)})))}).apply(null,[]); // Skipping: (defn count "Returns the number of items in the collection. (count nil) returns\n 0. Also works on strings, arrays, and Java Collections and Maps" [coll] (. clojure.lang.RT (count coll))) //====== //(defn peek "For a list or queue, same as first, for a vector, same as, but much\n more efficient than, last. If the collection is empty, returns nil." [coll] (. clojure.lang.RT (peek coll))) //--- (function __clojure_core_fn_1364(){ return (clojure.JS.def(clojure.core,"peek",(function __clojure_core_fn_1364_peek_1366(coll_1){ return (clojure.lang.RT.peek(coll_1))})))}).apply(null,[]); //====== //(defn pop "For a list or queue, returns a new list/queue without the first\n item, for a vector, returns a new vector without the last item. If\n the collection is empty, throws an exception. Note - not the same\n as rest/butlast." [coll] (. clojure.lang.RT (pop coll))) //--- (function __clojure_core_fn_1370(){ return (clojure.JS.def(clojure.core,"pop",(function __clojure_core_fn_1370_pop_1372(coll_1){ return (clojure.lang.RT.pop(coll_1))})))}).apply(null,[]); // Skipping: (defn nth "Returns the value at the index. get returns nil if index out of\n bounds, nth throws an exception unless not-found is supplied. nth\n also works for strings, Java arrays, regex Matchers and Lists, and,\n in O(n) time, for sequences." ([coll index] (. clojure.lang.RT (nth coll index))) ([coll index not-found] (. clojure.lang.RT (nth coll index not-found)))) // Skipping: (defn contains? "Returns true if key is present in the given collection, otherwise\n returns false. Note that for numerically indexed collections like\n vectors and Java arrays, this tests if the numeric key is within the\n range of indexes. 'contains?' operates constant or logarithmic time;\n it will not perform a linear search for a value. See also 'some'." [coll key] (. clojure.lang.RT (contains coll key))) // Skipping: (defn get "Returns the value mapped to key, not-found or nil if key not present." ([map key] (. clojure.lang.RT (get map key))) ([map key not-found] (. clojure.lang.RT (get map key not-found)))) //====== //(defn dissoc "dissoc[iate]. Returns a new map of the same (hashed/sorted) type,\n that does not contain a mapping for key(s)." ([map] map) ([map key] (. clojure.lang.RT (dissoc map key))) ([map key & ks] (let [ret (dissoc map key)] (if ks (recur ret (first ks) (rest ks)) ret)))) //--- (function __clojure_core_fn_1396(){ return (clojure.JS.def(clojure.core,"dissoc",clojure.JS.variadic(2,(function __clojure_core_fn_1396_dissoc_1398(map_1,key_2){switch(arguments.length){ case 1:return (map_1) case 2:return (clojure.lang.RT.dissoc(map_1,key_2))} var _cnt,_rtn,ret_4,ks_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((ret_4=clojure.core.dissoc.apply(null,[map_1,key_2])), ((ks_3)?((_cnt=1,_rtn=[ret_4,clojure.core.first.apply(null,[ks_3]),clojure.core.rest.apply(null,[ks_3])],map_1=_rtn[0],key_2=_rtn[1],ks_3=_rtn[2])):(ret_4))) }while(_cnt);return _rtn;}))))}).apply(null,[]); //====== //(defn disj "disj[oin]. Returns a new set of the same (hashed/sorted) type, that\n does not contain key(s)." ([set] set) ([set key] (. set (disjoin key))) ([set key & ks] (let [ret (disj set key)] (if ks (recur ret (first ks) (rest ks)) ret)))) //--- (function __clojure_core_fn_1404(){ return (clojure.JS.def(clojure.core,"disj",clojure.JS.variadic(2,(function __clojure_core_fn_1404_disj_1406(set_1,key_2){switch(arguments.length){ case 1:return (set_1) case 2:return ((set_1).disjoin(key_2))} var _cnt,_rtn,ret_4,ks_3=clojure.JS.rest_args(this,arguments,2); do{_cnt=0;_rtn=((ret_4=clojure.core.disj.apply(null,[set_1,key_2])), ((ks_3)?((_cnt=1,_rtn=[ret_4,clojure.core.first.apply(null,[ks_3]),clojure.core.rest.apply(null,[ks_3])],set_1=_rtn[0],key_2=_rtn[1],ks_3=_rtn[2])):(ret_4))) }while(_cnt);return _rtn;}))))}).apply(null,[]); // Skipping: (defn find "Returns the map entry for key, or nil if key not present." [map key] (. clojure.lang.RT (find map key))) //====== //(defn select-keys "Returns a map containing only those entries in map whose key is in keys" [map keyseq] (loop [ret {} keys (seq keyseq)] (if keys (let [entry (. clojure.lang.RT (find map (first keys)))] (recur (if entry (conj ret entry) ret) (rest keys))) ret))) //--- (function __clojure_core_fn_1418(){ return (clojure.JS.def(clojure.core,"select_keys",(function __clojure_core_fn_1418_select_keys_1420(map_1,keyseq_2){ var ret_3,keys_4,entry_5; return (((function __loop(){var _rtn,_cnt;(ret_3=clojure.lang.PersistentArrayMap.EMPTY), (keys_4=clojure.core.seq.apply(null,[keyseq_2]));do{_cnt=0; _rtn=((keys_4)?(((entry_5=clojure.lang.RT.find(map_1,clojure.core.first.apply(null,[keys_4]))), (_cnt=1,_rtn=[((entry_5)?(clojure.core.conj.apply(null,[ret_3,entry_5])):(ret_3)),clojure.core.rest.apply(null,[keys_4])],ret_3=_rtn[0],keys_4=_rtn[1]))):(ret_3))}while(_cnt);return _rtn;})()))})))}).apply(null,[]); // Skipping: (defn keys "Returns a sequence of the map's keys." [map] (. clojure.lang.RT (keys map))) // Skipping: (defn vals "Returns a sequence of the map's values." [map] (. clojure.lang.RT (vals map))) //====== //(defn key "Returns the key of the map entry." [e] (. e (getKey))) //--- (function __clojure_core_fn_1436(){ return (clojure.JS.def(clojure.core,"key",(function __clojure_core_fn_1436_key_1438(e_1){ return ((e_1).getKey())})))}).apply(null,[]); //====== //(defn val "Returns the value in the map entry." [e] (. e (getValue))) //--- (function __clojure_core_fn_1442(){ return (clojure.JS.def(clojure.core,"val",(function __clojure_core_fn_1442_val_1444(e_1){ return ((e_1).getValue())})))}).apply(null,[]); //====== //(defn rseq "Returns, in constant time, a sequence of the items in rev (which\n can be a vector or sorted-map), in reverse order." [rev] (. rev (rseq))) //--- (function __clojure_core_fn_1448(){ return (clojure.JS.def(clojure.core,"rseq",(function __clojure_core_fn_1448_rseq_1450(rev_1){ return ((rev_1).rseq())})))}).apply(null,[]); //====== //(defn name "Returns the name String of a symbol or keyword." [x] (. x (getName))) //--- (function __clojure_core_fn_1454(){ return (clojure.JS.def(clojure.core,"name",(function __clojure_core_fn_1454_name_1456(x_1){ return ((x_1).getName())})))}).apply(null,[]); //====== //(defn namespace "Returns the namespace String of a symbol or keyword, or nil if not present." [x] (. x (getNamespace))) //--- (function __clojure_core_fn_1460(){ return (clojure.JS.def(clojure.core,"namespace",(function __clojure_core_fn_1460_namespace_1462(x_1){ return ((x_1).getNamespace())})))}).apply(null,[]); // Skipping: (defmacro locking "Executes exprs in an implicit do, while holding the monitor of x.\n Will release the monitor of x in all circumstances." [x & body] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote lockee__1466__auto__)) (clojure.core/list x)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote try)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote monitor-enter)) (clojure.core/list (quote lockee__1466__auto__)))) body (clojure.core/list (clojure.core/concat (clojure.core/list (quote finally)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote monitor-exit)) (clojure.core/list (quote lockee__1466__auto__)))))))))) // Skipping: (defmacro .. "form => fieldName-symbol or (instanceMethodName-symbol args*)\n\n Expands into a member access (.) of the first member on the first\n argument, followed by the next member on the result, etc. For\n instance:\n\n (.. System (getProperties) (get \"os.name\"))\n\n expands to:\n\n (. (. System (getProperties)) (get \"os.name\"))\n\n but is easier to write, read, and understand." ([x form] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list x) (clojure.core/list form))) ([x form & more] (clojure.core/concat (clojure.core/list (quote ..)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list x) (clojure.core/list form))) more))) // Skipping: (defmacro -> "Threads the expr through the forms. Inserts x as the\n second item in the first form, making a list of it if it is not a\n list already. If there are more forms, inserts the first form as the\n second item in second form, etc." ([x form] (if (seq? form) (clojure.core/concat (clojure.core/list (first form)) (clojure.core/list x) (rest form)) (list form x))) ([x form & more] (clojure.core/concat (clojure.core/list (quote clojure.core/->)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/->)) (clojure.core/list x) (clojure.core/list form))) more))) // Skipping: (defmacro defmulti "Creates a new multimethod with the associated dispatch function. If\n default-dispatch-val is supplied it becomes the default dispatch\n value of the multimethod, otherwise the default dispatch value\n is :default." ([name dispatch-fn] (clojure.core/concat (clojure.core/list (quote clojure.core/defmulti)) (clojure.core/list name) (clojure.core/list dispatch-fn) (clojure.core/list :default))) ([name dispatch-fn default-val] (clojure.core/concat (clojure.core/list (quote def)) (clojure.core/list (with-meta name (assoc (clojure.core/meta name) :tag (quote clojure.lang.MultiFn)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote new)) (clojure.core/list (quote clojure.lang.MultiFn)) (clojure.core/list dispatch-fn) (clojure.core/list default-val)))))) // Skipping: (defmacro defmethod "Creates and installs a new method of multimethod associated with dispatch-value. " [multifn dispatch-val & fn-tail] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list multifn) (clojure.core/list (quote clojure.core/addMethod)) (clojure.core/list dispatch-val) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/fn)) fn-tail)))) //====== //(defn remove-method "Removes the method of multimethod associated\twith dispatch-value." [multifn dispatch-val] (. multifn removeMethod dispatch-val)) //--- (function __clojure_core_fn_1518(){ return (clojure.JS.def(clojure.core,"remove_method",(function __clojure_core_fn_1518_remove_method_1520(multifn_1,dispatch_val_2){ return ((multifn_1).removeMethod(dispatch_val_2))})))}).apply(null,[]); //====== //(defn prefer-method "Causes the multimethod to prefer matches of dispatch-val-x over dispatch-val-y when there is a conflict" [multifn dispatch-val-x dispatch-val-y] (. multifn preferMethod dispatch-val-x dispatch-val-y)) //--- (function __clojure_core_fn_1524(){ return (clojure.JS.def(clojure.core,"prefer_method",(function __clojure_core_fn_1524_prefer_method_1526(multifn_1,dispatch_val_x_2,dispatch_val_y_3){ return ((multifn_1).preferMethod(dispatch_val_x_2,dispatch_val_y_3))})))}).apply(null,[]); //====== //(defn methods "Given a multimethod, returns a map of dispatch values -> dispatch fns" [multifn] (.getMethodTable multifn)) //--- (function __clojure_core_fn_1530(){ return (clojure.JS.def(clojure.core,"methods",(function __clojure_core_fn_1530_methods_1532(multifn_1){ return (clojure.JS.getOrRun(multifn_1,"getMethodTable"))})))}).apply(null,[]); //====== //(defn prefers "Given a multimethod, returns a map of preferred value -> set of other values" [multifn] (.getPreferTable multifn)) //--- (function __clojure_core_fn_1536(){ return (clojure.JS.def(clojure.core,"prefers",(function __clojure_core_fn_1536_prefers_1538(multifn_1){ return (clojure.JS.getOrRun(multifn_1,"getPreferTable"))})))}).apply(null,[]); // Skipping: (defmacro assert-args [fnname & pairs] (clojure.core/concat (clojure.core/list (quote do)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when-not)) (clojure.core/list (first pairs)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote throw)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote java.lang.IllegalArgumentException.)) (clojure.core/list (str fnname " requires " (second pairs))))))))) (clojure.core/list (let [more (rrest pairs)] (when more (list* (quote clojure.core/assert-args) fnname more)))))) // Skipping: (defmacro binding "binding => var-symbol init-expr \n\n Creates new bindings for the (already-existing) vars, with the\n supplied initial values, executes the exprs in an implicit do, then\n re-establishes the bindings that existed before." [bindings & body] (assert-args binding (vector? bindings) "a vector for its binding" (even? (count bindings)) "an even number of forms in binding vector") (let [var-ize (fn [var-vals] (loop [ret [] vvs (seq var-vals)] (if vvs (recur (conj (conj ret (clojure.core/concat (clojure.core/list (quote var)) (clojure.core/list (first vvs)))) (second vvs)) (rest (rest vvs))) (seq ret))))] (clojure.core/concat (clojure.core/list (quote do)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Var)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/pushThreadBindings)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/hash-map)) (var-ize bindings))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote try)) body (clojure.core/list (clojure.core/concat (clojure.core/list (quote finally)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Var)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/popThreadBindings))))))))))))) //====== //(defn find-var "Returns the global var named by the namespace-qualified symbol, or\n nil if no var with that name." [sym] (. clojure.lang.Var (find sym))) //--- (function __clojure_core_fn_1566(){ return (clojure.JS.def(clojure.core,"find_var",(function __clojure_core_fn_1566_find_var_1568(sym_1){ return (clojure.lang.Var.find(sym_1))})))}).apply(null,[]); //====== //(defn setup-reference [r options] (let [opts (apply hash-map options)] (when (:meta opts) (.resetMeta r (:meta opts))) (when (:validator opts) (.setValidator r (:validator opts))) r)) //--- (function __clojure_core_fn_1572(){ return (clojure.JS.def(clojure.core,"setup_reference",(function __clojure_core_fn_1572_setup_reference_1574(r_1,options_2){ var opts_3; return (((opts_3=clojure.core.apply.apply(null,[clojure.core.hash_map,options_2])), ((clojure.core.keyword("","meta").apply(null,[opts_3]))?((r_1).resetMeta(clojure.core.keyword("","meta").apply(null,[opts_3]))):(null)), ((clojure.core.keyword("","validator").apply(null,[opts_3]))?((r_1).setValidator(clojure.core.keyword("","validator").apply(null,[opts_3]))):(null)), r_1))})))}).apply(null,[]); //====== //(defn agent "Creates and returns an agent with an initial value of state and\n zero or more options (in any order):\n \n :meta metadata-map\n \n :validator validate-fn\n\n If metadata-map is supplied, it will be come the metadata on the\n agent. validate-fn must be nil or a side-effect-free fn of one\n argument, which will be passed the intended new state on any state\n change. If the new state is unacceptable, the validate-fn should\n return false or throw an exception." ([state] (new clojure.lang.Agent state)) ([state & options] (setup-reference (agent state) options))) //--- (function __clojure_core_fn_1578(){ return (clojure.JS.def(clojure.core,"agent",clojure.JS.variadic(1,(function __clojure_core_fn_1578_agent_1580(state_1){switch(arguments.length){ case 1:return ((new clojure.lang.Agent(state_1)))} var options_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.setup_reference.apply(null,[clojure.core.agent.apply(null,[state_1]),options_2]))}))))}).apply(null,[]); //====== //(defn send "Dispatch an action to an agent. Returns the agent immediately.\n Subsequently, in a thread from a thread pool, the state of the agent\n will be set to the value of:\n\n (apply action-fn state-of-agent args)" [a f & args] (. a (dispatch f args false))) //--- (function __clojure_core_fn_1585(){ return (clojure.JS.def(clojure.core,"send",clojure.JS.variadic(2,(function __clojure_core_fn_1585_send_1587(a_1,f_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return ((a_1).dispatch(f_2,args_3,false))}))))}).apply(null,[]); //====== //(defn send-off "Dispatch a potentially blocking action to an agent. Returns the\n agent immediately. Subsequently, in a separate thread, the state of\n the agent will be set to the value of:\n\n (apply action-fn state-of-agent args)" [a f & args] (. a (dispatch f args true))) //--- (function __clojure_core_fn_1591(){ return (clojure.JS.def(clojure.core,"send_off",clojure.JS.variadic(2,(function __clojure_core_fn_1591_send_off_1593(a_1,f_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return ((a_1).dispatch(f_2,args_3,true))}))))}).apply(null,[]); //====== //(defn release-pending-sends "Normally, actions sent directly or indirectly during another action\n are held until the action completes (changes the agent's\n state). This function can be used to dispatch any pending sent\n actions immediately. This has no impact on actions sent during a\n transaction, which are still held until commit. If no action is\n occurring, does nothing. Returns the number of actions dispatched." [] (clojure.lang.Agent/releasePendingSends)) //--- (function __clojure_core_fn_1597(){ return (clojure.JS.def(clojure.core,"release_pending_sends",(function __clojure_core_fn_1597_release_pending_sends_1599(){ return (clojure.lang.Agent.releasePendingSends())})))}).apply(null,[]); //====== //(defn add-watcher "Experimental.\n Adds a watcher to an agent/atom/var/ref reference. The watcher must\n be an Agent, and the action a function of the agent's state and one\n additional arg, the reference. Whenever the reference's state\n changes, any registered watchers will have their actions\n sent. send-type must be one of :send or :send-off. The actions will\n be sent after the reference's state is changed. Var watchers are\n triggered only by root binding changes, not thread-local set!s" [reference send-type watcher-agent action-fn] (.addWatch reference watcher-agent action-fn (= send-type :send-off))) //--- (function __clojure_core_fn_1603(){ return (clojure.JS.def(clojure.core,"add_watcher",(function __clojure_core_fn_1603_add_watcher_1605(reference_1,send_type_2,watcher_agent_3,action_fn_4){ return ((reference_1).addWatch(watcher_agent_3,action_fn_4,clojure.lang.Util.equiv(send_type_2,clojure.core.keyword("","send-off"))))})))}).apply(null,[]); //====== //(defn remove-watcher "Experimental.\n Removes a watcher (set by add-watcher) from a reference" [reference watcher-agent] (.removeWatch reference watcher-agent)) //--- (function __clojure_core_fn_1609(){ return (clojure.JS.def(clojure.core,"remove_watcher",(function __clojure_core_fn_1609_remove_watcher_1611(reference_1,watcher_agent_2){ return ((reference_1).removeWatch(watcher_agent_2))})))}).apply(null,[]); //====== //(defn agent-errors "Returns a sequence of the exceptions thrown during asynchronous\n actions of the agent." [a] (. a (getErrors))) //--- (function __clojure_core_fn_1615(){ return (clojure.JS.def(clojure.core,"agent_errors",(function __clojure_core_fn_1615_agent_errors_1617(a_1){ return ((a_1).getErrors())})))}).apply(null,[]); //====== //(defn clear-agent-errors "Clears any exceptions thrown during asynchronous actions of the\n agent, allowing subsequent actions to occur." [a] (. a (clearErrors))) //--- (function __clojure_core_fn_1621(){ return (clojure.JS.def(clojure.core,"clear_agent_errors",(function __clojure_core_fn_1621_clear_agent_errors_1623(a_1){ return ((a_1).clearErrors())})))}).apply(null,[]); //====== //(defn shutdown-agents "Initiates a shutdown of the thread pools that back the agent\n system. Running actions will complete, but no new actions will be\n accepted" [] (. clojure.lang.Agent shutdown)) //--- (function __clojure_core_fn_1627(){ return (clojure.JS.def(clojure.core,"shutdown_agents",(function __clojure_core_fn_1627_shutdown_agents_1629(){ return (clojure.lang.Agent.shutdown())})))}).apply(null,[]); //====== //(defn ref "Creates and returns a Ref with an initial value of x and zero or\n more options (in any order):\n \n :meta metadata-map\n \n :validator validate-fn\n\n If metadata-map is supplied, it will be come the metadata on the\n ref. validate-fn must be nil or a side-effect-free fn of one\n argument, which will be passed the intended new state on any state\n change. If the new state is unacceptable, the validate-fn should\n return false or throw an exception. validate-fn will be called on\n transaction commit, when all refs have their final values." ([x] (new clojure.lang.Ref x)) ([x & options] (setup-reference (ref x) options))) //--- (function __clojure_core_fn_1633(){ return (clojure.JS.def(clojure.core,"ref",clojure.JS.variadic(1,(function __clojure_core_fn_1633_ref_1635(x_1){switch(arguments.length){ case 1:return ((new clojure.lang.Ref(x_1)))} var options_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.setup_reference.apply(null,[clojure.core.ref.apply(null,[x_1]),options_2]))}))))}).apply(null,[]); //====== //(defn deref "Also reader macro: @ref/@agent/@var/@atom Within a transaction,\n returns the in-transaction-value of ref, else returns the\n most-recently-committed value of ref. When applied to a var, agent\n or atom, returns its current state." [ref] (. ref (get))) //--- (function __clojure_core_fn_1640(){ return (clojure.JS.def(clojure.core,"deref",(function __clojure_core_fn_1640_deref_1642(ref_1){ return ((ref_1).get())})))}).apply(null,[]); //====== //(defn atom "Creates and returns an Atom with an initial value of x and zero or\n more options (in any order):\n \n :meta metadata-map\n \n :validator validate-fn\n\n If metadata-map is supplied, it will be come the metadata on the\n atom. validate-fn must be nil or a side-effect-free fn of one\n argument, which will be passed the intended new state on any state\n change. If the new state is unacceptable, the validate-fn should\n return false or throw an exception." ([x] (new clojure.lang.Atom x)) ([x & options] (setup-reference (atom x) options))) //--- (function __clojure_core_fn_1646(){ return (clojure.JS.def(clojure.core,"atom",clojure.JS.variadic(1,(function __clojure_core_fn_1646_atom_1648(x_1){switch(arguments.length){ case 1:return ((new clojure.lang.Atom(x_1)))} var options_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.setup_reference.apply(null,[clojure.core.atom.apply(null,[x_1]),options_2]))}))))}).apply(null,[]); //====== //(defn swap! "Atomically swaps the value of atom to be:\n (apply f current-value-of-atom args). Note that f may be called\n multiple times, and thus should be free of side effects. Returns\n the value that was swapped in." ([atom f] (.swap atom f)) ([atom f x] (.swap atom f x)) ([atom f x y] (.swap atom f x y)) ([atom f x y & args] (.swap atom f x y args))) //--- (function __clojure_core_fn_1653(){ return (clojure.JS.def(clojure.core,"swap_BANG_",clojure.JS.variadic(4,(function __clojure_core_fn_1653_swap_BANG_1655(atom_1,f_2,x_3,y_4){switch(arguments.length){ case 2:return ((atom_1).swap(f_2)) case 3:return ((atom_1).swap(f_2,x_3)) case 4:return ((atom_1).swap(f_2,x_3,y_4))} var args_5=clojure.JS.rest_args(this,arguments,4); return ((atom_1).swap(f_2,x_3,y_4,args_5))}))))}).apply(null,[]); //====== //(defn compare-and-set! "Atomically sets the value of atom to newval if and only if the\n current value of the atom is identical to oldval. Returns true if\n set happened, else false" [atom oldval newval] (.compareAndSet atom oldval newval)) //--- (function __clojure_core_fn_1662(){ return (clojure.JS.def(clojure.core,"compare_and_set_BANG_",(function __clojure_core_fn_1662_compare_and_set_BANG_1664(atom_1,oldval_2,newval_3){ return ((atom_1).compareAndSet(oldval_2,newval_3))})))}).apply(null,[]); //====== //(defn reset! "Sets the value of atom to newval without regard for the\n current value. Returns newval." [atom newval] (.reset atom newval)) //--- (function __clojure_core_fn_1668(){ return (clojure.JS.def(clojure.core,"reset_BANG_",(function __clojure_core_fn_1668_reset_BANG_1670(atom_1,newval_2){ return ((atom_1).reset(newval_2))})))}).apply(null,[]); //====== //(defn set-validator! "Sets the validator-fn for a var/ref/agent/atom. validator-fn must be nil or a\n side-effect-free fn of one argument, which will be passed the intended\n new state on any state change. If the new state is unacceptable, the\n validator-fn should return false or throw an exception. If the current state (root\n value if var) is not acceptable to the new validator, an exception\n will be thrown and the validator will not be changed." [iref validator-fn] (. iref (setValidator validator-fn))) //--- (function __clojure_core_fn_1674(){ return (clojure.JS.def(clojure.core,"set_validator_BANG_",(function __clojure_core_fn_1674_set_validator_BANG_1676(iref_1,validator_fn_2){ return ((iref_1).setValidator(validator_fn_2))})))}).apply(null,[]); //====== //(defn get-validator "Gets the validator-fn for a var/ref/agent/atom." [iref] (. iref (getValidator))) //--- (function __clojure_core_fn_1680(){ return (clojure.JS.def(clojure.core,"get_validator",(function __clojure_core_fn_1680_get_validator_1682(iref_1){ return ((iref_1).getValidator())})))}).apply(null,[]); //====== //(defn alter-meta! "Atomically sets the metadata for a namespace/var/ref/agent/atom to be: \n \n (apply f its-current-meta args) \n \n f must be free of side-effects" [iref f & args] (.alterMeta iref f args)) //--- (function __clojure_core_fn_1686(){ return (clojure.JS.def(clojure.core,"alter_meta_BANG_",clojure.JS.variadic(2,(function __clojure_core_fn_1686_alter_meta_BANG_1688(iref_1,f_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return ((iref_1).alterMeta(f_2,args_3))}))))}).apply(null,[]); //====== //(defn reset-meta! "Atomically resets the metadata for a namespace/var/ref/agent/atom" [iref metadata-map] (.resetMeta iref metadata-map)) //--- (function __clojure_core_fn_1692(){ return (clojure.JS.def(clojure.core,"reset_meta_BANG_",(function __clojure_core_fn_1692_reset_meta_BANG_1694(iref_1,metadata_map_2){ return ((iref_1).resetMeta(metadata_map_2))})))}).apply(null,[]); //====== //(defn commute "Must be called in a transaction. Sets the in-transaction-value of\n ref to:\n\n (apply fun in-transaction-value-of-ref args)\n\n and returns the in-transaction-value of ref.\n\n At the commit point of the transaction, sets the value of ref to be:\n\n (apply fun most-recently-committed-value-of-ref args)\n\n Thus fun should be commutative, or, failing that, you must accept\n last-one-in-wins behavior. commute allows for more concurrency than\n ref-set." [ref fun & args] (. ref (commute fun args))) //--- (function __clojure_core_fn_1698(){ return (clojure.JS.def(clojure.core,"commute",clojure.JS.variadic(2,(function __clojure_core_fn_1698_commute_1700(ref_1,fun_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return ((ref_1).commute(fun_2,args_3))}))))}).apply(null,[]); //====== //(defn alter "Must be called in a transaction. Sets the in-transaction-value of\n ref to:\n\n (apply fun in-transaction-value-of-ref args)\n\n and returns the in-transaction-value of ref." [ref fun & args] (. ref (alter fun args))) //--- (function __clojure_core_fn_1704(){ return (clojure.JS.def(clojure.core,"alter",clojure.JS.variadic(2,(function __clojure_core_fn_1704_alter_1706(ref_1,fun_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return ((ref_1).alter(fun_2,args_3))}))))}).apply(null,[]); //====== //(defn ref-set "Must be called in a transaction. Sets the value of ref.\n Returns val." [ref val] (. ref (set val))) //--- (function __clojure_core_fn_1710(){ return (clojure.JS.def(clojure.core,"ref_set",(function __clojure_core_fn_1710_ref_set_1712(ref_1,val_2){ return ((ref_1).set(val_2))})))}).apply(null,[]); //====== //(defn ensure "Must be called in a transaction. Protects the ref from modification\n by other transactions. Returns the in-transaction-value of\n ref. Allows for more concurrency than (ref-set ref @ref)" [ref] (. ref (touch)) (. ref (get))) //--- (function __clojure_core_fn_1716(){ return (clojure.JS.def(clojure.core,"ensure",(function __clojure_core_fn_1716_ensure_1718(ref_1){ return ((ref_1).touch(), (ref_1).get())})))}).apply(null,[]); // Skipping: (defmacro sync "transaction-flags => TBD, pass nil for now\n\n Runs the exprs (in an implicit do) in a transaction that encompasses\n exprs and any nested calls. Starts a transaction if none is already\n running on this thread. Any uncaught exception will abort the\n transaction and flow out of sync. The exprs may be run more than\n once, but any effects on Refs will be atomic." [flags-ignored-for-now & body] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.LockingTransaction)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/runInTransaction)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/fn)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat))) body)))))) // Skipping: (defmacro io! "If an io! block occurs in a transaction, throws an\n IllegalStateException, else runs body in an implicit do. If the\n first expression in body is a literal string, will use that as the\n exception message." [& body] (let [message (when (string? (first body)) (first body)) body (if message (rest body) body)] (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.lang.LockingTransaction/isRunning)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote throw)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote new)) (clojure.core/list (quote java.lang.IllegalStateException)) (clojure.core/list (or message "I/O in transaction")))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote do)) body))))) //====== //(defn comp "Takes a set of functions and returns a fn that is the composition\n of those fns. The returned fn takes a variable number of args,\n applies the rightmost of fns to the args, the next\n fn (right-to-left) to the result, etc." [& fs] (let [fs (reverse fs)] (fn [& args] (loop [ret (apply (first fs) args) fs (rest fs)] (if fs (recur ((first fs) ret) (rest fs)) ret))))) //--- (function __clojure_core_fn_1741(){ return (clojure.JS.def(clojure.core,"comp",clojure.JS.variadic(0,(function __clojure_core_fn_1741_comp_1743(){ var fs_2,fs_1=clojure.JS.rest_args(this,arguments,0); return (((fs_2=clojure.core.reverse.apply(null,[fs_1])), clojure.JS.variadic(0,(function __clojure_core_fn_1741_comp_1743_fn_1745(){ var ret_2,fs_3,args_1=clojure.JS.rest_args(this,arguments,0); return (((function __loop(){var _rtn,_cnt;(ret_2=clojure.core.apply.apply(null,[clojure.core.first.apply(null,[fs_2]),args_1])), (fs_3=clojure.core.rest.apply(null,[fs_2]));do{_cnt=0; _rtn=((fs_3)?((_cnt=1,_rtn=[clojure.core.first.apply(null,[fs_3]).apply(null,[ret_2]),clojure.core.rest.apply(null,[fs_3])],ret_2=_rtn[0],fs_3=_rtn[1])):(ret_2))}while(_cnt);return _rtn;})()))}))))}))))}).apply(null,[]); //====== //(defn partial "Takes a function f and fewer than the normal arguments to f, and\n returns a fn that takes a variable number of additional args. When\n called, the returned function calls f with args + additional args." ([f arg1] (fn [& args] (apply f arg1 args))) ([f arg1 arg2] (fn [& args] (apply f arg1 arg2 args))) ([f arg1 arg2 arg3] (fn [& args] (apply f arg1 arg2 arg3 args))) ([f arg1 arg2 arg3 & more] (fn [& args] (apply f arg1 arg2 arg3 (concat more args))))) //--- (function __clojure_core_fn_1750(){ return (clojure.JS.def(clojure.core,"partial",clojure.JS.variadic(4,(function __clojure_core_fn_1750_partial_1752(f_1,arg1_2,arg2_3,arg3_4){switch(arguments.length){ case 2:return (clojure.JS.variadic(0,(function __clojure_core_fn_1750_partial_1752_fn_1754(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[f_1,arg1_2,args_1]))}))) case 3:return (clojure.JS.variadic(0,(function __clojure_core_fn_1750_partial_1752_fn_1758(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[f_1,arg1_2,arg2_3,args_1]))}))) case 4:return (clojure.JS.variadic(0,(function __clojure_core_fn_1750_partial_1752_fn_1762(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[f_1,arg1_2,arg2_3,arg3_4,args_1]))})))} var more_5=clojure.JS.rest_args(this,arguments,4); return (clojure.JS.variadic(0,(function __clojure_core_fn_1750_partial_1752_fn_1766(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[f_1,arg1_2,arg2_3,arg3_4,clojure.core.concat.apply(null,[more_5,args_1])]))})))}))))}).apply(null,[]); //====== //(defn every? "Returns true if (pred x) is logical true for every x in coll, else\n false." {:tag Boolean} [pred coll] (if (seq coll) (and (pred (first coll)) (recur pred (rest coll))) true)) //--- (function __clojure_core_fn_1771(){ return (clojure.JS.def(clojure.core,"every_QMARK_",(function __clojure_core_fn_1771_every_QMARK_1773(pred_1,coll_2){ var _cnt,_rtn,and__948__auto___3; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[coll_2]))?(((and__948__auto___3=pred_1.apply(null,[clojure.core.first.apply(null,[coll_2])])), ((and__948__auto___3)?((_cnt=1,_rtn=[pred_1,clojure.core.rest.apply(null,[coll_2])],pred_1=_rtn[0],coll_2=_rtn[1])):(and__948__auto___3)))):(true)) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(def not-every? (comp not every?)) //--- (function __clojure_core_fn_1777(){ return (clojure.JS.def(clojure.core,"not_every_QMARK_",clojure.core.comp.apply(null,[clojure.core.not,clojure.core.every_QMARK_])))}).apply(null,[]); //====== //(defn some "Returns the first logical true value of (pred x) for any x in coll,\n else nil. One common idiom is to use a set as pred, for example\n this will return true if :fred is in the sequence, otherwise nil:\n (some #{:fred} coll)" [pred coll] (when (seq coll) (or (pred (first coll)) (recur pred (rest coll))))) //--- (function __clojure_core_fn_1780(){ return (clojure.JS.def(clojure.core,"some",(function __clojure_core_fn_1780_some_1782(pred_1,coll_2){ var _cnt,_rtn,or__962__auto___3; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[coll_2]))?(((or__962__auto___3=pred_1.apply(null,[clojure.core.first.apply(null,[coll_2])])), ((or__962__auto___3)?(or__962__auto___3):((_cnt=1,_rtn=[pred_1,clojure.core.rest.apply(null,[coll_2])],pred_1=_rtn[0],coll_2=_rtn[1]))))):(null)) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(def not-any? (comp not some)) //--- (function __clojure_core_fn_1786(){ return (clojure.JS.def(clojure.core,"not_any_QMARK_",clojure.core.comp.apply(null,[clojure.core.not,clojure.core.some])))}).apply(null,[]); //====== //(defn map "Returns a lazy seq consisting of the result of applying f to the\n set of first items of each coll, followed by applying f to the set\n of second items in each coll, until any one of the colls is\n exhausted. Any remaining items in other colls are ignored. Function\n f should accept number-of-colls arguments." ([f coll] (when (seq coll) (lazy-cons (f (first coll)) (map f (rest coll))))) ([f c1 c2] (when (and (seq c1) (seq c2)) (lazy-cons (f (first c1) (first c2)) (map f (rest c1) (rest c2))))) ([f c1 c2 c3] (when (and (seq c1) (seq c2) (seq c3)) (lazy-cons (f (first c1) (first c2) (first c3)) (map f (rest c1) (rest c2) (rest c3))))) ([f c1 c2 c3 & colls] (let [step (fn step [cs] (when (every? seq cs) (lazy-cons (map first cs) (step (map rest cs)))))] (map (fn* [p1__1789] (apply f p1__1789)) (step (conj colls c3 c2 c1)))))) //--- (function __clojure_core_fn_1790(){ return (clojure.JS.def(clojure.core,"map",clojure.JS.variadic(4,(function __clojure_core_fn_1790_map_1792(f_1,c1_2,c2_3,c3_4){switch(arguments.length){ case 2:var coll_2=arguments[1]; return (((clojure.core.seq.apply(null,[coll_2]))?((new clojure.lang.LazyCons((function __clojure_core_fn_1790_map_1792_fn_1795(G__1794_1){switch(arguments.length){ case 0:return (f_1.apply(null,[clojure.core.first.apply(null,[coll_2])]))} return (clojure.core.map.apply(null,[f_1,clojure.core.rest.apply(null,[coll_2])]))})))):(null))) case 3:var and__948__auto___4; return (((((and__948__auto___4=clojure.core.seq.apply(null,[c1_2])), ((and__948__auto___4)?(clojure.core.seq.apply(null,[c2_3])):(and__948__auto___4))))?((new clojure.lang.LazyCons((function __clojure_core_fn_1790_map_1792_fn_1801(G__1800_1){switch(arguments.length){ case 0:return (f_1.apply(null,[clojure.core.first.apply(null,[c1_2]),clojure.core.first.apply(null,[c2_3])]))} return (clojure.core.map.apply(null,[f_1,clojure.core.rest.apply(null,[c1_2]),clojure.core.rest.apply(null,[c2_3])]))})))):(null))) case 4:var and__948__auto___5,and__948__auto___6; return (((((and__948__auto___5=clojure.core.seq.apply(null,[c1_2])), ((and__948__auto___5)?(((and__948__auto___6=clojure.core.seq.apply(null,[c2_3])), ((and__948__auto___6)?(clojure.core.seq.apply(null,[c3_4])):(and__948__auto___6)))):(and__948__auto___5))))?((new clojure.lang.LazyCons((function __clojure_core_fn_1790_map_1792_fn_1807(G__1806_1){switch(arguments.length){ case 0:return (f_1.apply(null,[clojure.core.first.apply(null,[c1_2]),clojure.core.first.apply(null,[c2_3]),clojure.core.first.apply(null,[c3_4])]))} return (clojure.core.map.apply(null,[f_1,clojure.core.rest.apply(null,[c1_2]),clojure.core.rest.apply(null,[c2_3]),clojure.core.rest.apply(null,[c3_4])]))})))):(null)))} var step_6,colls_5=clojure.JS.rest_args(this,arguments,4); return (((step_6=(function __clojure_core_fn_1790_map_1792_step_1812(cs_1){ var step_0=arguments.callee; return (((clojure.core.every_QMARK_.apply(null,[clojure.core.seq,cs_1]))?((new clojure.lang.LazyCons((function __clojure_core_fn_1790_map_1792_step_1812_fn_1814(G__1813_1){switch(arguments.length){ case 0:return (clojure.core.map.apply(null,[clojure.core.first,cs_1]))} return (step_0.apply(null,[clojure.core.map.apply(null,[clojure.core.rest,cs_1])]))})))):(null)))})), clojure.core.map.apply(null,[(function __clojure_core_fn_1790_map_1792_fn_1819(p1__1789_1){ return (clojure.core.apply.apply(null,[f_1,p1__1789_1]))}),step_6.apply(null,[clojure.core.conj.apply(null,[colls_5,c3_4,c2_3,c1_2])])])))}))))}).apply(null,[]); //====== //(defn mapcat "Returns the result of applying concat to the result of applying map\n to f and colls. Thus function f should return a collection." [f & colls] (apply concat (apply map f colls))) //--- (function __clojure_core_fn_1824(){ return (clojure.JS.def(clojure.core,"mapcat",clojure.JS.variadic(1,(function __clojure_core_fn_1824_mapcat_1826(f_1){ var colls_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.apply.apply(null,[clojure.core.concat,clojure.core.apply.apply(null,[clojure.core.map,f_1,colls_2])]))}))))}).apply(null,[]); //====== //(defn filter "Returns a lazy seq of the items in coll for which\n (pred item) returns true. pred must be free of side-effects." [pred coll] (when (seq coll) (if (pred (first coll)) (lazy-cons (first coll) (filter pred (rest coll))) (recur pred (rest coll))))) //--- (function __clojure_core_fn_1830(){ return (clojure.JS.def(clojure.core,"filter",(function __clojure_core_fn_1830_filter_1832(pred_1,coll_2){ var _cnt,_rtn; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[coll_2]))?(((pred_1.apply(null,[clojure.core.first.apply(null,[coll_2])]))?((new clojure.lang.LazyCons((function __clojure_core_fn_1830_filter_1832_fn_1835(G__1834_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll_2]))} return (clojure.core.filter.apply(null,[pred_1,clojure.core.rest.apply(null,[coll_2])]))})))):((_cnt=1,_rtn=[pred_1,clojure.core.rest.apply(null,[coll_2])],pred_1=_rtn[0],coll_2=_rtn[1])))):(null)) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(defn remove "Returns a lazy seq of the items in coll for which\n (pred item) returns false. pred must be free of side-effects." [pred coll] (when (seq coll) (if (pred (first coll)) (recur pred (rest coll)) (lazy-cons (first coll) (remove pred (rest coll)))))) //--- (function __clojure_core_fn_1841(){ return (clojure.JS.def(clojure.core,"remove",(function __clojure_core_fn_1841_remove_1843(pred_1,coll_2){ var _cnt,_rtn; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[coll_2]))?(((pred_1.apply(null,[clojure.core.first.apply(null,[coll_2])]))?((_cnt=1,_rtn=[pred_1,clojure.core.rest.apply(null,[coll_2])],pred_1=_rtn[0],coll_2=_rtn[1])):((new clojure.lang.LazyCons((function __clojure_core_fn_1841_remove_1843_fn_1846(G__1845_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll_2]))} return (clojure.core.remove.apply(null,[pred_1,clojure.core.rest.apply(null,[coll_2])]))})))))):(null)) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(defn take "Returns a lazy seq of the first n items in coll, or all items if\n there are fewer than n." [n coll] (when (and (pos? n) (seq coll)) (lazy-cons (first coll) (when (> n 1) (take (dec n) (rest coll)))))) //--- (function __clojure_core_fn_1852(){ return (clojure.JS.def(clojure.core,"take",(function __clojure_core_fn_1852_take_1854(n_1,coll_2){ var and__948__auto___3; return (((((and__948__auto___3=clojure.lang.Numbers.isPos(n_1)), ((and__948__auto___3)?(clojure.core.seq.apply(null,[coll_2])):(and__948__auto___3))))?((new clojure.lang.LazyCons((function __clojure_core_fn_1852_take_1854_fn_1857(G__1856_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll_2]))} return (((clojure.lang.Numbers.gt(n_1,(1)))?(clojure.core.take.apply(null,[clojure.lang.Numbers.dec(n_1),clojure.core.rest.apply(null,[coll_2])])):(null)))})))):(null)))})))}).apply(null,[]); //====== //(defn take-while "Returns a lazy seq of successive items from coll while\n (pred item) returns true. pred must be free of side-effects." [pred coll] (when (and (seq coll) (pred (first coll))) (lazy-cons (first coll) (take-while pred (rest coll))))) //--- (function __clojure_core_fn_1863(){ return (clojure.JS.def(clojure.core,"take_while",(function __clojure_core_fn_1863_take_while_1865(pred_1,coll_2){ var and__948__auto___3; return (((((and__948__auto___3=clojure.core.seq.apply(null,[coll_2])), ((and__948__auto___3)?(pred_1.apply(null,[clojure.core.first.apply(null,[coll_2])])):(and__948__auto___3))))?((new clojure.lang.LazyCons((function __clojure_core_fn_1863_take_while_1865_fn_1868(G__1867_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll_2]))} return (clojure.core.take_while.apply(null,[pred_1,clojure.core.rest.apply(null,[coll_2])]))})))):(null)))})))}).apply(null,[]); //====== //(defn drop "Returns a lazy seq of all but the first n items in coll." [n coll] (if (and (pos? n) (seq coll)) (recur (dec n) (rest coll)) (seq coll))) //--- (function __clojure_core_fn_1874(){ return (clojure.JS.def(clojure.core,"drop",(function __clojure_core_fn_1874_drop_1876(n_1,coll_2){ var _cnt,_rtn,and__948__auto___3; do{_cnt=0;_rtn=((((and__948__auto___3=clojure.lang.Numbers.isPos(n_1)), ((and__948__auto___3)?(clojure.core.seq.apply(null,[coll_2])):(and__948__auto___3))))?((_cnt=1,_rtn=[clojure.lang.Numbers.dec(n_1),clojure.core.rest.apply(null,[coll_2])],n_1=_rtn[0],coll_2=_rtn[1])):(clojure.core.seq.apply(null,[coll_2]))) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(defn drop-last "Return a lazy seq of all but the last n (default 1) items in coll" ([s] (drop-last 1 s)) ([n s] (map (fn [x _] x) (seq s) (drop n s)))) //--- (function __clojure_core_fn_1880(){ return (clojure.JS.def(clojure.core,"drop_last",(function __clojure_core_fn_1880_drop_last_1882(n_1,s_2){switch(arguments.length){ case 1:var s_1=arguments[0]; return (clojure.core.drop_last.apply(null,[(1),s_1]))} return (clojure.core.map.apply(null,[(function __clojure_core_fn_1880_drop_last_1882_fn_1885(x_1,__2){ return (x_1)}),clojure.core.seq.apply(null,[s_2]),clojure.core.drop.apply(null,[n_1,s_2])]))})))}).apply(null,[]); //====== //(defn drop-while "Returns a lazy seq of the items in coll starting from the first\n item for which (pred item) returns nil." [pred coll] (if (and (seq coll) (pred (first coll))) (recur pred (rest coll)) (seq coll))) //--- (function __clojure_core_fn_1890(){ return (clojure.JS.def(clojure.core,"drop_while",(function __clojure_core_fn_1890_drop_while_1892(pred_1,coll_2){ var _cnt,_rtn,and__948__auto___3; do{_cnt=0;_rtn=((((and__948__auto___3=clojure.core.seq.apply(null,[coll_2])), ((and__948__auto___3)?(pred_1.apply(null,[clojure.core.first.apply(null,[coll_2])])):(and__948__auto___3))))?((_cnt=1,_rtn=[pred_1,clojure.core.rest.apply(null,[coll_2])],pred_1=_rtn[0],coll_2=_rtn[1])):(clojure.core.seq.apply(null,[coll_2]))) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(defn cycle "Returns a lazy (infinite!) seq of repetitions of the items in\n coll." [coll] (when (seq coll) (let [rep (fn thisfn [xs] (if xs (lazy-cons (first xs) (thisfn (rest xs))) (recur (seq coll))))] (rep (seq coll))))) //--- (function __clojure_core_fn_1896(){ return (clojure.JS.def(clojure.core,"cycle",(function __clojure_core_fn_1896_cycle_1898(coll_1){ var rep_2; return (((clojure.core.seq.apply(null,[coll_1]))?(((rep_2=(function __clojure_core_fn_1896_cycle_1898_thisfn_1900(xs_1){ var _cnt,_rtn,thisfn_0=arguments.callee; do{_cnt=0;_rtn=((xs_1)?((new clojure.lang.LazyCons((function __clojure_core_fn_1896_cycle_1898_thisfn_1900_fn_1902(G__1901_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[xs_1]))} return (thisfn_0.apply(null,[clojure.core.rest.apply(null,[xs_1])]))})))):((_cnt=1,_rtn=[clojure.core.seq.apply(null,[coll_1])],xs_1=_rtn[0]))) }while(_cnt);return _rtn;})), rep_2.apply(null,[clojure.core.seq.apply(null,[coll_1])]))):(null)))})))}).apply(null,[]); //====== //(defn split-at "Returns a vector of [(take n coll) (drop n coll)]" [n coll] [(take n coll) (drop n coll)]) //--- (function __clojure_core_fn_1909(){ return (clojure.JS.def(clojure.core,"split_at",(function __clojure_core_fn_1909_split_at_1911(n_1,coll_2){ return (clojure.JS.lit_vector([clojure.core.take.apply(null,[n_1,coll_2]),clojure.core.drop.apply(null,[n_1,coll_2])]))})))}).apply(null,[]); //====== //(defn split-with "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" [pred coll] [(take-while pred coll) (drop-while pred coll)]) //--- (function __clojure_core_fn_1915(){ return (clojure.JS.def(clojure.core,"split_with",(function __clojure_core_fn_1915_split_with_1917(pred_1,coll_2){ return (clojure.JS.lit_vector([clojure.core.take_while.apply(null,[pred_1,coll_2]),clojure.core.drop_while.apply(null,[pred_1,coll_2])]))})))}).apply(null,[]); //====== //(defn repeat "Returns a lazy (infinite!) seq of xs." [x] (lazy-cons x (repeat x))) //--- (function __clojure_core_fn_1921(){ return (clojure.JS.def(clojure.core,"repeat",(function __clojure_core_fn_1921_repeat_1923(x_1){ return ((new clojure.lang.LazyCons((function __clojure_core_fn_1921_repeat_1923_fn_1926(G__1925_1){switch(arguments.length){ case 0:return (x_1)} return (clojure.core.repeat.apply(null,[x_1]))}))))})))}).apply(null,[]); //====== //(defn replicate "Returns a lazy seq of n xs." [n x] (take n (repeat x))) //--- (function __clojure_core_fn_1932(){ return (clojure.JS.def(clojure.core,"replicate",(function __clojure_core_fn_1932_replicate_1934(n_1,x_2){ return (clojure.core.take.apply(null,[n_1,clojure.core.repeat.apply(null,[x_2])]))})))}).apply(null,[]); //====== //(defn iterate "Returns a lazy seq of x, (f x), (f (f x)) etc. f must be free of side-effects" [f x] (lazy-cons x (iterate f (f x)))) //--- (function __clojure_core_fn_1938(){ return (clojure.JS.def(clojure.core,"iterate",(function __clojure_core_fn_1938_iterate_1940(f_1,x_2){ return ((new clojure.lang.LazyCons((function __clojure_core_fn_1938_iterate_1940_fn_1943(G__1942_1){switch(arguments.length){ case 0:return (x_2)} return (clojure.core.iterate.apply(null,[f_1,f_1.apply(null,[x_2])]))}))))})))}).apply(null,[]); //====== //(defn range "Returns a lazy seq of nums from start (inclusive) to end\n (exclusive), by step, where start defaults to 0 and step to 1." ([end] (if (and (> end 0) (<= end clojure.lang.RT/IntegerMaxValue)) (new clojure.lang.Range 0 end) (take end (iterate inc 0)))) ([start end] (if (and (< start end) (>= start clojure.lang.RT/IntegerMinValue) (<= end clojure.lang.RT/IntegerMaxValue)) (new clojure.lang.Range start end) (take (- end start) (iterate inc start)))) ([start end step] (take-while (partial (if (pos? step) > <) end) (iterate (partial + step) start)))) //--- (function __clojure_core_fn_1949(){ return (clojure.JS.def(clojure.core,"range",(function __clojure_core_fn_1949_range_1951(start_1,end_2,step_3){switch(arguments.length){ case 1:var and__948__auto___2,end_1=arguments[0]; return (((((and__948__auto___2=clojure.lang.Numbers.gt(end_1,(0))), ((and__948__auto___2)?(clojure.lang.Numbers.lte(end_1,clojure.JS.getOrRun(clojure.lang.RT,"IntegerMaxValue"))):(and__948__auto___2))))?((new clojure.lang.Range((0),end_1))):(clojure.core.take.apply(null,[end_1,clojure.core.iterate.apply(null,[clojure.core.inc,(0)])])))) case 2:var and__948__auto___3,and__948__auto___4; return (((((and__948__auto___3=clojure.lang.Numbers.lt(start_1,end_2)), ((and__948__auto___3)?(((and__948__auto___4=clojure.lang.Numbers.gte(start_1,clojure.JS.getOrRun(clojure.lang.RT,"IntegerMinValue"))), ((and__948__auto___4)?(clojure.lang.Numbers.lte(end_2,clojure.JS.getOrRun(clojure.lang.RT,"IntegerMaxValue"))):(and__948__auto___4)))):(and__948__auto___3))))?((new clojure.lang.Range(start_1,end_2))):(clojure.core.take.apply(null,[clojure.lang.Numbers.minus(end_2,start_1),clojure.core.iterate.apply(null,[clojure.core.inc,start_1])]))))} return (clojure.core.take_while.apply(null,[clojure.core.partial.apply(null,[((clojure.lang.Numbers.isPos(step_3))?(clojure.core._GT_):(clojure.core._LT_)),end_2]),clojure.core.iterate.apply(null,[clojure.core.partial.apply(null,[clojure.core._PLUS_,step_3]),start_1])]))})))}).apply(null,[]); //====== //(defn merge "Returns a map that consists of the rest of the maps conj-ed onto\n the first. If a key occurs in more than one map, the mapping from\n the latter (left-to-right) will be the mapping in the result." [& maps] (when (some identity maps) (reduce (fn* [p1__1957 p2__1958] (conj (or p1__1957 {}) p2__1958)) maps))) //--- (function __clojure_core_fn_1959(){ return (clojure.JS.def(clojure.core,"merge",clojure.JS.variadic(0,(function __clojure_core_fn_1959_merge_1961(){ var maps_1=clojure.JS.rest_args(this,arguments,0); return (((clojure.core.some.apply(null,[clojure.core.identity,maps_1]))?(clojure.core.reduce.apply(null,[(function __clojure_core_fn_1959_merge_1961_fn_1963(p1__1957_1,p2__1958_2){ var or__962__auto___3; return (clojure.core.conj.apply(null,[((or__962__auto___3=p1__1957_1), ((or__962__auto___3)?(or__962__auto___3):(clojure.lang.PersistentArrayMap.EMPTY))),p2__1958_2]))}),maps_1])):(null)))}))))}).apply(null,[]); //====== //(defn merge-with "Returns a map that consists of the rest of the maps conj-ed onto\n the first. If a key occurs in more than one map, the mapping(s)\n from the latter (left-to-right) will be combined with the mapping in\n the result by calling (f val-in-result val-in-latter)." [f & maps] (when (some identity maps) (let [merge-entry (fn [m e] (let [k (key e) v (val e)] (if (contains? m k) (assoc m k (f (m k) v)) (assoc m k v)))) merge2 (fn [m1 m2] (reduce merge-entry (or m1 {}) (seq m2)))] (reduce merge2 maps)))) //--- (function __clojure_core_fn_1968(){ return (clojure.JS.def(clojure.core,"merge_with",clojure.JS.variadic(1,(function __clojure_core_fn_1968_merge_with_1970(f_1){ var merge_entry_3,merge2_4,maps_2=clojure.JS.rest_args(this,arguments,1); return (((clojure.core.some.apply(null,[clojure.core.identity,maps_2]))?(((merge_entry_3=(function __clojure_core_fn_1968_merge_with_1970_merge_entry_1972(m_1,e_2){ var k_3,v_4; return (((k_3=clojure.core.key.apply(null,[e_2])), (v_4=clojure.core.val.apply(null,[e_2])), ((clojure.core.contains_QMARK_.apply(null,[m_1,k_3]))?(clojure.core.assoc.apply(null,[m_1,k_3,f_1.apply(null,[m_1.apply(null,[k_3]),v_4])])):(clojure.core.assoc.apply(null,[m_1,k_3,v_4])))))})), (merge2_4=(function __clojure_core_fn_1968_merge_with_1970_merge2_1975(m1_1,m2_2){ var or__962__auto___3; return (clojure.core.reduce.apply(null,[merge_entry_3,((or__962__auto___3=m1_1), ((or__962__auto___3)?(or__962__auto___3):(clojure.lang.PersistentArrayMap.EMPTY))),clojure.core.seq.apply(null,[m2_2])]))})), clojure.core.reduce.apply(null,[merge2_4,maps_2]))):(null)))}))))}).apply(null,[]); //====== //(defn zipmap "Returns a map with the keys mapped to the corresponding vals." [keys vals] (loop [map {} ks (seq keys) vs (seq vals)] (if (and ks vs) (recur (assoc map (first ks) (first vs)) (rest ks) (rest vs)) map))) //--- (function __clojure_core_fn_1980(){ return (clojure.JS.def(clojure.core,"zipmap",(function __clojure_core_fn_1980_zipmap_1982(keys_1,vals_2){ var map_3,ks_4,vs_5,and__948__auto___6; return (((function __loop(){var _rtn,_cnt;(map_3=clojure.lang.PersistentArrayMap.EMPTY), (ks_4=clojure.core.seq.apply(null,[keys_1])), (vs_5=clojure.core.seq.apply(null,[vals_2]));do{_cnt=0; _rtn=((((and__948__auto___6=ks_4), ((and__948__auto___6)?(vs_5):(and__948__auto___6))))?((_cnt=1,_rtn=[clojure.core.assoc.apply(null,[map_3,clojure.core.first.apply(null,[ks_4]),clojure.core.first.apply(null,[vs_5])]),clojure.core.rest.apply(null,[ks_4]),clojure.core.rest.apply(null,[vs_5])],map_3=_rtn[0],ks_4=_rtn[1],vs_5=_rtn[2])):(map_3))}while(_cnt);return _rtn;})()))})))}).apply(null,[]); //====== //(defn line-seq "Returns the lines of text from rdr as a lazy sequence of strings.\n rdr must implement java.io.BufferedReader." [rdr] (let [line (. rdr (readLine))] (when line (lazy-cons line (line-seq rdr))))) //--- (function __clojure_core_fn_1986(){ return (clojure.JS.def(clojure.core,"line_seq",(function __clojure_core_fn_1986_line_seq_1988(rdr_1){ var line_2; return (((line_2=(rdr_1).readLine()), ((line_2)?((new clojure.lang.LazyCons((function __clojure_core_fn_1986_line_seq_1988_fn_1991(G__1990_1){switch(arguments.length){ case 0:return (line_2)} return (clojure.core.line_seq.apply(null,[rdr_1]))})))):(null))))})))}).apply(null,[]); //====== //(defn comparator "Returns an implementation of java.util.Comparator based upon pred." [pred] (fn [x y] (cond (pred x y) -1 (pred y x) 1 :else 0))) //--- (function __clojure_core_fn_1997(){ return (clojure.JS.def(clojure.core,"comparator",(function __clojure_core_fn_1997_comparator_1999(pred_1){ return ((function __clojure_core_fn_1997_comparator_1999_fn_2001(x_1,y_2){ return (((pred_1.apply(null,[x_1,y_2]))?((-1)):(((pred_1.apply(null,[y_2,x_1]))?((1)):(((clojure.core.keyword("","else"))?((0)):(null)))))))}))})))}).apply(null,[]); //====== //(defn sort "Returns a sorted sequence of the items in coll. If no comparator is\n supplied, uses compare. comparator must\n implement java.util.Comparator." ([coll] (sort compare coll)) ([comp coll] (when (and coll (not (zero? (count coll)))) (let [a (to-array coll)] (clojure.lang.RT/sortArray a comp) (seq a))))) //--- (function __clojure_core_fn_2006(){ return (clojure.JS.def(clojure.core,"sort",(function __clojure_core_fn_2006_sort_2008(comp_1,coll_2){switch(arguments.length){ case 1:var coll_1=arguments[0]; return (clojure.core.sort.apply(null,[clojure.core.compare,coll_1]))} var and__948__auto___3,a_3; return (((((and__948__auto___3=coll_2), ((and__948__auto___3)?(clojure.core.not.apply(null,[clojure.lang.Numbers.isZero(clojure.core.count.apply(null,[coll_2]))])):(and__948__auto___3))))?(((a_3=clojure.core.to_array.apply(null,[coll_2])), clojure.lang.RT.sortArray(a_3,comp_1), clojure.core.seq.apply(null,[a_3]))):(null)))})))}).apply(null,[]); //====== //(defn sort-by "Returns a sorted sequence of the items in coll, where the sort\n order is determined by comparing (keyfn item). If no comparator is\n supplied, uses compare. comparator must\n implement java.util.Comparator." ([keyfn coll] (sort-by keyfn compare coll)) ([keyfn comp coll] (sort (fn [x y] (. comp (compare (keyfn x) (keyfn y)))) coll))) //--- (function __clojure_core_fn_2013(){ return (clojure.JS.def(clojure.core,"sort_by",(function __clojure_core_fn_2013_sort_by_2015(keyfn_1,comp_2,coll_3){switch(arguments.length){ case 2:var coll_2=arguments[1]; return (clojure.core.sort_by.apply(null,[keyfn_1,clojure.core.compare,coll_2]))} return (clojure.core.sort.apply(null,[(function __clojure_core_fn_2013_sort_by_2015_fn_2018(x_1,y_2){ return ((comp_2).compare(keyfn_1.apply(null,[x_1]),keyfn_1.apply(null,[y_2])))}),coll_3]))})))}).apply(null,[]); //====== //(defn partition "Returns a lazy sequence of lists of n items each, at offsets step\n apart. If step is not supplied, defaults to n, i.e. the partitions\n do not overlap." ([n coll] (partition n n coll)) ([n step coll] (when (seq coll) (let [p (take n coll)] (when (= n (count p)) (lazy-cons p (partition n step (drop step coll)))))))) //--- (function __clojure_core_fn_2023(){ return (clojure.JS.def(clojure.core,"partition",(function __clojure_core_fn_2023_partition_2025(n_1,step_2,coll_3){switch(arguments.length){ case 2:var coll_2=arguments[1]; return (clojure.core.partition.apply(null,[n_1,n_1,coll_2]))} var p_4; return (((clojure.core.seq.apply(null,[coll_3]))?(((p_4=clojure.core.take.apply(null,[n_1,coll_3])), ((clojure.lang.Util.equiv(n_1,clojure.core.count.apply(null,[p_4])))?((new clojure.lang.LazyCons((function __clojure_core_fn_2023_partition_2025_fn_2029(G__2028_1){switch(arguments.length){ case 0:return (p_4)} return (clojure.core.partition.apply(null,[n_1,step_2,clojure.core.drop.apply(null,[step_2,coll_3])]))})))):(null)))):(null)))})))}).apply(null,[]); // Skipping: (defn eval "Evaluates the form data structure (not text!) and returns the result." [form] (. clojure.lang.Compiler (eval form))) // Skipping: (defmacro doseq "Repeatedly executes body (presumably for side-effects) with\n bindings and filtering as provided by \"for\". Does not retain\n the head of the sequence. Returns nil." [seq-exprs & body] (assert-args doseq (vector? seq-exprs) "a vector for its binding" (even? (count seq-exprs)) "an even number of forms in binding vector") (let [groups (reduce (fn [groups p] (if (keyword? (first p)) (conj (pop groups) (apply assoc (peek groups) p)) (conj groups {:bind (first p), :seq (second p)}))) [] (partition 2 seq-exprs)) emit (fn emit [group & more-groups] (clojure.core/concat (clojure.core/list (quote clojure.core/loop)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote sq__2041__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/seq)) (clojure.core/list (:seq group))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (quote sq__2041__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (:bind group)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/first)) (clojure.core/list (quote sq__2041__auto__))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (or (:while group) true)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (or (:when group) true)) (clojure.core/list (if more-groups (apply emit more-groups) (clojure.core/concat (clojure.core/list (quote do)) body))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/rest)) (clojure.core/list (quote sq__2041__auto__))))))))))))))] (apply emit groups))) //====== //(defn dorun "When lazy sequences are produced via functions that have side\n effects, any effects other than those needed to produce the first\n element in the seq do not occur until the seq is consumed. dorun can\n be used to force any effects. Walks through the successive rests of\n the seq, does not retain the head and returns nil." ([coll] (when (and (seq coll) (or (first coll) true)) (recur (rest coll)))) ([n coll] (when (and (seq coll) (pos? n) (or (first coll) true)) (recur (dec n) (rest coll))))) //--- (function __clojure_core_fn_2063(){ return (clojure.JS.def(clojure.core,"dorun",(function __clojure_core_fn_2063_dorun_2065(n_1,coll_2){switch(arguments.length){ case 1:var _cnt,_rtn,and__948__auto___2,or__962__auto___3,coll_1=arguments[0]; do{_cnt=0;_rtn=((((and__948__auto___2=clojure.core.seq.apply(null,[coll_1])), ((and__948__auto___2)?(((or__962__auto___3=clojure.core.first.apply(null,[coll_1])), ((or__962__auto___3)?(or__962__auto___3):(true)))):(and__948__auto___2))))?((_cnt=1,_rtn=[clojure.core.rest.apply(null,[coll_1])],coll_1=_rtn[0])):(null)) }while(_cnt);return _rtn;} var _cnt,_rtn,and__948__auto___3,and__948__auto___4,or__962__auto___5; do{_cnt=0;_rtn=((((and__948__auto___3=clojure.core.seq.apply(null,[coll_2])), ((and__948__auto___3)?(((and__948__auto___4=clojure.lang.Numbers.isPos(n_1)), ((and__948__auto___4)?(((or__962__auto___5=clojure.core.first.apply(null,[coll_2])), ((or__962__auto___5)?(or__962__auto___5):(true)))):(and__948__auto___4)))):(and__948__auto___3))))?((_cnt=1,_rtn=[clojure.lang.Numbers.dec(n_1),clojure.core.rest.apply(null,[coll_2])],n_1=_rtn[0],coll_2=_rtn[1])):(null)) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(defn doall "When lazy sequences are produced via functions that have side\n effects, any effects other than those needed to produce the first\n element in the seq do not occur until the seq is consumed. doall can\n be used to force any effects. Walks through the successive rests of\n the seq, retains the head and returns it, thus causing the entire\n seq to reside in memory at one time." ([coll] (dorun coll) coll) ([n coll] (dorun n coll) coll)) //--- (function __clojure_core_fn_2070(){ return (clojure.JS.def(clojure.core,"doall",(function __clojure_core_fn_2070_doall_2072(n_1,coll_2){switch(arguments.length){ case 1:var coll_1=arguments[0]; return (clojure.core.dorun.apply(null,[coll_1]), coll_1)} return (clojure.core.dorun.apply(null,[n_1,coll_2]), coll_2)})))}).apply(null,[]); // Skipping: (defn await "Blocks the current thread (indefinitely!) until all actions\n dispatched thus far, from this thread or agent, to the agent(s) have\n occurred." [& agents] (io! "await in transaction" (when *agent* (throw (clojure.lang.RT/makeException "Can't await in agent action"))) (let [latch (new java.util.concurrent.CountDownLatch (count agents)) count-down (fn [agent] (. latch (countDown)) agent)] (doseq [agent agents] (send agent count-down)) (. latch (await))))) //====== //(defn await1 [a] (when (pos? (.getQueueCount a)) (await a)) a) //--- (function __clojure_core_fn_2086(){ return (clojure.JS.def(clojure.core,"await1",(function __clojure_core_fn_2086_await1_2088(a_1){ return (((clojure.lang.Numbers.isPos((a_1).getQueueCount()))?(clojure.core.await.apply(null,[a_1])):(null)), a_1)})))}).apply(null,[]); // Skipping: (defn await-for "Blocks the current thread until all actions dispatched thus\n far (from this thread or agent) to the agents have occurred, or the\n timeout (in milliseconds) has elapsed. Returns nil if returning due\n to timeout, non-nil otherwise." [timeout-ms & agents] (io! "await-for in transaction" (when *agent* (throw (clojure.lang.RT/makeException "Can't await in agent action"))) (let [latch (new java.util.concurrent.CountDownLatch (count agents)) count-down (fn [agent] (. latch (countDown)) agent)] (doseq [agent agents] (send agent count-down)) (. latch (await timeout-ms (. java.util.concurrent.TimeUnit MILLISECONDS)))))) // Skipping: (defmacro dotimes "bindings => name n\n\n Repeatedly executes body (presumably for side-effects) with name\n bound to integers from 0 through n-1." [bindings & body] (assert-args dotimes (vector? bindings) "a vector for its binding" (= 2 (count bindings)) "exactly 2 forms in binding vector") (let [i (first bindings) n (second bindings)] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote n__2101__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/int)) (clojure.core/list n)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/loop)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list i) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/int)) (clojure.core/list 0)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/<)) (clojure.core/list i) (clojure.core/list (quote n__2101__auto__)))) body (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked-inc)) (clojure.core/list i)))))))))))) // Skipping: (defn import "import-list => (package-symbol class-name-symbols*)\n\n For each name in class-name-symbols, adds a mapping from name to the\n class named by package.name to the current namespace. Use :import in the ns \n macro in preference to calling this directly." [& import-symbols-or-lists] (let [ns *ns*] (doseq [spec import-symbols-or-lists] (if (symbol? spec) (let [n (name spec) dot (.lastIndexOf n (. clojure.lang.RT (intCast \.))) c (symbol (.substring n (inc dot)))] (. ns (importClass c (. clojure.lang.RT (classForName (name spec)))))) (let [pkg (first spec) classes (rest spec)] (doseq [c classes] (. ns (importClass c (. clojure.lang.RT (classForName (str pkg "." c))))))))))) //====== //(defn into-array "Returns an array with components set to the values in aseq. The array's\n component type is type if provided, or the type of the first value in\n aseq if present, or Object. All values in aseq must be compatible with\n the component type. Class objects for the primitive types can be obtained\n using, e.g., Integer/TYPE." ([aseq] (clojure.lang.RT/seqToTypedArray (seq aseq))) ([type aseq] (clojure.lang.RT/seqToTypedArray type (seq aseq)))) //--- (function __clojure_core_fn_2117(){ return (clojure.JS.def(clojure.core,"into_array",(function __clojure_core_fn_2117_into_array_2119(type_1,aseq_2){switch(arguments.length){ case 1:var aseq_1=arguments[0]; return (clojure.lang.RT.seqToTypedArray(clojure.core.seq.apply(null,[aseq_1])))} return (clojure.lang.RT.seqToTypedArray(type_1,clojure.core.seq.apply(null,[aseq_2])))})))}).apply(null,[]); //====== //(defn into "Returns a new coll consisting of to-coll with all of the items of\n from-coll conjoined." [to from] (let [ret to items (seq from)] (if items (recur (conj ret (first items)) (rest items)) ret))) //--- (function __clojure_core_fn_2124(){ return (clojure.JS.def(clojure.core,"into",(function __clojure_core_fn_2124_into_2126(to_1,from_2){ var _cnt,_rtn,ret_3,items_4; do{_cnt=0;_rtn=((ret_3=to_1), (items_4=clojure.core.seq.apply(null,[from_2])), ((items_4)?((_cnt=1,_rtn=[clojure.core.conj.apply(null,[ret_3,clojure.core.first.apply(null,[items_4])]),clojure.core.rest.apply(null,[items_4])],to_1=_rtn[0],from_2=_rtn[1])):(ret_3))) }while(_cnt);return _rtn;})))}).apply(null,[]); //====== //(defn array [& items] (into-array items)) //--- (function __clojure_core_fn_2130(){ return (clojure.JS.def(clojure.core,"array",clojure.JS.variadic(0,(function __clojure_core_fn_2130_array_2132(){ var items_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.into_array.apply(null,[items_1]))}))))}).apply(null,[]); // Skipping: (defn class "Returns the Class of x" [x] (if (nil? x) x (. x (getClass)))) //====== //(defn num "Coerce to Number" {:tag Number, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/num)) (clojure.core/list x)))))} [x] (. clojure.lang.Numbers (num x))) //--- (function __clojure_core_fn_2142(){ return (clojure.JS.def(clojure.core,"num",(function __clojure_core_fn_2142_num_2147(x_1){ return (clojure.lang.Numbers.num(x_1))})))}).apply(null,[]); //====== //(defn int "Coerce to int" {:tag Integer, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/intCast)) (clojure.core/list x)))))} [x] (. clojure.lang.RT (intCast x))) //--- (function __clojure_core_fn_2151(){ return (clojure.JS.def(clojure.core,"int",(function __clojure_core_fn_2151_int_2156(x_1){ return (clojure.lang.RT.intCast(x_1))})))}).apply(null,[]); //====== //(defn long "Coerce to long" {:tag Long, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/longCast)) (clojure.core/list x)))))} [x] (. x (longValue))) //--- (function __clojure_core_fn_2160(){ return (clojure.JS.def(clojure.core,"long",(function __clojure_core_fn_2160_long_2165(x_1){ return ((x_1).longValue())})))}).apply(null,[]); //====== //(defn float "Coerce to float" {:tag Float, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/floatCast)) (clojure.core/list x)))))} [x] (. x (floatValue))) //--- (function __clojure_core_fn_2169(){ return (clojure.JS.def(clojure.core,"float",(function __clojure_core_fn_2169_float_2174(x_1){ return ((x_1).floatValue())})))}).apply(null,[]); //====== //(defn double "Coerce to double" {:tag Double, :inline (fn [x] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/doubleCast)) (clojure.core/list x)))))} [x] (. x (doubleValue))) //--- (function __clojure_core_fn_2178(){ return (clojure.JS.def(clojure.core,"double",(function __clojure_core_fn_2178_double_2183(x_1){ return ((x_1).doubleValue())})))}).apply(null,[]); //====== //(defn short "Coerce to short" {:tag Short} [x] (. x (shortValue))) //--- (function __clojure_core_fn_2187(){ return (clojure.JS.def(clojure.core,"short_",(function __clojure_core_fn_2187_short_2189(x_1){ return ((x_1).shortValue())})))}).apply(null,[]); //====== //(defn byte "Coerce to byte" {:tag Byte} [x] (. x (byteValue))) //--- (function __clojure_core_fn_2193(){ return (clojure.JS.def(clojure.core,"byte_",(function __clojure_core_fn_2193_byte_2195(x_1){ return ((x_1).byteValue())})))}).apply(null,[]); //====== //(defn char "Coerce to char" {:tag Character} [x] (. clojure.lang.RT (charCast x))) //--- (function __clojure_core_fn_2199(){ return (clojure.JS.def(clojure.core,"char_",(function __clojure_core_fn_2199_char_2201(x_1){ return (clojure.lang.RT.charCast(x_1))})))}).apply(null,[]); //====== //(defn boolean "Coerce to boolean" {:tag Boolean} [x] (if x true false)) //--- (function __clojure_core_fn_2205(){ return (clojure.JS.def(clojure.core,"boolean_",(function __clojure_core_fn_2205_boolean_2207(x_1){ return (((x_1)?(true):(false)))})))}).apply(null,[]); // Skipping: (defn number? "Returns true if x is a Number" [x] (instance? Number x)) // Skipping: (defn integer? "Returns true if n is an integer" [n] (or (instance? Integer n) (instance? Long n) (instance? BigInteger n) (instance? Short n) (instance? Byte n))) //====== //(defn ratio? "Returns true if n is a Ratio" [n] (instance? clojure.lang.Ratio n)) //--- (function __clojure_core_fn_2223(){ return (clojure.JS.def(clojure.core,"ratio_QMARK_",(function __clojure_core_fn_2223_ratio_QMARK_2225(n_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Ratio,n_1]))})))}).apply(null,[]); // Skipping: (defn decimal? "Returns true if n is a BigDecimal" [n] (instance? BigDecimal n)) // Skipping: (defn float? "Returns true if n is a floating point number" [n] (or (instance? Double n) (instance? Float n))) //====== //(defn rational? [n] "Returns true if n is a rational number" (or (integer? n) (ratio? n) (decimal? n))) //--- (function __clojure_core_fn_2241(){ return (clojure.JS.def(clojure.core,"rational_QMARK_",(function __clojure_core_fn_2241_rational_QMARK_2243(n_1){ var or__962__auto___2,or__962__auto___3; return ("Returns true if n is a rational number", ((or__962__auto___2=clojure.core.integer_QMARK_.apply(null,[n_1])), ((or__962__auto___2)?(or__962__auto___2):(((or__962__auto___3=clojure.core.ratio_QMARK_.apply(null,[n_1])), ((or__962__auto___3)?(or__962__auto___3):(clojure.core.decimal_QMARK_.apply(null,[n_1]))))))))})))}).apply(null,[]); // Skipping: (defn bigint "Coerce to BigInteger" {:tag BigInteger} [x] (cond (instance? BigInteger x) x (decimal? x) (.toBigInteger x) (number? x) (BigInteger/valueOf (long x)) :else (BigInteger. x))) // Skipping: (defn bigdec "Coerce to BigDecimal" {:tag BigDecimal} [x] (cond (decimal? x) x (float? x) (. BigDecimal valueOf (double x)) (instance? BigInteger x) (BigDecimal. x) (number? x) (BigDecimal/valueOf (long x)) :else (BigDecimal. x))) //====== //(def print-initialized false) //--- (function __clojure_core_fn_2259(){ return (clojure.JS.def(clojure.core,"print_initialized",false))}).apply(null,[]); // Skipping: (defmulti print-method (fn [x writer] (class x))) //====== //(defmulti print-dup (fn [x writer] (class x))) //--- (function __clojure_core_fn_2268(){ return (clojure.JS.def(clojure.core,"print_dup",(new clojure.lang.MultiFn((function __clojure_core_fn_2268_fn_2270(x_1,writer_2){ return (clojure.core.class_.apply(null,[x_1]))}),clojure.core.keyword("","default")))))}).apply(null,[]); //====== //(defn pr-on {:private true} [x w] (if *print-dup* (print-dup x w) (print-method x w)) nil) //--- (function __clojure_core_fn_2274(){ return (clojure.JS.def(clojure.core,"pr_on",(function __clojure_core_fn_2274_pr_on_2276(x_1,w_2){ return (((clojure.core._STAR_print_dup_STAR_)?(clojure.core.print_dup.apply(null,[x_1,w_2])):(clojure.core.print_method.apply(null,[x_1,w_2]))), null)})))}).apply(null,[]); //====== //(defn pr "Prints the object(s) to the output stream that is the current value\n of *out*. Prints the object(s), separated by spaces if there is\n more than one. By default, pr and prn print in a way that objects\n can be read by the reader" ([] nil) ([x] (pr-on x *out*)) ([x & more] (pr x) (. *out* (append \space)) (apply pr more))) //--- (function __clojure_core_fn_2280(){ return (clojure.JS.def(clojure.core,"pr",clojure.JS.variadic(1,(function __clojure_core_fn_2280_pr_2282(x_1){switch(arguments.length){ case 0:return (null) case 1:return (clojure.core.pr_on.apply(null,[x_1,clojure.core._STAR_out_STAR_]))} var more_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.pr.apply(null,[x_1]), (clojure.core._STAR_out_STAR_).append(" "), clojure.core.apply.apply(null,[clojure.core.pr,more_2]))}))))}).apply(null,[]); //====== //(defn newline "Writes a newline to the output stream that is the current value of\n *out*" [] (. *out* (append \newline)) nil) //--- (function __clojure_core_fn_2288(){ return (clojure.JS.def(clojure.core,"newline",(function __clojure_core_fn_2288_newline_2290(){ return ((clojure.core._STAR_out_STAR_).append("\n"), null)})))}).apply(null,[]); //====== //(defn flush "Flushes the output stream that is the current value of\n *out*" [] (. *out* (flush)) nil) //--- (function __clojure_core_fn_2294(){ return (clojure.JS.def(clojure.core,"flush",(function __clojure_core_fn_2294_flush_2296(){ return ((clojure.core._STAR_out_STAR_).flush(), null)})))}).apply(null,[]); //====== //(defn prn "Same as pr followed by (newline). Observes *flush-on-newline*" [& more] (apply pr more) (newline) (when *flush-on-newline* (flush))) //--- (function __clojure_core_fn_2300(){ return (clojure.JS.def(clojure.core,"prn",clojure.JS.variadic(0,(function __clojure_core_fn_2300_prn_2302(){ var more_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[clojure.core.pr,more_1]), clojure.core.newline.apply(null,[]), ((clojure.core._STAR_flush_on_newline_STAR_)?(clojure.core.flush.apply(null,[])):(null)))}))))}).apply(null,[]); //====== //(defn print "Prints the object(s) to the output stream that is the current value\n of *out*. print and println produce output for human consumption." [& more] (binding [*print-readably* nil] (apply pr more))) //--- (function __clojure_core_fn_2306(){ return (clojure.JS.def(clojure.core,"print",clojure.JS.variadic(0,(function __clojure_core_fn_2306_print_2308(){ var more_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_print_readably_STAR_,null])), (function __try(){try{var _rtn=(clojure.core.apply.apply(null,[clojure.core.pr,more_1]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())}))))}).apply(null,[]); //====== //(defn println "Same as print followed by (newline)" [& more] (binding [*print-readably* nil] (apply prn more))) //--- (function __clojure_core_fn_2312(){ return (clojure.JS.def(clojure.core,"println",clojure.JS.variadic(0,(function __clojure_core_fn_2312_println_2314(){ var more_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_print_readably_STAR_,null])), (function __try(){try{var _rtn=(clojure.core.apply.apply(null,[clojure.core.prn,more_1]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())}))))}).apply(null,[]); //====== //(defn read "Reads the next object from stream, which must be an instance of\n java.io.PushbackReader or some derivee. stream defaults to the\n current value of *in* ." ([] (read *in*)) ([stream] (read stream true nil)) ([stream eof-error? eof-value] (read stream eof-error? eof-value false)) ([stream eof-error? eof-value recursive?] (. clojure.lang.LispReader (read stream (boolean eof-error?) eof-value recursive?)))) //--- (function __clojure_core_fn_2318(){ return (clojure.JS.def(clojure.core,"read",(function __clojure_core_fn_2318_read_2320(stream_1,eof_error_QMARK__2,eof_value_3,recursive_QMARK__4){switch(arguments.length){ case 0:return (clojure.core.read.apply(null,[clojure.core._STAR_in_STAR_])) case 1:return (clojure.core.read.apply(null,[stream_1,true,null])) case 3:return (clojure.core.read.apply(null,[stream_1,eof_error_QMARK__2,eof_value_3,false]))} return (clojure.lang.LispReader.read(stream_1,clojure.core.boolean_.apply(null,[eof_error_QMARK__2]),eof_value_3,recursive_QMARK__4))})))}).apply(null,[]); //====== //(defn read-line "Reads the next line from stream that is the current value of *in* ." [] (. *in* (readLine))) //--- (function __clojure_core_fn_2327(){ return (clojure.JS.def(clojure.core,"read_line",(function __clojure_core_fn_2327_read_line_2329(){ return ((clojure.core._STAR_in_STAR_).readLine())})))}).apply(null,[]); //====== //(defn read-string "Reads one object from the string s" [s] (clojure.lang.RT/readString s)) //--- (function __clojure_core_fn_2333(){ return (clojure.JS.def(clojure.core,"read_string",(function __clojure_core_fn_2333_read_string_2335(s_1){ return (clojure.lang.RT.readString(s_1))})))}).apply(null,[]); //====== //(defn subvec "Returns a persistent vector of the items in vector from\n start (inclusive) to end (exclusive). If end is not supplied,\n defaults to (count vector). This operation is O(1) and very fast, as\n the resulting vector shares structure with the original and no\n trimming is done." ([v start] (subvec v start (count v))) ([v start end] (. clojure.lang.RT (subvec v start end)))) //--- (function __clojure_core_fn_2339(){ return (clojure.JS.def(clojure.core,"subvec",(function __clojure_core_fn_2339_subvec_2341(v_1,start_2,end_3){switch(arguments.length){ case 2:return (clojure.core.subvec.apply(null,[v_1,start_2,clojure.core.count.apply(null,[v_1])]))} return (clojure.lang.RT.subvec(v_1,start_2,end_3))})))}).apply(null,[]); // Skipping: (defmacro with-open "bindings => [name init ...]\n\n Evaluates body in a try expression with names bound to the values\n of the inits, and a finally clause that calls (.close name) on each\n name in reverse order." [bindings & body] (assert-args with-open (vector? bindings) "a vector for its binding" (even? (count bindings)) "an even number of forms in binding vector") (cond (= (count bindings) 0) (clojure.core/concat (clojure.core/list (quote do)) body) (symbol? (bindings 0)) (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (subvec bindings 0 2)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote try)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/with-open)) (clojure.core/list (subvec bindings 2)) body)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote finally)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (bindings 0)) (clojure.core/list (quote clojure.core/close))))))))) :else (throw (IllegalArgumentException. "with-open only allows Symbols in bindings")))) // Skipping: (defmacro doto "Evaluates x then calls all of the methods and functions with the \n value of x supplied at the from of the given arguments. The forms\n are evaluated in order. Returns x.\n\n (doto (new java.util.HashMap) (.put \"a\" 1) (.put \"b\" 2))" [x & forms] (let [gx (gensym)] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list gx) (clojure.core/list x)))) (map (fn [f] (if (seq? f) (clojure.core/concat (clojure.core/list (first f)) (clojure.core/list gx) (rest f)) (clojure.core/concat (clojure.core/list f) (clojure.core/list gx)))) forms) (clojure.core/list gx)))) // Skipping: (defmacro memfn "Expands into code that creates a fn that expects to be passed an\n object and any args and calls the named instance method on the\n object passing the args. Use when you want to treat a Java method as\n a first-class fn." [name & args] (clojure.core/concat (clojure.core/list (quote clojure.core/fn)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote target__2370__auto__)) args))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote target__2370__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list name) args)))))) // Skipping: (defmacro time "Evaluates expr and prints the time it took. Returns the value of\n expr." [expr] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote start__2380__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote java.lang.System)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/nanoTime)))))) (clojure.core/list (quote ret__2381__auto__)) (clojure.core/list expr)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/prn)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/str)) (clojure.core/list "Elapsed time: ") (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core//)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/double)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/-)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote java.lang.System)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/nanoTime)))))) (clojure.core/list (quote start__2380__auto__)))))) (clojure.core/list 1000000.0))) (clojure.core/list " msecs"))))) (clojure.core/list (quote ret__2381__auto__)))) //====== //(import (quote (java.lang.reflect Array))) //--- (function __clojure_core_fn_2391(){ return (clojure.core.import_.apply(null,[clojure.JS.lit_list([clojure.core.symbol("java.lang.reflect"),clojure.core.symbol("Array")])]))}).apply(null,[]); //====== //(import (quote (clojure.lang RT))) //--- (function __clojure_core_fn_2394(){ return (clojure.core.import_.apply(null,[clojure.JS.lit_list([clojure.core.symbol("clojure.lang"),clojure.core.symbol("RT")])]))}).apply(null,[]); //====== //(defn alength "Returns the length of the Java array. Works on arrays of all\n types." {:inline (fn [a] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/alength)) (clojure.core/list a)))))} [array] (. clojure.lang.RT (alength array))) //--- (function __clojure_core_fn_2397(){ return (clojure.JS.def(clojure.core,"alength",(function __clojure_core_fn_2397_alength_2402(array_1){ return (clojure.lang.RT.alength(array_1))})))}).apply(null,[]); //====== //(defn aclone "Returns a clone of the Java array. Works on arrays of known\n types." {:inline (fn [a] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/aclone)) (clojure.core/list a)))))} [array] (. clojure.lang.RT (aclone array))) //--- (function __clojure_core_fn_2406(){ return (clojure.JS.def(clojure.core,"aclone",(function __clojure_core_fn_2406_aclone_2411(array_1){ return (clojure.lang.RT.aclone(array_1))})))}).apply(null,[]); //====== //(defn aget "Returns the value at the index/indices. Works on Java arrays of all\n types." {:inline (fn [a i] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/aget)) (clojure.core/list a) (clojure.core/list i))))), :inline-arities #{2}} ([array idx] (clojure.lang.Reflector/prepRet (RT/aget array idx))) ([array idx & idxs] (apply aget (aget array idx) idxs))) //--- (function __clojure_core_fn_2415(){ return (clojure.JS.def(clojure.core,"aget",clojure.JS.variadic(2,(function __clojure_core_fn_2415_aget_2420(array_1,idx_2){switch(arguments.length){ case 2:return (clojure.lang.Reflector.prepRet(clojure.lang.RT.aget(array_1,idx_2)))} var idxs_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.apply.apply(null,[clojure.core.aget,clojure.lang.RT.aget(array_1,idx_2),idxs_3]))}))))}).apply(null,[]); //====== //(defn aset "Sets the value at the index/indices. Works on Java arrays of\n reference types. Returns val." {:inline (fn [a i v] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.RT)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/aset)) (clojure.core/list a) (clojure.core/list i) (clojure.core/list v))))), :inline-arities #{3}} ([array idx val] (RT/aset array idx val) val) ([array idx idx2 & idxv] (apply aset (aget array idx) idx2 idxv))) //--- (function __clojure_core_fn_2425(){ return (clojure.JS.def(clojure.core,"aset",clojure.JS.variadic(3,(function __clojure_core_fn_2425_aset_2430(array_1,idx_2,idx2_3){switch(arguments.length){ case 3:var val_3=arguments[2]; return (clojure.lang.RT.aset(array_1,idx_2,val_3), val_3)} var idxv_4=clojure.JS.rest_args(this,arguments,3); return (clojure.core.apply.apply(null,[clojure.core.aset,clojure.lang.RT.aget(array_1,idx_2),idx2_3,idxv_4]))}))))}).apply(null,[]); // Skipping: (defmacro def-aset [name method coerce] (clojure.core/concat (clojure.core/list (quote clojure.core/defn)) (clojure.core/list name) (clojure.core/list (clojure.core/apply clojure.core/hash-map (clojure.core/concat (clojure.core/list :arglists) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list (clojure.core/concat (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote array)) (clojure.core/list (quote idx)) (clojure.core/list (quote val))))) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote array)) (clojure.core/list (quote idx)) (clojure.core/list (quote idx2)) (clojure.core/list (quote &)) (clojure.core/list (quote idxv)))))))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote array__2435__auto__)) (clojure.core/list (quote idx__2436__auto__)) (clojure.core/list (quote val__2437__auto__))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote java.lang.reflect.Array)) (clojure.core/list (clojure.core/concat (clojure.core/list method) (clojure.core/list (quote array__2435__auto__)) (clojure.core/list (quote idx__2436__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list coerce) (clojure.core/list (quote val__2437__auto__)))))))) (clojure.core/list (quote val__2437__auto__)))) (clojure.core/list (clojure.core/concat (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote array__2435__auto__)) (clojure.core/list (quote idx__2436__auto__)) (clojure.core/list (quote idx2__2438__auto__)) (clojure.core/list (quote &)) (clojure.core/list (quote idxv__2439__auto__))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/apply)) (clojure.core/list name) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/aget)) (clojure.core/list (quote array__2435__auto__)) (clojure.core/list (quote idx__2436__auto__)))) (clojure.core/list (quote idx2__2438__auto__)) (clojure.core/list (quote idxv__2439__auto__)))))))) // Skipping: (def-aset aset-int setInt int) // Skipping: (def-aset aset-long setLong long) // Skipping: (def-aset aset-boolean setBoolean boolean) // Skipping: (def-aset aset-float setFloat float) // Skipping: (def-aset aset-double setDouble double) // Skipping: (def-aset aset-short setShort short) // Skipping: (def-aset aset-byte setByte byte) // Skipping: (def-aset aset-char setChar char) // Skipping: (defn make-array "Creates and returns an array of instances of the specified class of\n the specified dimension(s). Note that a class object is required.\n Class objects can be obtained by using their imported or\n fully-qualified name. Class objects for the primitive types can be\n obtained using, e.g., Integer/TYPE." ([type len] (. Array (newInstance type (int len)))) ([type dim & more-dims] (let [dims (cons dim more-dims) dimarray (make-array (. Integer TYPE) (count dims))] (dotimes [i (alength dimarray)] (aset-int dimarray i (nth dims i))) (. Array (newInstance type dimarray))))) // Skipping: (defn to-array-2d "Returns a (potentially-ragged) 2-dimensional array of Objects\n containing the contents of coll, which can be any Collection of any\n Collection." [coll] (let [ret (make-array (. Class (forName "[Ljava.lang.Object;")) (. coll (size)))] (loop [i 0 xs (seq coll)] (when xs (aset ret i (to-array (first xs))) (recur (inc i) (rest xs)))) ret)) // Skipping: (defn macroexpand-1 "If form represents a macro form, returns its expansion,\n else returns form." [form] (. clojure.lang.Compiler (macroexpand1 form))) // Skipping: (defn macroexpand "Repeatedly calls macroexpand-1 on form until it no longer\n represents a macro form, then returns it. Note neither\n macroexpand-1 nor macroexpand expand macros in subforms." [form] (let [ex (macroexpand-1 form)] (if (identical? ex form) form (macroexpand ex)))) //====== //(defn create-struct "Returns a structure basis object." [& keys] (. clojure.lang.PersistentStructMap (createSlotMap keys))) //--- (function __clojure_core_fn_2530(){ return (clojure.JS.def(clojure.core,"create_struct",clojure.JS.variadic(0,(function __clojure_core_fn_2530_create_struct_2532(){ var keys_1=clojure.JS.rest_args(this,arguments,0); return (clojure.lang.PersistentStructMap.createSlotMap(keys_1))}))))}).apply(null,[]); // Skipping: (defmacro defstruct "Same as (def name (create-struct keys...))" [name & keys] (clojure.core/concat (clojure.core/list (quote def)) (clojure.core/list name) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/create-struct)) keys)))) //====== //(defn struct-map "Returns a new structmap instance with the keys of the\n structure-basis. keyvals may contain all, some or none of the basis\n keys - where values are not supplied they will default to nil.\n keyvals can also contain keys not in the basis." [s & inits] (. clojure.lang.PersistentStructMap (create s inits))) //--- (function __clojure_core_fn_2545(){ return (clojure.JS.def(clojure.core,"struct_map",clojure.JS.variadic(1,(function __clojure_core_fn_2545_struct_map_2547(s_1){ var inits_2=clojure.JS.rest_args(this,arguments,1); return (clojure.lang.PersistentStructMap.create(s_1,inits_2))}))))}).apply(null,[]); //====== //(defn struct "Returns a new structmap instance with the keys of the\n structure-basis. vals must be supplied for basis keys in order -\n where values are not supplied they will default to nil." [s & vals] (. clojure.lang.PersistentStructMap (construct s vals))) //--- (function __clojure_core_fn_2551(){ return (clojure.JS.def(clojure.core,"struct",clojure.JS.variadic(1,(function __clojure_core_fn_2551_struct_2553(s_1){ var vals_2=clojure.JS.rest_args(this,arguments,1); return (clojure.lang.PersistentStructMap.construct(s_1,vals_2))}))))}).apply(null,[]); //====== //(defn accessor "Returns a fn that, given an instance of a structmap with the basis,\n returns the value at the key. The key must be in the basis. The\n returned function should be (slightly) more efficient than using\n get, but such use of accessors should be limited to known\n performance-critical areas." [s key] (. clojure.lang.PersistentStructMap (getAccessor s key))) //--- (function __clojure_core_fn_2557(){ return (clojure.JS.def(clojure.core,"accessor",(function __clojure_core_fn_2557_accessor_2559(s_1,key_2){ return (clojure.lang.PersistentStructMap.getAccessor(s_1,key_2))})))}).apply(null,[]); // Skipping: (defn load-reader "Sequentially read and evaluate the set of forms contained in the\n stream/file" [rdr] (. clojure.lang.Compiler (load rdr))) // Skipping: (defn load-string "Sequentially read and evaluate the set of forms contained in the\n string" [s] (let [rdr (-> (java.io.StringReader. s) (clojure.lang.LineNumberingPushbackReader.))] (load-reader rdr))) //====== //(defn resultset-seq "Creates and returns a lazy sequence of structmaps corresponding to\n the rows in the java.sql.ResultSet rs" [rs] (let [rsmeta (. rs (getMetaData)) idxs (range 1 (inc (. rsmeta (getColumnCount)))) keys (map (comp keyword (memfn toLowerCase)) (map (fn [i] (. rsmeta (getColumnName i))) idxs)) row-struct (apply create-struct keys) row-values (fn [] (map (fn [i] (. rs (getObject i))) idxs)) rows (fn thisfn [] (when (. rs (next)) (lazy-cons (apply struct row-struct (row-values)) (thisfn))))] (rows))) //--- (function __clojure_core_fn_2575(){ return (clojure.JS.def(clojure.core,"resultset_seq",(function __clojure_core_fn_2575_resultset_seq_2577(rs_1){ var rsmeta_2,idxs_3,keys_4,row_struct_5,row_values_6,rows_7; return (((rsmeta_2=(rs_1).getMetaData()), (idxs_3=clojure.core.range.apply(null,[(1),clojure.lang.Numbers.inc((rsmeta_2).getColumnCount())])), (keys_4=clojure.core.map.apply(null,[clojure.core.comp.apply(null,[clojure.core.keyword,(function __clojure_core_fn_2575_resultset_seq_2577_fn_2579(target__2370__auto___1){ return ((target__2370__auto___1).toLowerCase())})]),clojure.core.map.apply(null,[(function __clojure_core_fn_2575_resultset_seq_2577_fn_2582(i_1){ return ((rsmeta_2).getColumnName(i_1))}),idxs_3])])), (row_struct_5=clojure.core.apply.apply(null,[clojure.core.create_struct,keys_4])), (row_values_6=(function __clojure_core_fn_2575_resultset_seq_2577_row_values_2585(){ return (clojure.core.map.apply(null,[(function __clojure_core_fn_2575_resultset_seq_2577_row_values_2585_fn_2587(i_1){ return ((rs_1).getObject(i_1))}),idxs_3]))})), (rows_7=(function __clojure_core_fn_2575_resultset_seq_2577_thisfn_2591(){ var thisfn_0=arguments.callee; return ((((rs_1).next())?((new clojure.lang.LazyCons((function __clojure_core_fn_2575_resultset_seq_2577_thisfn_2591_fn_2593(G__2592_1){switch(arguments.length){ case 0:return (clojure.core.apply.apply(null,[clojure.core.struct,row_struct_5,row_values_6.apply(null,[])]))} return (thisfn_0.apply(null,[]))})))):(null)))})), rows_7.apply(null,[])))})))}).apply(null,[]); //====== //(defn set "Returns a set of the distinct elements of coll." [coll] (apply hash-set coll)) //--- (function __clojure_core_fn_2600(){ return (clojure.JS.def(clojure.core,"set",(function __clojure_core_fn_2600_set_2602(coll_1){ return (clojure.core.apply.apply(null,[clojure.core.hash_set,coll_1]))})))}).apply(null,[]); // Skipping: (defn class? "Returns true if x is an instance of Class" [x] (instance? Class x)) //====== //(defn filter-key [keyfn pred amap] (loop [ret {} es (seq amap)] (if es (if (pred (keyfn (first es))) (recur (assoc ret (key (first es)) (val (first es))) (rest es)) (recur ret (rest es))) ret))) //--- (function __clojure_core_fn_2612(){ return (clojure.JS.def(clojure.core,"filter_key",(function __clojure_core_fn_2612_filter_key_2614(keyfn_1,pred_2,amap_3){ var ret_4,es_5; return (((function __loop(){var _rtn,_cnt;(ret_4=clojure.lang.PersistentArrayMap.EMPTY), (es_5=clojure.core.seq.apply(null,[amap_3]));do{_cnt=0; _rtn=((es_5)?(((pred_2.apply(null,[keyfn_1.apply(null,[clojure.core.first.apply(null,[es_5])])]))?((_cnt=1,_rtn=[clojure.core.assoc.apply(null,[ret_4,clojure.core.key.apply(null,[clojure.core.first.apply(null,[es_5])]),clojure.core.val.apply(null,[clojure.core.first.apply(null,[es_5])])]),clojure.core.rest.apply(null,[es_5])],ret_4=_rtn[0],es_5=_rtn[1])):((_cnt=1,_rtn=[ret_4,clojure.core.rest.apply(null,[es_5])],ret_4=_rtn[0],es_5=_rtn[1])))):(ret_4))}while(_cnt);return _rtn;})()))})))}).apply(null,[]); //====== //(defn find-ns "Returns the namespace named by the symbol or nil if it doesn't exist." [sym] (clojure.lang.Namespace/find sym)) //--- (function __clojure_core_fn_2618(){ return (clojure.JS.def(clojure.core,"find_ns",(function __clojure_core_fn_2618_find_ns_2620(sym_1){ return (clojure.lang.Namespace.find(sym_1))})))}).apply(null,[]); //====== //(defn create-ns "Create a new namespace named by the symbol if one doesn't already\n exist, returns it or the already-existing namespace of the same\n name." [sym] (clojure.lang.Namespace/findOrCreate sym)) //--- (function __clojure_core_fn_2624(){ return (clojure.JS.def(clojure.core,"create_ns",(function __clojure_core_fn_2624_create_ns_2626(sym_1){ return (clojure.lang.Namespace.findOrCreate(sym_1))})))}).apply(null,[]); //====== //(defn remove-ns "Removes the namespace named by the symbol. Use with caution.\n Cannot be used to remove the clojure namespace." [sym] (clojure.lang.Namespace/remove sym)) //--- (function __clojure_core_fn_2630(){ return (clojure.JS.def(clojure.core,"remove_ns",(function __clojure_core_fn_2630_remove_ns_2632(sym_1){ return (clojure.lang.Namespace.remove(sym_1))})))}).apply(null,[]); //====== //(defn all-ns "Returns a sequence of all namespaces." [] (clojure.lang.Namespace/all)) //--- (function __clojure_core_fn_2636(){ return (clojure.JS.def(clojure.core,"all_ns",(function __clojure_core_fn_2636_all_ns_2638(){ return (clojure.lang.Namespace.all())})))}).apply(null,[]); //====== //(defn the-ns "If passed a namespace, returns it. Else, when passed a symbol,\n returns the namespace named by it, throwing an exception if not\n found." [x] (if (instance? clojure.lang.Namespace x) x (or (find-ns x) (throw (RT/makeException (str "No namespace: " x " found")))))) //--- (function __clojure_core_fn_2642(){ return (clojure.JS.def(clojure.core,"the_ns",(function __clojure_core_fn_2642_the_ns_2644(x_1){ var or__962__auto___2; return (((clojure.core.instance_QMARK_.apply(null,[clojure.lang.Namespace,x_1]))?(x_1):(((or__962__auto___2=clojure.core.find_ns.apply(null,[x_1])), ((or__962__auto___2)?(or__962__auto___2):((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["No namespace: ",x_1," found"]))})()))))))})))}).apply(null,[]); //====== //(defn ns-name "Returns the name of the namespace, a symbol." [ns] (.getName (the-ns ns))) //--- (function __clojure_core_fn_2648(){ return (clojure.JS.def(clojure.core,"ns_name",(function __clojure_core_fn_2648_ns_name_2650(ns_1){ return ((clojure.core.the_ns.apply(null,[ns_1])).getName())})))}).apply(null,[]); //====== //(defn ns-map "Returns a map of all the mappings for the namespace." [ns] (.getMappings (the-ns ns))) //--- (function __clojure_core_fn_2654(){ return (clojure.JS.def(clojure.core,"ns_map",(function __clojure_core_fn_2654_ns_map_2656(ns_1){ return ((clojure.core.the_ns.apply(null,[ns_1])).getMappings())})))}).apply(null,[]); //====== //(defn ns-unmap "Removes the mappings for the symbol from the namespace." [ns sym] (.unmap (the-ns ns) sym)) //--- (function __clojure_core_fn_2660(){ return (clojure.JS.def(clojure.core,"ns_unmap",(function __clojure_core_fn_2660_ns_unmap_2662(ns_1,sym_2){ return ((clojure.core.the_ns.apply(null,[ns_1])).unmap(sym_2))})))}).apply(null,[]); //====== //(defn ns-publics "Returns a map of the public intern mappings for the namespace." [ns] (let [ns (the-ns ns)] (filter-key val (fn [v] (and (instance? clojure.lang.Var v) (= ns (.ns v)) (.isPublic v))) (ns-map ns)))) //--- (function __clojure_core_fn_2666(){ return (clojure.JS.def(clojure.core,"ns_publics",(function __clojure_core_fn_2666_ns_publics_2668(ns_1){ var ns_2; return (((ns_2=clojure.core.the_ns.apply(null,[ns_1])), clojure.core.filter_key.apply(null,[clojure.core.val,(function __clojure_core_fn_2666_ns_publics_2668_fn_2670(v_1){ var and__948__auto___2,and__948__auto___3; return (((and__948__auto___2=clojure.core.instance_QMARK_.apply(null,[clojure.lang.Var,v_1])), ((and__948__auto___2)?(((and__948__auto___3=clojure.lang.Util.equiv(ns_2,clojure.JS.getOrRun(v_1,"ns"))), ((and__948__auto___3)?((v_1).isPublic()):(and__948__auto___3)))):(and__948__auto___2))))}),clojure.core.ns_map.apply(null,[ns_2])])))})))}).apply(null,[]); //====== //(defn ns-imports "Returns a map of the import mappings for the namespace." [ns] (filter-key val class? (ns-map ns))) //--- (function __clojure_core_fn_2675(){ return (clojure.JS.def(clojure.core,"ns_imports",(function __clojure_core_fn_2675_ns_imports_2677(ns_1){ return (clojure.core.filter_key.apply(null,[clojure.core.val,clojure.core.class_QMARK_,clojure.core.ns_map.apply(null,[ns_1])]))})))}).apply(null,[]); // Skipping: (defn refer "refers to all public vars of ns, subject to filters.\n filters can include at most one each of:\n\n :exclude list-of-symbols\n :only list-of-symbols\n :rename map-of-fromsymbol-tosymbol\n\n For each public interned var in the namespace named by the symbol,\n adds a mapping from the name of the var to the var to the current\n namespace. Throws an exception if name is already mapped to\n something else in the current namespace. Filters can be used to\n select a subset, via inclusion or exclusion, or to provide a mapping\n to a symbol different from the var's name, in order to prevent\n clashes. Use :use in the ns macro in preference to calling this directly." [ns-sym & filters] (let [ns (or (find-ns ns-sym) (throw (RT/makeException (str "No namespace: " ns-sym)))) fs (apply hash-map filters) nspublics (ns-publics ns) rename (or (:rename fs) {}) exclude (set (:exclude fs)) to-do (or (:only fs) (keys nspublics))] (doseq [sym to-do] (when-not (exclude sym) (let [v (nspublics sym)] (when-not v (throw (new java.lang.IllegalAccessError (str sym " is not public")))) (. *ns* (refer (or (rename sym) sym) v))))))) //====== //(defn ns-refers "Returns a map of the refer mappings for the namespace." [ns] (let [ns (the-ns ns)] (filter-key val (fn [v] (and (instance? clojure.lang.Var v) (not= ns (.ns v)))) (ns-map ns)))) //--- (function __clojure_core_fn_2687(){ return (clojure.JS.def(clojure.core,"ns_refers",(function __clojure_core_fn_2687_ns_refers_2689(ns_1){ var ns_2; return (((ns_2=clojure.core.the_ns.apply(null,[ns_1])), clojure.core.filter_key.apply(null,[clojure.core.val,(function __clojure_core_fn_2687_ns_refers_2689_fn_2691(v_1){ var and__948__auto___2; return (((and__948__auto___2=clojure.core.instance_QMARK_.apply(null,[clojure.lang.Var,v_1])), ((and__948__auto___2)?(clojure.core.not_EQ_.apply(null,[ns_2,clojure.JS.getOrRun(v_1,"ns")])):(and__948__auto___2))))}),clojure.core.ns_map.apply(null,[ns_2])])))})))}).apply(null,[]); //====== //(defn ns-interns "Returns a map of the intern mappings for the namespace." [ns] (let [ns (the-ns ns)] (filter-key val (fn [v] (and (instance? clojure.lang.Var v) (= ns (.ns v)))) (ns-map ns)))) //--- (function __clojure_core_fn_2696(){ return (clojure.JS.def(clojure.core,"ns_interns",(function __clojure_core_fn_2696_ns_interns_2698(ns_1){ var ns_2; return (((ns_2=clojure.core.the_ns.apply(null,[ns_1])), clojure.core.filter_key.apply(null,[clojure.core.val,(function __clojure_core_fn_2696_ns_interns_2698_fn_2700(v_1){ var and__948__auto___2; return (((and__948__auto___2=clojure.core.instance_QMARK_.apply(null,[clojure.lang.Var,v_1])), ((and__948__auto___2)?(clojure.lang.Util.equiv(ns_2,clojure.JS.getOrRun(v_1,"ns"))):(and__948__auto___2))))}),clojure.core.ns_map.apply(null,[ns_2])])))})))}).apply(null,[]); //====== //(defn alias "Add an alias in the current namespace to another\n namespace. Arguments are two symbols: the alias to be used, and\n the symbolic name of the target namespace. Use :as in the ns macro in preference \n to calling this directly." [alias namespace-sym] (.addAlias *ns* alias (find-ns namespace-sym))) //--- (function __clojure_core_fn_2705(){ return (clojure.JS.def(clojure.core,"alias",(function __clojure_core_fn_2705_alias_2707(alias_1,namespace_sym_2){ return ((clojure.core._STAR_ns_STAR_).addAlias(alias_1,clojure.core.find_ns.apply(null,[namespace_sym_2])))})))}).apply(null,[]); //====== //(defn ns-aliases "Returns a map of the aliases for the namespace." [ns] (.getAliases (the-ns ns))) //--- (function __clojure_core_fn_2711(){ return (clojure.JS.def(clojure.core,"ns_aliases",(function __clojure_core_fn_2711_ns_aliases_2713(ns_1){ return ((clojure.core.the_ns.apply(null,[ns_1])).getAliases())})))}).apply(null,[]); //====== //(defn ns-unalias "Removes the alias for the symbol from the namespace." [ns sym] (.removeAlias (the-ns ns) sym)) //--- (function __clojure_core_fn_2717(){ return (clojure.JS.def(clojure.core,"ns_unalias",(function __clojure_core_fn_2717_ns_unalias_2719(ns_1,sym_2){ return ((clojure.core.the_ns.apply(null,[ns_1])).removeAlias(sym_2))})))}).apply(null,[]); //====== //(defn take-nth "Returns a lazy seq of every nth item in coll." [n coll] (when (seq coll) (lazy-cons (first coll) (take-nth n (drop n coll))))) //--- (function __clojure_core_fn_2723(){ return (clojure.JS.def(clojure.core,"take_nth",(function __clojure_core_fn_2723_take_nth_2725(n_1,coll_2){ return (((clojure.core.seq.apply(null,[coll_2]))?((new clojure.lang.LazyCons((function __clojure_core_fn_2723_take_nth_2725_fn_2728(G__2727_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll_2]))} return (clojure.core.take_nth.apply(null,[n_1,clojure.core.drop.apply(null,[n_1,coll_2])]))})))):(null)))})))}).apply(null,[]); //====== //(defn interleave "Returns a lazy seq of the first item in each coll, then the second\n etc." [& colls] (apply concat (apply map list colls))) //--- (function __clojure_core_fn_2734(){ return (clojure.JS.def(clojure.core,"interleave",clojure.JS.variadic(0,(function __clojure_core_fn_2734_interleave_2736(){ var colls_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[clojure.core.concat,clojure.core.apply.apply(null,[clojure.core.map,clojure.core.list,colls_1])]))}))))}).apply(null,[]); //====== //(defn var-get "Gets the value in the var object" [x] (. x (get))) //--- (function __clojure_core_fn_2740(){ return (clojure.JS.def(clojure.core,"var_get",(function __clojure_core_fn_2740_var_get_2742(x_1){ return ((x_1).get())})))}).apply(null,[]); //====== //(defn var-set "Sets the value in the var object to val. The var must be\n thread-locally bound." [x val] (. x (set val))) //--- (function __clojure_core_fn_2746(){ return (clojure.JS.def(clojure.core,"var_set",(function __clojure_core_fn_2746_var_set_2748(x_1,val_2){ return ((x_1).set(val_2))})))}).apply(null,[]); // Skipping: (defmacro with-local-vars "varbinding=> symbol init-expr\n\n Executes the exprs in a context in which the symbols are bound to\n vars with per-thread bindings to the init-exprs. The symbols refer\n to the var objects themselves, and must be accessed with var-get and\n var-set" [name-vals-vec & body] (assert-args with-local-vars (vector? name-vals-vec) "a vector for its binding" (even? (count name-vals-vec)) "an even number of forms in binding vector") (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (interleave (take-nth 2 name-vals-vec) (repeat (quote (. clojure.lang.Var (create)))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Var)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/pushThreadBindings)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/hash-map)) name-vals-vec)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote try)) body (clojure.core/list (clojure.core/concat (clojure.core/list (quote finally)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Var)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/popThreadBindings)))))))))))) // Skipping: (defn ns-resolve "Returns the var or Class to which a symbol will be resolved in the\n namespace, else nil. Note that if the symbol is fully qualified,\n the var/Class to which it resolves need not be present in the\n namespace." [ns sym] (clojure.lang.Compiler/maybeResolveIn (the-ns ns) sym)) // Skipping: (defn resolve "same as (ns-resolve *ns* symbol)" [sym] (ns-resolve *ns* sym)) //====== //(defn array-map "Constructs an array-map." ([] (. clojure.lang.PersistentArrayMap EMPTY)) ([& keyvals] (new clojure.lang.PersistentArrayMap (to-array keyvals)))) //--- (function __clojure_core_fn_2773(){ return (clojure.JS.def(clojure.core,"array_map",clojure.JS.variadic(0,(function __clojure_core_fn_2773_array_map_2775(){switch(arguments.length){ case 0:return (clojure.JS.getOrRun(clojure.lang.PersistentArrayMap,"EMPTY"))} var keyvals_1=clojure.JS.rest_args(this,arguments,0); return ((new clojure.lang.PersistentArrayMap(clojure.core.to_array.apply(null,[keyvals_1]))))}))))}).apply(null,[]); //====== //(defn nthrest "Returns the nth rest of coll, (seq coll) when n is 0." [coll n] (loop [n n xs (seq coll)] (if (and xs (pos? n)) (recur (dec n) (rest xs)) xs))) //--- (function __clojure_core_fn_2780(){ return (clojure.JS.def(clojure.core,"nthrest",(function __clojure_core_fn_2780_nthrest_2782(coll_1,n_2){ var n_3,xs_4,and__948__auto___5; return (((function __loop(){var _rtn,_cnt;(n_3=n_2), (xs_4=clojure.core.seq.apply(null,[coll_1]));do{_cnt=0; _rtn=((((and__948__auto___5=xs_4), ((and__948__auto___5)?(clojure.lang.Numbers.isPos(n_3)):(and__948__auto___5))))?((_cnt=1,_rtn=[clojure.lang.Numbers.dec(n_3),clojure.core.rest.apply(null,[xs_4])],n_3=_rtn[0],xs_4=_rtn[1])):(xs_4))}while(_cnt);return _rtn;})()))})))}).apply(null,[]); //====== //(defn destructure [bindings] (let [bmap (apply array-map bindings) pb (fn pb [bvec b v] (let [pvec (fn [bvec b val] (let [gvec (gensym "vec__")] (loop [ret (-> bvec (conj gvec) (conj val)) n 0 bs b seen-rest? false] (if (seq bs) (let [firstb (first bs)] (cond (= firstb (quote &)) (recur (pb ret (second bs) (list (quote clojure.core/nthrest) gvec n)) n (rrest bs) true) (= firstb :as) (pb ret (second bs) gvec) :else (if seen-rest? (throw (RT/makeException "Unsupported binding form, only :as can follow & parameter")) (recur (pb ret firstb (list (quote clojure.core/nth) gvec n nil)) (inc n) (rest bs) seen-rest?)))) ret)))) pmap (fn [bvec b v] (let [gmap (or (:as b) (gensym "map__")) defaults (:or b)] (loop [ret (-> bvec (conj gmap) (conj v)) bes (reduce (fn [bes entry] (reduce (fn* [p1__2786 p2__2787] (assoc p1__2786 p2__2787 ((val entry) p2__2787))) (dissoc bes (key entry)) ((key entry) bes))) (dissoc b :as :or) {:keys (fn* [p1__2788] (keyword (str p1__2788))), :strs str, :syms (fn* [p1__2789] (list (quote quote) p1__2789))})] (if (seq bes) (let [bb (key (first bes)) bk (val (first bes)) has-default (contains? defaults bb)] (recur (pb ret bb (if has-default (list (quote clojure.core/get) gmap bk (defaults bb)) (list (quote clojure.core/get) gmap bk))) (rest bes))) ret))))] (cond (symbol? b) (-> bvec (conj b) (conj v)) (vector? b) (pvec bvec b v) (map? b) (pmap bvec b v) :else (throw (RT/makeException (str "Unsupported binding form: " b)))))) process-entry (fn [bvec b] (pb bvec (key b) (val b)))] (if (every? symbol? (keys bmap)) bindings (reduce process-entry [] bmap)))) //--- (function __clojure_core_fn_2790(){ return (clojure.JS.def(clojure.core,"destructure",(function __clojure_core_fn_2790_destructure_2792(bindings_1){ var bmap_2,pb_3,process_entry_4; return (((bmap_2=clojure.core.apply.apply(null,[clojure.core.array_map,bindings_1])), (pb_3=(function __clojure_core_fn_2790_destructure_2792_pb_2794(bvec_1,b_2,v_3){ var pvec_4,pmap_5,pb_0=arguments.callee; return (((pvec_4=(function __clojure_core_fn_2790_destructure_2792_pb_2794_pvec_2795(bvec_1,b_2,val_3){ var seen_rest_QMARK__8,firstb_9,gvec_4,n_6,bs_7,ret_5; return (((gvec_4=clojure.core.gensym.apply(null,["vec__"])), ((function __loop(){var _rtn,_cnt;(ret_5=clojure.core.conj.apply(null,[clojure.core.conj.apply(null,[bvec_1,gvec_4]),val_3])), (n_6=(0)), (bs_7=b_2), (seen_rest_QMARK__8=false);do{_cnt=0; _rtn=((clojure.core.seq.apply(null,[bs_7]))?(((firstb_9=clojure.core.first.apply(null,[bs_7])), ((clojure.lang.Util.equiv(firstb_9,clojure.core.symbol("&")))?((_cnt=1,_rtn=[pb_0.apply(null,[ret_5,clojure.core.second.apply(null,[bs_7]),clojure.core.list.apply(null,[clojure.core.symbol("clojure.core/nthrest"),gvec_4,n_6])]),n_6,clojure.core.rrest.apply(null,[bs_7]),true],ret_5=_rtn[0],n_6=_rtn[1],bs_7=_rtn[2],seen_rest_QMARK__8=_rtn[3])):(((clojure.lang.Util.equiv(firstb_9,clojure.core.keyword("","as")))?(pb_0.apply(null,[ret_5,clojure.core.second.apply(null,[bs_7]),gvec_4])):(((clojure.core.keyword("","else"))?(((seen_rest_QMARK__8)?((function __throw(){throw clojure.lang.RT.makeException("Unsupported binding form, only :as can follow & parameter")})()):((_cnt=1,_rtn=[pb_0.apply(null,[ret_5,firstb_9,clojure.core.list.apply(null,[clojure.core.symbol("clojure.core/nth"),gvec_4,n_6,null])]),clojure.lang.Numbers.inc(n_6),clojure.core.rest.apply(null,[bs_7]),seen_rest_QMARK__8],ret_5=_rtn[0],n_6=_rtn[1],bs_7=_rtn[2],seen_rest_QMARK__8=_rtn[3])))):(null)))))))):(ret_5))}while(_cnt);return _rtn;})())))})), (pmap_5=(function __clojure_core_fn_2790_destructure_2792_pb_2794_pmap_2798(bvec_1,b_2,v_3){ var has_default_10,bes_7,or__962__auto___4,gmap_4,defaults_5,ret_6,bk_9,bb_8; return (((gmap_4=((or__962__auto___4=clojure.core.keyword("","as").apply(null,[b_2])), ((or__962__auto___4)?(or__962__auto___4):(clojure.core.gensym.apply(null,["map__"]))))), (defaults_5=clojure.core.keyword("","or").apply(null,[b_2])), ((function __loop(){var _rtn,_cnt;(ret_6=clojure.core.conj.apply(null,[clojure.core.conj.apply(null,[bvec_1,gmap_4]),v_3])), (bes_7=clojure.core.reduce.apply(null,[(function __clojure_core_fn_2790_destructure_2792_pb_2794_pmap_2798_fn_2800(bes_1,entry_2){ return (clojure.core.reduce.apply(null,[(function __clojure_core_fn_2790_destructure_2792_pb_2794_pmap_2798_fn_2800_fn_2802(p1__2786_1,p2__2787_2){ return (clojure.core.assoc.apply(null,[p1__2786_1,p2__2787_2,clojure.core.val.apply(null,[entry_2]).apply(null,[p2__2787_2])]))}),clojure.core.dissoc.apply(null,[bes_1,clojure.core.key.apply(null,[entry_2])]),clojure.core.key.apply(null,[entry_2]).apply(null,[bes_1])]))}),clojure.core.dissoc.apply(null,[b_2,clojure.core.keyword("","as"),clojure.core.keyword("","or")]),clojure.core.hash_map(clojure.core.keyword("","keys"),(function __clojure_core_fn_2790_destructure_2792_pb_2794_pmap_2798_fn_2806(p1__2788_1){ return (clojure.core.keyword.apply(null,[clojure.core.str.apply(null,[p1__2788_1])]))}),clojure.core.keyword("","strs"),clojure.core.str,clojure.core.keyword("","syms"),(function __clojure_core_fn_2790_destructure_2792_pb_2794_pmap_2798_fn_2809(p1__2789_1){ return (clojure.core.list.apply(null,[clojure.core.symbol("quote"),p1__2789_1]))}))]));do{_cnt=0; _rtn=((clojure.core.seq.apply(null,[bes_7]))?(((bb_8=clojure.core.key.apply(null,[clojure.core.first.apply(null,[bes_7])])), (bk_9=clojure.core.val.apply(null,[clojure.core.first.apply(null,[bes_7])])), (has_default_10=clojure.core.contains_QMARK_.apply(null,[defaults_5,bb_8])), (_cnt=1,_rtn=[pb_0.apply(null,[ret_6,bb_8,((has_default_10)?(clojure.core.list.apply(null,[clojure.core.symbol("clojure.core/get"),gmap_4,bk_9,defaults_5.apply(null,[bb_8])])):(clojure.core.list.apply(null,[clojure.core.symbol("clojure.core/get"),gmap_4,bk_9])))]),clojure.core.rest.apply(null,[bes_7])],ret_6=_rtn[0],bes_7=_rtn[1]))):(ret_6))}while(_cnt);return _rtn;})())))})), ((clojure.core.symbol_QMARK_.apply(null,[b_2]))?(clojure.core.conj.apply(null,[clojure.core.conj.apply(null,[bvec_1,b_2]),v_3])):(((clojure.core.vector_QMARK_.apply(null,[b_2]))?(pvec_4.apply(null,[bvec_1,b_2,v_3])):(((clojure.core.map_QMARK_.apply(null,[b_2]))?(pmap_5.apply(null,[bvec_1,b_2,v_3])):(((clojure.core.keyword("","else"))?((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["Unsupported binding form: ",b_2]))})()):(null))))))))))})), (process_entry_4=(function __clojure_core_fn_2790_destructure_2792_process_entry_2814(bvec_1,b_2){ return (pb_3.apply(null,[bvec_1,clojure.core.key.apply(null,[b_2]),clojure.core.val.apply(null,[b_2])]))})), ((clojure.core.every_QMARK_.apply(null,[clojure.core.symbol_QMARK_,clojure.core.keys.apply(null,[bmap_2])]))?(bindings_1):(clojure.core.reduce.apply(null,[process_entry_4,clojure.lang.PersistentVector.EMPTY,bmap_2])))))})))}).apply(null,[]); // Skipping: (defmacro let "Evaluates the exprs in a lexical context in which the symbols in\n the binding-forms are bound to their respective init-exprs or parts\n therein." [bindings & body] (assert-args let (vector? bindings) "a vector for its binding" (even? (count bindings)) "an even number of forms in binding vector") (clojure.core/concat (clojure.core/list (quote let*)) (clojure.core/list (destructure bindings)) body)) // Skipping: (defmacro fn "(fn name? [params* ] exprs*)\n (fn name? ([params* ] exprs*)+)\n\n params => positional-params* , or positional-params* & rest-param\n positional-param => binding-form\n rest-param => binding-form\n name => symbol\n\n Defines a function" [& sigs] (let [name (if (symbol? (first sigs)) (first sigs) nil) sigs (if name (rest sigs) sigs) sigs (if (vector? (first sigs)) (list sigs) sigs) psig (fn [sig] (let [[params & body] sig] (if (every? symbol? params) sig (loop [params params new-params [] lets []] (if params (if (symbol? (first params)) (recur (rest params) (conj new-params (first params)) lets) (let [gparam (gensym "p__")] (recur (rest params) (conj new-params gparam) (-> lets (conj (first params)) (conj gparam))))) (clojure.core/concat (clojure.core/list new-params) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list lets) body)))))))) new-sigs (map psig sigs)] (with-meta (if name (list* (quote fn*) name new-sigs) (cons (quote fn*) new-sigs)) *macro-meta*))) // Skipping: (defmacro loop "Evaluates the exprs in a lexical context in which the symbols in\n the binding-forms are bound to their respective init-exprs or parts\n therein. Acts as a recur target." [bindings & body] (assert-args loop (vector? bindings) "a vector for its binding" (even? (count bindings)) "an even number of forms in binding vector") (let [db (destructure bindings)] (if (= db bindings) (clojure.core/concat (clojure.core/list (quote loop*)) (clojure.core/list bindings) body) (let [vs (take-nth 2 (drop 1 bindings)) bs (take-nth 2 bindings) gs (map (fn [b] (if (symbol? b) b (gensym))) bs) bfs (reduce (fn [ret [b v g]] (if (symbol? b) (conj ret g v) (conj ret g v b g))) [] (map vector bs vs gs))] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list bfs) (clojure.core/list (clojure.core/concat (clojure.core/list (quote loop*)) (clojure.core/list (vec (interleave gs gs))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (vec (interleave bs gs))) body))))))))) // Skipping: (defmacro when-first "bindings => x xs\n\n Same as (when (seq xs) (let [x (first xs)] body))" [bindings & body] (assert-args when-first (vector? bindings) "a vector for its binding" (= 2 (count bindings)) "exactly 2 forms in binding vector") (let [[x xs] bindings] (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/seq)) (clojure.core/list xs))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list x) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/first)) (clojure.core/list xs)))))) body))))) // Skipping: (defmacro lazy-cat "Expands to code which yields a lazy sequence of the concatenation\n of the supplied colls. Each coll expr is not evaluated until it is\n needed." ([coll] (clojure.core/concat (clojure.core/list (quote clojure.core/seq)) (clojure.core/list coll))) ([coll & colls] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote iter__2881__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/fn)) (clojure.core/list (quote iter__2881__auto__)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote coll__2882__auto__))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/seq)) (clojure.core/list (quote coll__2882__auto__)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/lazy-cons)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/first)) (clojure.core/list (quote coll__2882__auto__)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote iter__2881__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/rest)) (clojure.core/list (quote coll__2882__auto__)))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/lazy-cat)) colls))))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote iter__2881__auto__)) (clojure.core/list coll)))))) // Skipping: (defmacro for "List comprehension. Takes a vector of one or more\n binding-form/collection-expr pairs, each followed by an optional filtering\n :when/:while expression (:when test or :while test), and yields a\n lazy sequence of evaluations of expr. Collections are iterated in a\n nested fashion, rightmost fastest, and nested coll-exprs can refer to\n bindings created in prior binding-forms.\n\n (take 100 (for [x (range 100000000) y (range 1000000) :while (< y x)] [x y]))" ([seq-exprs expr] (assert-args for (vector? seq-exprs) "a vector for its binding" (even? (count seq-exprs)) "an even number of forms in binding vector") (let [to-groups (fn [seq-exprs] (reduce (fn [groups [k v]] (if (keyword? k) (conj (pop groups) (assoc (peek groups) k v)) (conj groups {:bind k, :seq v}))) [] (partition 2 seq-exprs))) emit (fn emit [[group & [{next-seq :seq} :as more-groups]]] (let [giter (gensym "iter__") gxs (gensym "s__")] (clojure.core/concat (clojure.core/list (quote clojure.core/fn)) (clojure.core/list giter) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list gxs)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when-first)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (:bind group)) (clojure.core/list gxs)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (or (:while group) true)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (or (:when group) true)) (clojure.core/list (if more-groups (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote iterys__2894__auto__)) (clojure.core/list (emit more-groups)) (clojure.core/list (quote fs__2895__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote iterys__2894__auto__)) (clojure.core/list next-seq)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (quote fs__2895__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/lazy-cat)) (clojure.core/list (quote fs__2895__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list giter) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/rest)) (clojure.core/list gxs))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/rest)) (clojure.core/list gxs)))))))) (clojure.core/concat (clojure.core/list (quote clojure.core/lazy-cons)) (clojure.core/list expr) (clojure.core/list (clojure.core/concat (clojure.core/list giter) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/rest)) (clojure.core/list gxs)))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/rest)) (clojure.core/list gxs))))))))))))))] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote iter__2896__auto__)) (clojure.core/list (emit (to-groups seq-exprs)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote iter__2896__auto__)) (clojure.core/list (second seq-exprs)))))))) // Skipping: (defmacro comment "Ignores body, yields nil" [& body]) // Skipping: (defmacro with-out-str "Evaluates exprs in a context in which *out* is bound to a fresh\n StringWriter. Returns the string created by any nested printing\n calls." [& body] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote s__2945__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.lang.RT/makeStringWriter))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/binding)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote clojure.core/*out*)) (clojure.core/list (quote s__2945__auto__))))) body (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/str)) (clojure.core/list (quote s__2945__auto__)))))))) // Skipping: (defmacro with-in-str "Evaluates body in a context in which *in* is bound to a fresh\n StringReader initialized with the string s." [s & body] (clojure.core/concat (clojure.core/list (quote clojure.core/with-open)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote s__2955__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/->)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote java.io.StringReader.)) (clojure.core/list s))) (clojure.core/list (quote clojure.lang.LineNumberingPushbackReader.))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/binding)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote clojure.core/*in*)) (clojure.core/list (quote s__2955__auto__))))) body)))) //====== //(defn pr-str "pr to a string, returning it" {:tag String} [& xs] (with-out-str (apply pr xs))) //--- (function __clojure_core_fn_2965(){ return (clojure.JS.def(clojure.core,"pr_str",clojure.JS.variadic(0,(function __clojure_core_fn_2965_pr_str_2967(){ var s__2945__auto___2,xs_1=clojure.JS.rest_args(this,arguments,0); return (((s__2945__auto___2=clojure.lang.RT.makeStringWriter()), clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_out_STAR_,s__2945__auto___2])), (function __try(){try{var _rtn=(clojure.core.apply.apply(null,[clojure.core.pr,xs_1]), clojure.core.str.apply(null,[s__2945__auto___2]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})()))}))))}).apply(null,[]); //====== //(defn prn-str "prn to a string, returning it" {:tag String} [& xs] (with-out-str (apply prn xs))) //--- (function __clojure_core_fn_2971(){ return (clojure.JS.def(clojure.core,"prn_str",clojure.JS.variadic(0,(function __clojure_core_fn_2971_prn_str_2973(){ var s__2945__auto___2,xs_1=clojure.JS.rest_args(this,arguments,0); return (((s__2945__auto___2=clojure.lang.RT.makeStringWriter()), clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_out_STAR_,s__2945__auto___2])), (function __try(){try{var _rtn=(clojure.core.apply.apply(null,[clojure.core.prn,xs_1]), clojure.core.str.apply(null,[s__2945__auto___2]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})()))}))))}).apply(null,[]); //====== //(defn print-str "print to a string, returning it" {:tag String} [& xs] (with-out-str (apply print xs))) //--- (function __clojure_core_fn_2977(){ return (clojure.JS.def(clojure.core,"print_str",clojure.JS.variadic(0,(function __clojure_core_fn_2977_print_str_2979(){ var s__2945__auto___2,xs_1=clojure.JS.rest_args(this,arguments,0); return (((s__2945__auto___2=clojure.lang.RT.makeStringWriter()), clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_out_STAR_,s__2945__auto___2])), (function __try(){try{var _rtn=(clojure.core.apply.apply(null,[clojure.core.print,xs_1]), clojure.core.str.apply(null,[s__2945__auto___2]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})()))}))))}).apply(null,[]); //====== //(defn println-str "println to a string, returning it" {:tag String} [& xs] (with-out-str (apply println xs))) //--- (function __clojure_core_fn_2983(){ return (clojure.JS.def(clojure.core,"println_str",clojure.JS.variadic(0,(function __clojure_core_fn_2983_println_str_2985(){ var s__2945__auto___2,xs_1=clojure.JS.rest_args(this,arguments,0); return (((s__2945__auto___2=clojure.lang.RT.makeStringWriter()), clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_out_STAR_,s__2945__auto___2])), (function __try(){try{var _rtn=(clojure.core.apply.apply(null,[clojure.core.println,xs_1]), clojure.core.str.apply(null,[s__2945__auto___2]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})()))}))))}).apply(null,[]); // Skipping: (defmacro assert "Evaluates expr and throws an exception if it does not evaluate to\n logical true." [x] (clojure.core/concat (clojure.core/list (quote clojure.core/when-not)) (clojure.core/list x) (clojure.core/list (clojure.core/concat (clojure.core/list (quote throw)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.lang.RT/makeException)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/str)) (clojure.core/list "Assert failed: ") (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/pr-str)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list x))))))))))))) //====== //(defn test "test [v] finds fn at key :test in var metadata and calls it,\n presuming failure will throw exception" [v] (let [f (:test (clojure.core/meta v))] (if f (do (f) :ok) :no-test))) //--- (function __clojure_core_fn_2998(){ return (clojure.JS.def(clojure.core,"test",(function __clojure_core_fn_2998_test_3000(v_1){ var f_2; return (((f_2=clojure.core.keyword("","test").apply(null,[clojure.core.meta.apply(null,[v_1])])), ((f_2)?(f_2.apply(null,[]), clojure.core.keyword("","ok")):(clojure.core.keyword("","no-test")))))})))}).apply(null,[]); // Skipping: (defn re-pattern "Returns an instance of java.util.regex.Pattern, for use, e.g. in\n re-matcher." {:tag java.util.regex.Pattern} [s] (if (instance? java.util.regex.Pattern s) s (. java.util.regex.Pattern (compile s)))) // Skipping: (defn re-matcher "Returns an instance of java.util.regex.Matcher, for use, e.g. in\n re-find." {:tag java.util.regex.Matcher} [re s] (. re (matcher s))) // Skipping: (defn re-groups "Returns the groups from the most recent match/find. If there are no\n nested groups, returns a string of the entire match. If there are\n nested groups, returns a vector of the groups, the first element\n being the entire match." [m] (let [gc (. m (groupCount))] (if (zero? gc) (. m (group)) (loop [ret [] c 0] (if (<= c gc) (recur (conj ret (. m (group c))) (inc c)) ret))))) // Skipping: (defn re-seq "Returns a lazy sequence of successive matches of pattern in string,\n using java.util.regex.Matcher.find(), each such match processed with\n re-groups." [re s] (let [m (re-matcher re s)] ((fn step [] (when (. m (find)) (lazy-cons (re-groups m) (step))))))) // Skipping: (defn re-matches "Returns the match, if any, of string to pattern, using\n java.util.regex.Matcher.matches(). Uses re-groups to return the\n groups." [re s] (let [m (re-matcher re s)] (when (. m (matches)) (re-groups m)))) // Skipping: (defn re-find "Returns the next regex match, if any, of string to pattern, using\n java.util.regex.Matcher.find(). Uses re-groups to return the\n groups." ([m] (when (. m (find)) (re-groups m))) ([re s] (let [m (re-matcher re s)] (re-find m)))) //====== //(defn rand "Returns a random floating point number between 0 (inclusive) and\n 1 (exclusive)." ([] (RT/random)) ([n] (* n (rand)))) //--- (function __clojure_core_fn_3048(){ return (clojure.JS.def(clojure.core,"rand",(function __clojure_core_fn_3048_rand_3050(n_1){switch(arguments.length){ case 0:return (clojure.lang.RT.random())} return (clojure.lang.Numbers.multiply(n_1,clojure.core.rand.apply(null,[])))})))}).apply(null,[]); //====== //(defn rand-int "Returns a random integer between 0 (inclusive) and n (exclusive)." [n] (int (rand n))) //--- (function __clojure_core_fn_3055(){ return (clojure.JS.def(clojure.core,"rand_int",(function __clojure_core_fn_3055_rand_int_3057(n_1){ return (clojure.lang.RT.intCast(clojure.core.rand.apply(null,[n_1])))})))}).apply(null,[]); // Skipping: (defmacro defn- "same as defn, yielding non-public def" [name & decls] (list* (quote clojure.core/defn) (with-meta name (assoc (meta name) :private true)) decls)) //====== //(defn print-doc [v] (println "-------------------------") (println (str (ns-name (:ns (clojure.core/meta v))) "/" (:name (clojure.core/meta v)))) (prn (:arglists (clojure.core/meta v))) (when (:macro (clojure.core/meta v)) (println "Macro")) (println " " (:doc (clojure.core/meta v)))) //--- (function __clojure_core_fn_3070(){ return (clojure.JS.def(clojure.core,"print_doc",(function __clojure_core_fn_3070_print_doc_3072(v_1){ return (clojure.core.println.apply(null,["-------------------------"]), clojure.core.println.apply(null,[clojure.core.str.apply(null,[clojure.core.ns_name.apply(null,[clojure.core.keyword("","ns").apply(null,[clojure.core.meta.apply(null,[v_1])])]),"/",clojure.core.keyword("","name").apply(null,[clojure.core.meta.apply(null,[v_1])])])]), clojure.core.prn.apply(null,[clojure.core.keyword("","arglists").apply(null,[clojure.core.meta.apply(null,[v_1])])]), ((clojure.core.keyword("","macro").apply(null,[clojure.core.meta.apply(null,[v_1])]))?(clojure.core.println.apply(null,["Macro"])):(null)), clojure.core.println.apply(null,[" ",clojure.core.keyword("","doc").apply(null,[clojure.core.meta.apply(null,[v_1])])]))})))}).apply(null,[]); //====== //(defn find-doc "Prints documentation for any var whose documentation or name\n contains a match for re-string-or-pattern" [re-string-or-pattern] (let [re (re-pattern re-string-or-pattern)] (dorun (for [ns (all-ns) v (sort-by (comp :name meta) (vals (ns-interns ns))) :when (and (:doc (clojure.core/meta v)) (or (re-find (re-matcher re (:doc (clojure.core/meta v)))) (re-find (re-matcher re (str (:name (clojure.core/meta v)))))))] (print-doc v))))) //--- (function __clojure_core_fn_3076(){ return (clojure.JS.def(clojure.core,"find_doc",(function __clojure_core_fn_3076_find_doc_3078(re_string_or_pattern_1){ var re_2,iter__2896__auto___3; return (((re_2=clojure.core.re_pattern.apply(null,[re_string_or_pattern_1])), clojure.core.dorun.apply(null,[((iter__2896__auto___3=(function __clojure_core_fn_3076_find_doc_3078_iter_3080_3084(s__3081_1){ var _cnt,_rtn,ns_2,iterys__2894__auto___3,fs__2895__auto___4,iter__2881__auto___5,iter__3080_0=arguments.callee; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[s__3081_1]))?(((ns_2=clojure.core.first.apply(null,[s__3081_1])), ((true)?(((true)?(((iterys__2894__auto___3=(function __clojure_core_fn_3076_find_doc_3078_iter_3080_3084_iter_3082_3085(s__3083_1){ var _cnt,_rtn,v_2,and__948__auto___3,or__962__auto___4,iter__3082_0=arguments.callee; do{_cnt=0;_rtn=((clojure.core.seq.apply(null,[s__3083_1]))?(((v_2=clojure.core.first.apply(null,[s__3083_1])), ((true)?(((((and__948__auto___3=clojure.core.keyword("","doc").apply(null,[clojure.core.meta.apply(null,[v_2])])), ((and__948__auto___3)?(((or__962__auto___4=clojure.core.re_find.apply(null,[clojure.core.re_matcher.apply(null,[re_2,clojure.core.keyword("","doc").apply(null,[clojure.core.meta.apply(null,[v_2])])])])), ((or__962__auto___4)?(or__962__auto___4):(clojure.core.re_find.apply(null,[clojure.core.re_matcher.apply(null,[re_2,clojure.core.str.apply(null,[clojure.core.keyword("","name").apply(null,[clojure.core.meta.apply(null,[v_2])])])])]))))):(and__948__auto___3))))?((new clojure.lang.LazyCons((function __clojure_core_fn_3076_find_doc_3078_iter_3080_3084_iter_3082_3085_fn_3087(G__3086_1){switch(arguments.length){ case 0:return (clojure.core.print_doc.apply(null,[v_2]))} return (iter__3082_0.apply(null,[clojure.core.rest.apply(null,[s__3083_1])]))})))):((_cnt=1,_rtn=[clojure.core.rest.apply(null,[s__3083_1])],s__3083_1=_rtn[0])))):(null)))):(null)) }while(_cnt);return _rtn;})), (fs__2895__auto___4=iterys__2894__auto___3.apply(null,[clojure.core.sort_by.apply(null,[clojure.core.comp.apply(null,[clojure.core.keyword("","name"),clojure.core.meta]),clojure.core.vals.apply(null,[clojure.core.ns_interns.apply(null,[ns_2])])])])), ((fs__2895__auto___4)?(((iter__2881__auto___5=(function __clojure_core_fn_3076_find_doc_3078_iter_3080_3084_iter_2881_auto_3092(coll__2882__auto___1){ var iter__2881__auto___0=arguments.callee; return (((clojure.core.seq.apply(null,[coll__2882__auto___1]))?((new clojure.lang.LazyCons((function __clojure_core_fn_3076_find_doc_3078_iter_3080_3084_iter_2881_auto_3092_fn_3094(G__3093_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll__2882__auto___1]))} return (iter__2881__auto___0.apply(null,[clojure.core.rest.apply(null,[coll__2882__auto___1])]))})))):(clojure.core.seq.apply(null,[iter__3080_0.apply(null,[clojure.core.rest.apply(null,[s__3081_1])])]))))})), iter__2881__auto___5.apply(null,[fs__2895__auto___4]))):((_cnt=1,_rtn=[clojure.core.rest.apply(null,[s__3081_1])],s__3081_1=_rtn[0]))))):((_cnt=1,_rtn=[clojure.core.rest.apply(null,[s__3081_1])],s__3081_1=_rtn[0])))):(null)))):(null)) }while(_cnt);return _rtn;})), iter__2896__auto___3.apply(null,[clojure.core.all_ns.apply(null,[])]))])))})))}).apply(null,[]); //====== //(defn special-form-anchor "Returns the anchor tag on http://clojure.org/special_forms for the\n special form x, or nil" [x] (#{(quote fn) (quote quote) (quote let) (quote var) (quote loop) (quote set!) (quote monitor-enter) (quote recur) (quote .) (quote do) (quote throw) (quote monitor-exit) (quote try) (quote if) (quote def) (quote new)} x)) //--- (function __clojure_core_fn_3102(){ return (clojure.JS.def(clojure.core,"special_form_anchor",(function __clojure_core_fn_3102_special_form_anchor_3104(x_1){ return (clojure.core.hash_set(clojure.core.symbol("fn"),clojure.core.symbol("quote"),clojure.core.symbol("let"),clojure.core.symbol("var"),clojure.core.symbol("loop"),clojure.core.symbol("set!"),clojure.core.symbol("monitor-enter"),clojure.core.symbol("recur"),clojure.core.symbol("."),clojure.core.symbol("do"),clojure.core.symbol("throw"),clojure.core.symbol("monitor-exit"),clojure.core.symbol("try"),clojure.core.symbol("if"),clojure.core.symbol("def"),clojure.core.symbol("new")).apply(null,[x_1]))})))}).apply(null,[]); //====== //(defn syntax-symbol-anchor "Returns the anchor tag on http://clojure.org/special_forms for the\n special form that uses syntax symbol x, or nil" [x] ({(quote &) (quote fn), (quote catch) (quote try), (quote finally) (quote try)} x)) //--- (function __clojure_core_fn_3108(){ return (clojure.JS.def(clojure.core,"syntax_symbol_anchor",(function __clojure_core_fn_3108_syntax_symbol_anchor_3110(x_1){ return (clojure.core.hash_map(clojure.core.symbol("&"),clojure.core.symbol("fn"),clojure.core.symbol("catch"),clojure.core.symbol("try"),clojure.core.symbol("finally"),clojure.core.symbol("try")).apply(null,[x_1]))})))}).apply(null,[]); //====== //(defn print-special-doc [name type anchor] (println "-------------------------") (println name) (println type) (println (str " Please see http://clojure.org/special_forms#" anchor))) //--- (function __clojure_core_fn_3114(){ return (clojure.JS.def(clojure.core,"print_special_doc",(function __clojure_core_fn_3114_print_special_doc_3116(name_1,type_2,anchor_3){ return (clojure.core.println.apply(null,["-------------------------"]), clojure.core.println.apply(null,[name_1]), clojure.core.println.apply(null,[type_2]), clojure.core.println.apply(null,[clojure.core.str.apply(null,[" Please see http://clojure.org/special_forms#",anchor_3])]))})))}).apply(null,[]); // Skipping: (defmacro doc "Prints documentation for a var or special form given its name" [name] (cond (special-form-anchor name) (clojure.core/concat (clojure.core/list (quote clojure.core/print-special-doc)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list name))) (clojure.core/list "Special Form") (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/special-form-anchor)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list name)))))) (syntax-symbol-anchor name) (clojure.core/concat (clojure.core/list (quote clojure.core/print-special-doc)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list name))) (clojure.core/list "Syntax Symbol") (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/syntax-symbol-anchor)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list name)))))) :else (clojure.core/concat (clojure.core/list (quote clojure.core/print-doc)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote var)) (clojure.core/list name)))))) //====== //(defn tree-seq "returns a lazy sequence of the nodes in a tree, via a depth-first walk.\n branch? must be a fn of one arg that returns true if passed a node\n that can have children (but may not). children must be a fn of one\n arg that returns a sequence of the children. Will only be called on\n nodes for which branch? returns true. Root is the root node of the\n tree, must be a branch." [branch? children root] (let [walk (fn walk [nodes] (when-first [node nodes] (lazy-cons node (if (branch? node) (lazy-cat (walk (children node)) (walk (rest nodes))) (walk (rest nodes))))))] (lazy-cons root (walk (children root))))) //--- (function __clojure_core_fn_3129(){ return (clojure.JS.def(clojure.core,"tree_seq",(function __clojure_core_fn_3129_tree_seq_3131(branch_QMARK__1,children_2,root_3){ var walk_4; return (((walk_4=(function __clojure_core_fn_3129_tree_seq_3131_walk_3133(nodes_1){ var node_2,walk_0=arguments.callee; return (((clojure.core.seq.apply(null,[nodes_1]))?(((node_2=clojure.core.first.apply(null,[nodes_1])), (new clojure.lang.LazyCons((function __clojure_core_fn_3129_tree_seq_3131_walk_3133_fn_3135(G__3134_1){switch(arguments.length){ case 0:return (node_2)} var iter__2881__auto___2; return (((branch_QMARK__1.apply(null,[node_2]))?(((iter__2881__auto___2=(function __clojure_core_fn_3129_tree_seq_3131_walk_3133_fn_3135_iter_2881_auto_3138(coll__2882__auto___1){ var iter__2881__auto___0=arguments.callee; return (((clojure.core.seq.apply(null,[coll__2882__auto___1]))?((new clojure.lang.LazyCons((function __clojure_core_fn_3129_tree_seq_3131_walk_3133_fn_3135_iter_2881_auto_3138_fn_3140(G__3139_1){switch(arguments.length){ case 0:return (clojure.core.first.apply(null,[coll__2882__auto___1]))} return (iter__2881__auto___0.apply(null,[clojure.core.rest.apply(null,[coll__2882__auto___1])]))})))):(clojure.core.seq.apply(null,[walk_0.apply(null,[clojure.core.rest.apply(null,[nodes_1])])]))))})), iter__2881__auto___2.apply(null,[walk_0.apply(null,[children_2.apply(null,[node_2])])]))):(walk_0.apply(null,[clojure.core.rest.apply(null,[nodes_1])]))))}))))):(null)))})), (new clojure.lang.LazyCons((function __clojure_core_fn_3129_tree_seq_3131_fn_3148(G__3147_1){switch(arguments.length){ case 0:return (root_3)} return (walk_4.apply(null,[children_2.apply(null,[root_3])]))})))))})))}).apply(null,[]); //====== //(defn file-seq "A tree seq on java.io.Files" [dir] (tree-seq (fn [f] (. f (isDirectory))) (fn [d] (seq (. d (listFiles)))) dir)) //--- (function __clojure_core_fn_3154(){ return (clojure.JS.def(clojure.core,"file_seq",(function __clojure_core_fn_3154_file_seq_3156(dir_1){ return (clojure.core.tree_seq.apply(null,[(function __clojure_core_fn_3154_file_seq_3156_fn_3158(f_1){ return ((f_1).isDirectory())}),(function __clojure_core_fn_3154_file_seq_3156_fn_3161(d_1){ return (clojure.core.seq.apply(null,[(d_1).listFiles()]))}),dir_1]))})))}).apply(null,[]); //====== //(defn xml-seq "A tree seq on the xml elements as per xml/parse" [root] (tree-seq (complement string?) (comp seq :content) root)) //--- (function __clojure_core_fn_3166(){ return (clojure.JS.def(clojure.core,"xml_seq",(function __clojure_core_fn_3166_xml_seq_3168(root_1){ return (clojure.core.tree_seq.apply(null,[clojure.core.complement.apply(null,[clojure.core.string_QMARK_]),clojure.core.comp.apply(null,[clojure.core.seq,clojure.core.keyword("","content")]),root_1]))})))}).apply(null,[]); // Skipping: (defn special-symbol? "Returns true if s names a special form" [s] (contains? (. clojure.lang.Compiler specials) s)) //====== //(defn var? "Returns true if v is of type clojure.lang.Var" [v] (instance? clojure.lang.Var v)) //--- (function __clojure_core_fn_3178(){ return (clojure.JS.def(clojure.core,"var_QMARK_",(function __clojure_core_fn_3178_var_QMARK_3180(v_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Var,v_1]))})))}).apply(null,[]); // Skipping: (defn slurp "Reads the file named by f into a string and returns it." [f] (with-open [r (new java.io.BufferedReader (new java.io.FileReader f))] (let [sb (RT/makeStringBuilder)] (loop [c (. r (read))] (if (neg? c) (str sb) (do (. sb (append (char c))) (recur (. r (read))))))))) //====== //(defn subs "Returns the substring of s beginning at start inclusive, and ending\n at end (defaults to length of string), exclusive." ([s start] (. s (substring start))) ([s start end] (. s (substring start end)))) //--- (function __clojure_core_fn_3190(){ return (clojure.JS.def(clojure.core,"subs",(function __clojure_core_fn_3190_subs_3192(s_1,start_2,end_3){switch(arguments.length){ case 2:return ((s_1).substring(start_2))} return ((s_1).substring(start_2,end_3))})))}).apply(null,[]); //====== //(defn max-key "Returns the x for which (k x), a number, is greatest." ([k x] x) ([k x y] (if (> (k x) (k y)) x y)) ([k x y & more] (reduce (fn* [p1__3197 p2__3198] (max-key k p1__3197 p2__3198)) (max-key k x y) more))) //--- (function __clojure_core_fn_3199(){ return (clojure.JS.def(clojure.core,"max_key",clojure.JS.variadic(3,(function __clojure_core_fn_3199_max_key_3201(k_1,x_2,y_3){switch(arguments.length){ case 2:return (x_2) case 3:return (((clojure.lang.Numbers.gt(k_1.apply(null,[x_2]),k_1.apply(null,[y_3])))?(x_2):(y_3)))} var more_4=clojure.JS.rest_args(this,arguments,3); return (clojure.core.reduce.apply(null,[(function __clojure_core_fn_3199_max_key_3201_fn_3205(p1__3197_1,p2__3198_2){ return (clojure.core.max_key.apply(null,[k_1,p1__3197_1,p2__3198_2]))}),clojure.core.max_key.apply(null,[k_1,x_2,y_3]),more_4]))}))))}).apply(null,[]); //====== //(defn min-key "Returns the x for which (k x), a number, is least." ([k x] x) ([k x y] (if (< (k x) (k y)) x y)) ([k x y & more] (reduce (fn* [p1__3210 p2__3211] (min-key k p1__3210 p2__3211)) (min-key k x y) more))) //--- (function __clojure_core_fn_3212(){ return (clojure.JS.def(clojure.core,"min_key",clojure.JS.variadic(3,(function __clojure_core_fn_3212_min_key_3214(k_1,x_2,y_3){switch(arguments.length){ case 2:return (x_2) case 3:return (((clojure.lang.Numbers.lt(k_1.apply(null,[x_2]),k_1.apply(null,[y_3])))?(x_2):(y_3)))} var more_4=clojure.JS.rest_args(this,arguments,3); return (clojure.core.reduce.apply(null,[(function __clojure_core_fn_3212_min_key_3214_fn_3218(p1__3210_1,p2__3211_2){ return (clojure.core.min_key.apply(null,[k_1,p1__3210_1,p2__3211_2]))}),clojure.core.min_key.apply(null,[k_1,x_2,y_3]),more_4]))}))))}).apply(null,[]); //====== //(defn distinct "Returns a lazy sequence of the elements of coll with duplicates removed" [coll] (let [step (fn step [[f & r :as xs] seen] (when xs (if (seen f) (recur r seen) (lazy-cons f (step r (conj seen f))))))] (step (seq coll) #{}))) //--- (function __clojure_core_fn_3223(){ return (clojure.JS.def(clojure.core,"distinct",(function __clojure_core_fn_3223_distinct_3225(coll_1){ var step_2; return (((step_2=(function __clojure_core_fn_3223_distinct_3225_step_3228(p__3227_1,seen_2){ var _cnt,_rtn,vec__3229_3,f_4,r_5,xs_6,step_0=arguments.callee; do{_cnt=0;_rtn=((vec__3229_3=p__3227_1), (f_4=clojure.core.nth.apply(null,[vec__3229_3,(0),null])), (r_5=clojure.core.nthrest.apply(null,[vec__3229_3,(1)])), (xs_6=vec__3229_3), ((xs_6)?(((seen_2.apply(null,[f_4]))?((_cnt=1,_rtn=[r_5,seen_2],p__3227_1=_rtn[0],seen_2=_rtn[1])):((new clojure.lang.LazyCons((function __clojure_core_fn_3223_distinct_3225_step_3228_fn_3231(G__3230_1){switch(arguments.length){ case 0:return (f_4)} return (step_0.apply(null,[r_5,clojure.core.conj.apply(null,[seen_2,f_4])]))})))))):(null))) }while(_cnt);return _rtn;})), step_2.apply(null,[clojure.core.seq.apply(null,[coll_1]),clojure.lang.PersistentHashSet.EMPTY])))})))}).apply(null,[]); // Skipping: (defmacro if-let "bindings => binding-form test\n\n If test is true, evaluates then with binding-form bound to the value of test, if not, yields else" ([bindings then] (clojure.core/concat (clojure.core/list (quote clojure.core/if-let)) (clojure.core/list bindings) (clojure.core/list then) (clojure.core/list (quote nil)))) ([bindings then else & oldform] (assert-args if-let (and (vector? bindings) (nil? oldform)) "a vector for its binding" (= 2 (count bindings)) "exactly 2 forms in binding vector") (let [[form tst] bindings] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote temp__3238__auto__)) (clojure.core/list tst)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (quote temp__3238__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list form) (clojure.core/list (quote temp__3238__auto__))))) (clojure.core/list then))) (clojure.core/list else))))))) // Skipping: (defmacro when-let "bindings => binding-form test\n\n When test is true, evaluates body with binding-form bound to the value of test" [bindings & body] (assert-args when-let (vector? bindings) "a vector for its binding" (= 2 (count bindings)) "exactly 2 forms in binding vector") (let [[form tst] bindings] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote temp__3253__auto__)) (clojure.core/list tst)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list (quote temp__3253__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list form) (clojure.core/list (quote temp__3253__auto__))))) body))))))) //====== //(defn replace "Given a map of replacement pairs and a vector/collection, returns a\n vector/seq with any elements = a key in smap replaced with the\n corresponding val in smap" [smap coll] (if (vector? coll) (reduce (fn [v i] (if-let [e (find smap (nth v i))] (assoc v i (val e)) v)) coll (range (count coll))) (map (fn* [p1__3265] (if-let [e (find smap p1__3265)] (val e) p1__3265)) coll))) //--- (function __clojure_core_fn_3266(){ return (clojure.JS.def(clojure.core,"replace",(function __clojure_core_fn_3266_replace_3268(smap_1,coll_2){ return (((clojure.core.vector_QMARK_.apply(null,[coll_2]))?(clojure.core.reduce.apply(null,[(function __clojure_core_fn_3266_replace_3268_fn_3270(v_1,i_2){ var temp__3238__auto___3,e_4; return (((temp__3238__auto___3=clojure.core.find.apply(null,[smap_1,clojure.core.nth.apply(null,[v_1,i_2])])), ((temp__3238__auto___3)?(((e_4=temp__3238__auto___3), clojure.core.assoc.apply(null,[v_1,i_2,clojure.core.val.apply(null,[e_4])]))):(v_1))))}),coll_2,clojure.core.range.apply(null,[clojure.core.count.apply(null,[coll_2])])])):(clojure.core.map.apply(null,[(function __clojure_core_fn_3266_replace_3268_fn_3273(p1__3265_1){ var temp__3238__auto___2,e_3; return (((temp__3238__auto___2=clojure.core.find.apply(null,[smap_1,p1__3265_1])), ((temp__3238__auto___2)?(((e_3=temp__3238__auto___2), clojure.core.val.apply(null,[e_3]))):(p1__3265_1))))}),coll_2]))))})))}).apply(null,[]); // Skipping: (defmacro dosync "Runs the exprs (in an implicit do) in a transaction that encompasses\n exprs and any nested calls. Starts a transaction if none is already\n running on this thread. Any uncaught exception will abort the\n transaction and flow out of dosync. The exprs may be run more than\n once, but any effects on Refs will be atomic." [& exprs] (clojure.core/concat (clojure.core/list (quote clojure.core/sync)) (clojure.core/list (quote nil)) exprs)) // Skipping: (defmacro with-precision "Sets the precision and rounding mode to be used for BigDecimal operations.\n\n Usage: (with-precision 10 (/ 1M 3))\n or: (with-precision 10 :rounding HALF_DOWN (/ 1M 3))\n \n The rounding mode is one of CEILING, FLOOR, HALF_UP, HALF_DOWN,\n HALF_EVEN, UP, DOWN and UNNECESSARY; it defaults to HALF_UP." [precision & exprs] (let [[body rm] (if (= (first exprs) :rounding) [(rest (rest exprs)) (clojure.core/concat (clojure.core/list (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote java.math.RoundingMode)) (clojure.core/list (second exprs)))))] [exprs nil])] (clojure.core/concat (clojure.core/list (quote clojure.core/binding)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote clojure.core/*math-context*)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote java.math.MathContext.)) (clojure.core/list precision) rm))))) body))) //====== //(defn bound-fn {:private true} [sc test key] (fn [e] (test (.. sc comparator (compare (. sc entryKey e) key)) 0))) //--- (function __clojure_core_fn_3298(){ return (clojure.JS.def(clojure.core,"bound_fn",(function __clojure_core_fn_3298_bound_fn_3300(sc_1,test_2,key_3){ return ((function __clojure_core_fn_3298_bound_fn_3300_fn_3302(e_1){ return (test_2.apply(null,[((sc_1).comparator()).compare((sc_1).entryKey(e_1),key_3),(0)]))}))})))}).apply(null,[]); //====== //(defn subseq "sc must be a sorted collection, test(s) one of <, <=, > or\n >=. Returns a seq of those entries with keys ek for\n which (test (.. sc comparator (compare ek key)) 0) is true" ([sc test key] (let [include (bound-fn sc test key)] (if (#{> >=} test) (when-let [[e :as s] (. sc seqFrom key true)] (if (include e) s (rest s))) (take-while include (. sc seq true))))) ([sc start-test start-key end-test end-key] (when-let [[e :as s] (. sc seqFrom start-key true)] (take-while (bound-fn sc end-test end-key) (if ((bound-fn sc start-test start-key) e) s (rest s)))))) //--- (function __clojure_core_fn_3307(){ return (clojure.JS.def(clojure.core,"subseq",(function __clojure_core_fn_3307_subseq_3309(sc_1,start_test_2,start_key_3,end_test_4,end_key_5){switch(arguments.length){ case 3:var include_4,temp__3253__auto___5,vec__3311_6,e_7,s_8,test_2=arguments[1],key_3=arguments[2]; return (((include_4=clojure.core.bound_fn.apply(null,[sc_1,test_2,key_3])), ((clojure.core.hash_set(clojure.core._GT_,clojure.core._GT__EQ_).apply(null,[test_2]))?(((temp__3253__auto___5=(sc_1).seqFrom(key_3,true)), ((temp__3253__auto___5)?(((vec__3311_6=temp__3253__auto___5), (e_7=clojure.core.nth.apply(null,[vec__3311_6,(0),null])), (s_8=vec__3311_6), ((include_4.apply(null,[e_7]))?(s_8):(clojure.core.rest.apply(null,[s_8]))))):(null)))):(clojure.core.take_while.apply(null,[include_4,(sc_1).seq(true)])))))} var e_8,s_9,temp__3253__auto___6,vec__3313_7; return (((temp__3253__auto___6=(sc_1).seqFrom(start_key_3,true)), ((temp__3253__auto___6)?(((vec__3313_7=temp__3253__auto___6), (e_8=clojure.core.nth.apply(null,[vec__3313_7,(0),null])), (s_9=vec__3313_7), clojure.core.take_while.apply(null,[clojure.core.bound_fn.apply(null,[sc_1,end_test_4,end_key_5]),((clojure.core.bound_fn.apply(null,[sc_1,start_test_2,start_key_3]).apply(null,[e_8]))?(s_9):(clojure.core.rest.apply(null,[s_9])))]))):(null))))})))}).apply(null,[]); //====== //(defn rsubseq "sc must be a sorted collection, test(s) one of <, <=, > or\n >=. Returns a reverse seq of those entries with keys ek for\n which (test (.. sc comparator (compare ek key)) 0) is true" ([sc test key] (let [include (bound-fn sc test key)] (if (#{< <=} test) (when-let [[e :as s] (. sc seqFrom key false)] (if (include e) s (rest s))) (take-while include (. sc seq false))))) ([sc start-test start-key end-test end-key] (when-let [[e :as s] (. sc seqFrom end-key false)] (take-while (bound-fn sc start-test start-key) (if ((bound-fn sc end-test end-key) e) s (rest s)))))) //--- (function __clojure_core_fn_3316(){ return (clojure.JS.def(clojure.core,"rsubseq",(function __clojure_core_fn_3316_rsubseq_3318(sc_1,start_test_2,start_key_3,end_test_4,end_key_5){switch(arguments.length){ case 3:var include_4,temp__3253__auto___5,vec__3320_6,e_7,s_8,test_2=arguments[1],key_3=arguments[2]; return (((include_4=clojure.core.bound_fn.apply(null,[sc_1,test_2,key_3])), ((clojure.core.hash_set(clojure.core._LT_,clojure.core._LT__EQ_).apply(null,[test_2]))?(((temp__3253__auto___5=(sc_1).seqFrom(key_3,false)), ((temp__3253__auto___5)?(((vec__3320_6=temp__3253__auto___5), (e_7=clojure.core.nth.apply(null,[vec__3320_6,(0),null])), (s_8=vec__3320_6), ((include_4.apply(null,[e_7]))?(s_8):(clojure.core.rest.apply(null,[s_8]))))):(null)))):(clojure.core.take_while.apply(null,[include_4,(sc_1).seq(false)])))))} var vec__3322_7,temp__3253__auto___6,e_8,s_9; return (((temp__3253__auto___6=(sc_1).seqFrom(end_key_5,false)), ((temp__3253__auto___6)?(((vec__3322_7=temp__3253__auto___6), (e_8=clojure.core.nth.apply(null,[vec__3322_7,(0),null])), (s_9=vec__3322_7), clojure.core.take_while.apply(null,[clojure.core.bound_fn.apply(null,[sc_1,start_test_2,start_key_3]),((clojure.core.bound_fn.apply(null,[sc_1,end_test_4,end_key_5]).apply(null,[e_8]))?(s_9):(clojure.core.rest.apply(null,[s_9])))]))):(null))))})))}).apply(null,[]); //====== //(defn repeatedly "Takes a function of no args, presumably with side effects, and returns an infinite\n lazy sequence of calls to it" [f] (lazy-cons (f) (repeatedly f))) //--- (function __clojure_core_fn_3325(){ return (clojure.JS.def(clojure.core,"repeatedly",(function __clojure_core_fn_3325_repeatedly_3327(f_1){ return ((new clojure.lang.LazyCons((function __clojure_core_fn_3325_repeatedly_3327_fn_3330(G__3329_1){switch(arguments.length){ case 0:return (f_1.apply(null,[]))} return (clojure.core.repeatedly.apply(null,[f_1]))}))))})))}).apply(null,[]); //====== //(defn add-classpath "Adds the url (String or URL object) to the classpath per URLClassLoader.addURL" [url] (. clojure.lang.RT addURL url)) //--- (function __clojure_core_fn_3336(){ return (clojure.JS.def(clojure.core,"add_classpath",(function __clojure_core_fn_3336_add_classpath_3338(url_1){ return (clojure.lang.RT.addURL(url_1))})))}).apply(null,[]); //====== //(defn hash "Returns the hash code of its argument" [x] (. clojure.lang.Util (hash x))) //--- (function __clojure_core_fn_3342(){ return (clojure.JS.def(clojure.core,"hash",(function __clojure_core_fn_3342_hash_3344(x_1){ return (clojure.lang.Util.hash(x_1))})))}).apply(null,[]); //====== //(defn interpose "Returns a lazy seq of the elements of coll separated by sep" [sep coll] (drop 1 (interleave (repeat sep) coll))) //--- (function __clojure_core_fn_3348(){ return (clojure.JS.def(clojure.core,"interpose",(function __clojure_core_fn_3348_interpose_3350(sep_1,coll_2){ return (clojure.core.drop.apply(null,[(1),clojure.core.interleave.apply(null,[clojure.core.repeat.apply(null,[sep_1]),coll_2])]))})))}).apply(null,[]); // Skipping: (defmacro definline "Experimental - like defmacro, except defines a named function whose\n body is the expansion, calls to which may be expanded inline as if\n it were a macro. Cannot be used with variadic (&) args." [name & decl] (let [[args expr] (drop-while (comp not vector?) decl) inline (eval (list (quote clojure.core/fn) args expr))] (clojure.core/concat (clojure.core/list (quote do)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/defn)) (clojure.core/list name) (clojure.core/list args) (clojure.core/list (apply inline args)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote v__3354__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote var)) (clojure.core/list name)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .setMeta)) (clojure.core/list (quote v__3354__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/assoc)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/meta)) (clojure.core/list (quote v__3354__auto__)))) (clojure.core/list :inline) (clojure.core/list inline)))))))))) //====== //(defn empty "Returns an empty collection of the same category as coll, or nil" [coll] (.empty coll)) //--- (function __clojure_core_fn_3366(){ return (clojure.JS.def(clojure.core,"empty",(function __clojure_core_fn_3366_empty_3368(coll_1){ return ((coll_1).empty())})))}).apply(null,[]); // Skipping: (defmacro amap "Maps an expression across an array a, using an index named idx, and\n return value named ret, initialized to a clone of a, then setting each element of\n ret to the evaluation of expr, returning the new array ret." [a idx ret expr] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote a__3372__auto__)) (clojure.core/list a) (clojure.core/list ret) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/aclone)) (clojure.core/list (quote a__3372__auto__))))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/loop)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list idx) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/int)) (clojure.core/list 0)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/<)) (clojure.core/list idx) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/alength)) (clojure.core/list (quote a__3372__auto__)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote do)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/aset)) (clojure.core/list ret) (clojure.core/list idx) (clojure.core/list expr))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked-inc)) (clojure.core/list idx))))))) (clojure.core/list ret))))))) // Skipping: (defmacro areduce "Reduces an expression across an array a, using an index named idx,\n and return value named ret, initialized to init, setting ret to the evaluation of expr at\n each step, returning ret." [a idx ret init expr] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote a__3382__auto__)) (clojure.core/list a)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/loop)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list idx) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/int)) (clojure.core/list 0))) (clojure.core/list ret) (clojure.core/list init)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/<)) (clojure.core/list idx) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/alength)) (clojure.core/list (quote a__3382__auto__)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/unchecked-inc)) (clojure.core/list idx))) (clojure.core/list expr))) (clojure.core/list ret))))))) // Skipping: (defn float-array "Creates an array of floats" {:inline (fn [& args] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/float_array)) args)), :inline-arities #{1 2}} ([size-or-seq] (. clojure.lang.Numbers float_array size-or-seq)) ([size init-val-or-seq] (. clojure.lang.Numbers float_array size init-val-or-seq))) // Skipping: (defn double-array "Creates an array of doubles" {:inline (fn [& args] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/double_array)) args)), :inline-arities #{1 2}} ([size-or-seq] (. clojure.lang.Numbers double_array size-or-seq)) ([size init-val-or-seq] (. clojure.lang.Numbers double_array size init-val-or-seq))) // Skipping: (defn int-array "Creates an array of ints" {:inline (fn [& args] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/int_array)) args)), :inline-arities #{1 2}} ([size-or-seq] (. clojure.lang.Numbers int_array size-or-seq)) ([size init-val-or-seq] (. clojure.lang.Numbers int_array size init-val-or-seq))) // Skipping: (defn long-array "Creates an array of ints" {:inline (fn [& args] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/long_array)) args)), :inline-arities #{1 2}} ([size-or-seq] (. clojure.lang.Numbers long_array size-or-seq)) ([size init-val-or-seq] (. clojure.lang.Numbers long_array size init-val-or-seq))) // Skipping: (definline floats "Casts to float[]" [xs] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/floats)) (clojure.core/list xs))) // Skipping: (definline ints "Casts to int[]" [xs] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/ints)) (clojure.core/list xs))) // Skipping: (definline doubles "Casts to double[]" [xs] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/doubles)) (clojure.core/list xs))) // Skipping: (definline longs "Casts to long[]" [xs] (clojure.core/concat (clojure.core/list (quote .)) (clojure.core/list (quote clojure.lang.Numbers)) (clojure.core/list (quote clojure.core/longs)) (clojure.core/list xs))) //====== //(import (quote (java.util.concurrent BlockingQueue LinkedBlockingQueue))) //--- (function __clojure_core_fn_3432(){ return (clojure.core.import_.apply(null,[clojure.JS.lit_list([clojure.core.symbol("java.util.concurrent"),clojure.core.symbol("BlockingQueue"),clojure.core.symbol("LinkedBlockingQueue")])]))}).apply(null,[]); // Skipping: (defn seque "Creates a queued seq on another (presumably lazy) seq s. The queued\n seq will produce a concrete seq in the background, and can get up to\n n items ahead of the consumer. n-or-q can be an integer n buffer\n size, or an instance of java.util.concurrent BlockingQueue. Note\n that reading from a seque can block if the reader gets ahead of the\n producer." ([s] (seque 100 s)) ([n-or-q s] (let [q (if (instance? BlockingQueue n-or-q) n-or-q (LinkedBlockingQueue. (int n-or-q))) NIL (Object.) agt (agent (seq s)) fill (fn [s] (try (loop [[x & xs :as s] s] (if s (if (.offer q (if (nil? x) NIL x)) (recur xs) s) (.put q q))) (catch Exception e (.put q q) (throw e)))) drain (fn drain [] (let [x (.take q)] (if (identical? x q) (clojure.core/deref agt) (do (send-off agt fill) (lazy-cons (if (identical? x NIL) nil x) (drain))))))] (send-off agt fill) (drain)))) //====== //(defn alter-var-root "Atomically alters the root binding of var v by applying f to its\n current value plus any args" [v f & args] (.alterRoot v f args)) //--- (function __clojure_core_fn_3456(){ return (clojure.JS.def(clojure.core,"alter_var_root",clojure.JS.variadic(2,(function __clojure_core_fn_3456_alter_var_root_3458(v_1,f_2){ var args_3=clojure.JS.rest_args(this,arguments,2); return ((v_1).alterRoot(f_2,args_3))}))))}).apply(null,[]); //====== //(defn make-hierarchy "Creates a hierarchy object for use with derive, isa? etc." [] {:parents {}, :descendants {}, :ancestors {}}) //--- (function __clojure_core_fn_3462(){ return (clojure.JS.def(clojure.core,"make_hierarchy",(function __clojure_core_fn_3462_make_hierarchy_3464(){ return (clojure.core.hash_map(clojure.core.keyword("","parents"),clojure.lang.PersistentArrayMap.EMPTY,clojure.core.keyword("","descendants"),clojure.lang.PersistentArrayMap.EMPTY,clojure.core.keyword("","ancestors"),clojure.lang.PersistentArrayMap.EMPTY))})))}).apply(null,[]); //====== //(def global-hierarchy (make-hierarchy)) //--- (function __clojure_core_fn_3468(){ return (clojure.JS.def(clojure.core,"global_hierarchy",clojure.core.make_hierarchy.apply(null,[])))}).apply(null,[]); //====== //(defn not-empty "If coll is empty, returns nil, else coll" [coll] (when (seq coll) coll)) //--- (function __clojure_core_fn_3471(){ return (clojure.JS.def(clojure.core,"not_empty",(function __clojure_core_fn_3471_not_empty_3473(coll_1){ return (((clojure.core.seq.apply(null,[coll_1]))?(coll_1):(null)))})))}).apply(null,[]); //====== //(defn bases "Returns the immediate superclass and direct interfaces of c, if any" [c] (let [i (.getInterfaces c) s (.getSuperclass c)] (not-empty (if s (cons s i) i)))) //--- (function __clojure_core_fn_3477(){ return (clojure.JS.def(clojure.core,"bases",(function __clojure_core_fn_3477_bases_3479(c_1){ var i_2,s_3; return (((i_2=(c_1).getInterfaces()), (s_3=(c_1).getSuperclass()), clojure.core.not_empty.apply(null,[((s_3)?(clojure.core.cons.apply(null,[s_3,i_2])):(i_2))])))})))}).apply(null,[]); //====== //(defn supers "Returns the immediate and indirect superclasses and interfaces of c, if any" [class] (loop [ret (set (bases class)) cs ret] (if (seq cs) (let [c (first cs) bs (bases c)] (recur (into ret bs) (into (disj cs c) bs))) (not-empty ret)))) //--- (function __clojure_core_fn_3483(){ return (clojure.JS.def(clojure.core,"supers",(function __clojure_core_fn_3483_supers_3485(class_1){ var ret_2,cs_3,c_4,bs_5; return (((function __loop(){var _rtn,_cnt;(ret_2=clojure.core.set.apply(null,[clojure.core.bases.apply(null,[class_1])])), (cs_3=ret_2);do{_cnt=0; _rtn=((clojure.core.seq.apply(null,[cs_3]))?(((c_4=clojure.core.first.apply(null,[cs_3])), (bs_5=clojure.core.bases.apply(null,[c_4])), (_cnt=1,_rtn=[clojure.core.into.apply(null,[ret_2,bs_5]),clojure.core.into.apply(null,[clojure.core.disj.apply(null,[cs_3,c_4]),bs_5])],ret_2=_rtn[0],cs_3=_rtn[1]))):(clojure.core.not_empty.apply(null,[ret_2])))}while(_cnt);return _rtn;})()))})))}).apply(null,[]); //====== //(defn isa? "Returns true if (= child parent), or child is directly or indirectly derived from\n parent, either via a Java type inheritance relationship or a\n relationship established via derive. h must be a hierarchy obtained\n from make-hierarchy, if not supplied defaults to the global\n hierarchy" ([child parent] (isa? global-hierarchy child parent)) ([h child parent] (or (= child parent) (and (class? parent) (class? child) (. parent isAssignableFrom child)) (contains? ((:ancestors h) child) parent) (and (class? child) (some (fn* [p1__3489] (contains? ((:ancestors h) p1__3489) parent)) (supers child))) (and (vector? parent) (vector? child) (= (count parent) (count child)) (loop [ret true i 0] (if (or (not ret) (= i (count parent))) ret (recur (isa? h (child i) (parent i)) (inc i)))))))) //--- (function __clojure_core_fn_3490(){ return (clojure.JS.def(clojure.core,"isa_QMARK_",(function __clojure_core_fn_3490_isa_QMARK_3492(h_1,child_2,parent_3){switch(arguments.length){ case 2:var child_1=arguments[0],parent_2=arguments[1]; return (clojure.core.isa_QMARK_.apply(null,[clojure.core.global_hierarchy,child_1,parent_2]))} var or__962__auto___6,i_12,and__948__auto___7,and__948__auto___5,and__948__auto___10,or__962__auto___13,or__962__auto___7,and__948__auto___9,and__948__auto___6,and__948__auto___8,or__962__auto___5,ret_11,or__962__auto___4; return (((or__962__auto___4=clojure.lang.Util.equiv(child_2,parent_3)), ((or__962__auto___4)?(or__962__auto___4):(((or__962__auto___5=((and__948__auto___5=clojure.core.class_QMARK_.apply(null,[parent_3])), ((and__948__auto___5)?(((and__948__auto___6=clojure.core.class_QMARK_.apply(null,[child_2])), ((and__948__auto___6)?((parent_3).isAssignableFrom(child_2)):(and__948__auto___6)))):(and__948__auto___5)))), ((or__962__auto___5)?(or__962__auto___5):(((or__962__auto___6=clojure.core.contains_QMARK_.apply(null,[clojure.core.keyword("","ancestors").apply(null,[h_1]).apply(null,[child_2]),parent_3])), ((or__962__auto___6)?(or__962__auto___6):(((or__962__auto___7=((and__948__auto___7=clojure.core.class_QMARK_.apply(null,[child_2])), ((and__948__auto___7)?(clojure.core.some.apply(null,[(function __clojure_core_fn_3490_isa_QMARK_3492_fn_3495(p1__3489_1){ return (clojure.core.contains_QMARK_.apply(null,[clojure.core.keyword("","ancestors").apply(null,[h_1]).apply(null,[p1__3489_1]),parent_3]))}),clojure.core.supers.apply(null,[child_2])])):(and__948__auto___7)))), ((or__962__auto___7)?(or__962__auto___7):(((and__948__auto___8=clojure.core.vector_QMARK_.apply(null,[parent_3])), ((and__948__auto___8)?(((and__948__auto___9=clojure.core.vector_QMARK_.apply(null,[child_2])), ((and__948__auto___9)?(((and__948__auto___10=clojure.lang.Util.equiv(clojure.core.count.apply(null,[parent_3]),clojure.core.count.apply(null,[child_2]))), ((and__948__auto___10)?(((function __loop(){var _rtn,_cnt;(ret_11=true), (i_12=(0));do{_cnt=0; _rtn=((((or__962__auto___13=clojure.core.not.apply(null,[ret_11])), ((or__962__auto___13)?(or__962__auto___13):(clojure.lang.Util.equiv(i_12,clojure.core.count.apply(null,[parent_3]))))))?(ret_11):((_cnt=1,_rtn=[clojure.core.isa_QMARK_.apply(null,[h_1,child_2.apply(null,[i_12]),parent_3.apply(null,[i_12])]),clojure.lang.Numbers.inc(i_12)],ret_11=_rtn[0],i_12=_rtn[1])))}while(_cnt);return _rtn;})())):(and__948__auto___10)))):(and__948__auto___9)))):(and__948__auto___8))))))))))))))))})))}).apply(null,[]); //====== //(defn parents "Returns the immediate parents of tag, either via a Java type\n inheritance relationship or a relationship established via derive. h\n must be a hierarchy obtained from make-hierarchy, if not supplied\n defaults to the global hierarchy" ([tag] (parents global-hierarchy tag)) ([h tag] (not-empty (let [tp (get (:parents h) tag)] (if (class? tag) (into (set (bases tag)) tp) tp))))) //--- (function __clojure_core_fn_3500(){ return (clojure.JS.def(clojure.core,"parents",(function __clojure_core_fn_3500_parents_3502(h_1,tag_2){switch(arguments.length){ case 1:var tag_1=arguments[0]; return (clojure.core.parents.apply(null,[clojure.core.global_hierarchy,tag_1]))} var tp_3; return (clojure.core.not_empty.apply(null,[((tp_3=clojure.core.get.apply(null,[clojure.core.keyword("","parents").apply(null,[h_1]),tag_2])), ((clojure.core.class_QMARK_.apply(null,[tag_2]))?(clojure.core.into.apply(null,[clojure.core.set.apply(null,[clojure.core.bases.apply(null,[tag_2])]),tp_3])):(tp_3)))]))})))}).apply(null,[]); //====== //(defn ancestors "Returns the immediate and indirect parents of tag, either via a Java type\n inheritance relationship or a relationship established via derive. h\n must be a hierarchy obtained from make-hierarchy, if not supplied\n defaults to the global hierarchy" ([tag] (ancestors global-hierarchy tag)) ([h tag] (not-empty (let [ta (get (:ancestors h) tag)] (if (class? tag) (into (set (supers tag)) ta) ta))))) //--- (function __clojure_core_fn_3507(){ return (clojure.JS.def(clojure.core,"ancestors",(function __clojure_core_fn_3507_ancestors_3509(h_1,tag_2){switch(arguments.length){ case 1:var tag_1=arguments[0]; return (clojure.core.ancestors.apply(null,[clojure.core.global_hierarchy,tag_1]))} var ta_3; return (clojure.core.not_empty.apply(null,[((ta_3=clojure.core.get.apply(null,[clojure.core.keyword("","ancestors").apply(null,[h_1]),tag_2])), ((clojure.core.class_QMARK_.apply(null,[tag_2]))?(clojure.core.into.apply(null,[clojure.core.set.apply(null,[clojure.core.supers.apply(null,[tag_2])]),ta_3])):(ta_3)))]))})))}).apply(null,[]); //====== //(defn descendants "Returns the immediate and indirect children of tag, through a\n relationship established via derive. h must be a hierarchy obtained\n from make-hierarchy, if not supplied defaults to the global\n hierarchy. Note: does not work on Java type inheritance\n relationships." ([tag] (descendants global-hierarchy tag)) ([h tag] (if (class? tag) (throw (RT/makeUnsupportedException "Can't get descendants of classes")) (not-empty (get (:descendants h) tag))))) //--- (function __clojure_core_fn_3514(){ return (clojure.JS.def(clojure.core,"descendants",(function __clojure_core_fn_3514_descendants_3516(h_1,tag_2){switch(arguments.length){ case 1:var tag_1=arguments[0]; return (clojure.core.descendants.apply(null,[clojure.core.global_hierarchy,tag_1]))} return (((clojure.core.class_QMARK_.apply(null,[tag_2]))?((function __throw(){throw clojure.lang.RT.makeUnsupportedException("Can't get descendants of classes")})()):(clojure.core.not_empty.apply(null,[clojure.core.get.apply(null,[clojure.core.keyword("","descendants").apply(null,[h_1]),tag_2])]))))})))}).apply(null,[]); //====== //(defn derive "Establishes a parent/child relationship between parent and\n tag. Parent must be a namespace-qualified symbol or keyword and\n child can be either a namespace-qualified symbol or keyword or a\n class. h must be a hierarchy obtained from make-hierarchy, if not\n supplied defaults to, and modifies, the global hierarchy." ([tag parent] (assert (namespace parent)) (assert (or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))) (alter-var-root (var global-hierarchy) derive tag parent) nil) ([h tag parent] (assert (not= tag parent)) (assert (or (class? tag) (instance? clojure.lang.Named tag))) (assert (instance? clojure.lang.Named parent)) (let [tp (:parents h) td (:descendants h) ta (:ancestors h) tf (fn [m source sources target targets] (reduce (fn [ret k] (assoc ret k (reduce conj (get targets k #{}) (cons target (targets target))))) m (cons source (sources source))))] (or (when-not (contains? (tp tag) parent) (when (contains? (ta tag) parent) (throw (RT/makeException (print-str tag "already has" parent "as ancestor")))) (when (contains? (ta parent) tag) (throw (RT/makeException (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)), :ancestors (tf (:ancestors h) tag td parent ta), :descendants (tf (:descendants h) parent ta tag td)}) h)))) //--- (function __clojure_core_fn_3521(){ return (clojure.JS.def(clojure.core,"derive",(function __clojure_core_fn_3521_derive_3523(h_1,tag_2,parent_3){switch(arguments.length){ case 2:var or__962__auto___3,and__948__auto___4,tag_1=arguments[0],parent_2=arguments[1]; return (((clojure.core.namespace.apply(null,[parent_2]))?(null):((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["Assert failed: ",clojure.core.pr_str.apply(null,[clojure.JS.lit_list([clojure.core.symbol("namespace"),clojure.core.symbol("parent")])])]))})())), ((((or__962__auto___3=clojure.core.class_QMARK_.apply(null,[tag_1])), ((or__962__auto___3)?(or__962__auto___3):(((and__948__auto___4=clojure.core.instance_QMARK_.apply(null,[clojure.lang.Named,tag_1])), ((and__948__auto___4)?(clojure.core.namespace.apply(null,[tag_1])):(and__948__auto___4)))))))?(null):((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["Assert failed: ",clojure.core.pr_str.apply(null,[clojure.JS.lit_list([clojure.core.symbol("or"),clojure.JS.lit_list([clojure.core.symbol("class?"),clojure.core.symbol("tag")]),clojure.JS.lit_list([clojure.core.symbol("and"),clojure.JS.lit_list([clojure.core.symbol("instance?"),clojure.core.symbol("clojure.lang.Named"),clojure.core.symbol("tag")]),clojure.JS.lit_list([clojure.core.symbol("namespace"),clojure.core.symbol("tag")])])])])]))})())), clojure.core.alter_var_root.apply(null,[clojure.core._var_global_hierarchy,clojure.core.derive,tag_1,parent_2]), null)} var tf_7,ta_6,tp_4,or__962__auto___4,td_5,or__962__auto___8; return (((clojure.core.not_EQ_.apply(null,[tag_2,parent_3]))?(null):((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["Assert failed: ",clojure.core.pr_str.apply(null,[clojure.JS.lit_list([clojure.core.symbol("not="),clojure.core.symbol("tag"),clojure.core.symbol("parent")])])]))})())), ((((or__962__auto___4=clojure.core.class_QMARK_.apply(null,[tag_2])), ((or__962__auto___4)?(or__962__auto___4):(clojure.core.instance_QMARK_.apply(null,[clojure.lang.Named,tag_2])))))?(null):((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["Assert failed: ",clojure.core.pr_str.apply(null,[clojure.JS.lit_list([clojure.core.symbol("or"),clojure.JS.lit_list([clojure.core.symbol("class?"),clojure.core.symbol("tag")]),clojure.JS.lit_list([clojure.core.symbol("instance?"),clojure.core.symbol("clojure.lang.Named"),clojure.core.symbol("tag")])])])]))})())), ((clojure.core.instance_QMARK_.apply(null,[clojure.lang.Named,parent_3]))?(null):((function __throw(){throw clojure.lang.RT.makeException(clojure.core.str.apply(null,["Assert failed: ",clojure.core.pr_str.apply(null,[clojure.JS.lit_list([clojure.core.symbol("instance?"),clojure.core.symbol("clojure.lang.Named"),clojure.core.symbol("parent")])])]))})())), ((tp_4=clojure.core.keyword("","parents").apply(null,[h_1])), (td_5=clojure.core.keyword("","descendants").apply(null,[h_1])), (ta_6=clojure.core.keyword("","ancestors").apply(null,[h_1])), (tf_7=(function __clojure_core_fn_3521_derive_3523_tf_3526(m_1,source_2,sources_3,target_4,targets_5){ return (clojure.core.reduce.apply(null,[(function __clojure_core_fn_3521_derive_3523_tf_3526_fn_3528(ret_1,k_2){ return (clojure.core.assoc.apply(null,[ret_1,k_2,clojure.core.reduce.apply(null,[clojure.core.conj,clojure.core.get.apply(null,[targets_5,k_2,clojure.lang.PersistentHashSet.EMPTY]),clojure.core.cons.apply(null,[target_4,targets_5.apply(null,[target_4])])])]))}),m_1,clojure.core.cons.apply(null,[source_2,sources_3.apply(null,[source_2])])]))})), ((or__962__auto___8=((clojure.core.contains_QMARK_.apply(null,[tp_4.apply(null,[tag_2]),parent_3]))?(null):(((clojure.core.contains_QMARK_.apply(null,[ta_6.apply(null,[tag_2]),parent_3]))?((function __throw(){throw clojure.lang.RT.makeException(clojure.core.print_str.apply(null,[tag_2,"already has",parent_3,"as ancestor"]))})()):(null)), ((clojure.core.contains_QMARK_.apply(null,[ta_6.apply(null,[parent_3]),tag_2]))?((function __throw(){throw clojure.lang.RT.makeException(clojure.core.print_str.apply(null,["Cyclic derivation:",parent_3,"has",tag_2,"as ancestor"]))})()):(null)), clojure.core.hash_map(clojure.core.keyword("","parents"),clojure.core.assoc.apply(null,[clojure.core.keyword("","parents").apply(null,[h_1]),tag_2,clojure.core.conj.apply(null,[clojure.core.get.apply(null,[tp_4,tag_2,clojure.lang.PersistentHashSet.EMPTY]),parent_3])]),clojure.core.keyword("","ancestors"),tf_7.apply(null,[clojure.core.keyword("","ancestors").apply(null,[h_1]),tag_2,td_5,parent_3,ta_6]),clojure.core.keyword("","descendants"),tf_7.apply(null,[clojure.core.keyword("","descendants").apply(null,[h_1]),parent_3,ta_6,tag_2,td_5]))))), ((or__962__auto___8)?(or__962__auto___8):(h_1)))))})))}).apply(null,[]); //====== //(defn underive "Removes a parent/child relationship between parent and\n tag. h must be a hierarchy obtained from make-hierarchy, if not\n supplied defaults to, and modifies, the global hierarchy." ([tag parent] (alter-var-root (var global-hierarchy) underive tag parent) nil) ([h tag parent] (let [tp (:parents h) td (:descendants h) ta (:ancestors h) tf (fn [m source sources target targets] (reduce (fn [ret k] (assoc ret k (reduce disj (get targets k) (cons target (targets target))))) m (cons source (sources source))))] (if (contains? (tp tag) parent) {:parent (assoc (:parents h) tag (disj (get tp tag) parent)), :ancestors (tf (:ancestors h) tag td parent ta), :descendants (tf (:descendants h) parent ta tag td)} h)))) //--- (function __clojure_core_fn_3534(){ return (clojure.JS.def(clojure.core,"underive",(function __clojure_core_fn_3534_underive_3536(h_1,tag_2,parent_3){switch(arguments.length){ case 2:var tag_1=arguments[0],parent_2=arguments[1]; return (clojure.core.alter_var_root.apply(null,[clojure.core._var_global_hierarchy,clojure.core.underive,tag_1,parent_2]), null)} var tp_4,td_5,ta_6,tf_7; return (((tp_4=clojure.core.keyword("","parents").apply(null,[h_1])), (td_5=clojure.core.keyword("","descendants").apply(null,[h_1])), (ta_6=clojure.core.keyword("","ancestors").apply(null,[h_1])), (tf_7=(function __clojure_core_fn_3534_underive_3536_tf_3539(m_1,source_2,sources_3,target_4,targets_5){ return (clojure.core.reduce.apply(null,[(function __clojure_core_fn_3534_underive_3536_tf_3539_fn_3541(ret_1,k_2){ return (clojure.core.assoc.apply(null,[ret_1,k_2,clojure.core.reduce.apply(null,[clojure.core.disj,clojure.core.get.apply(null,[targets_5,k_2]),clojure.core.cons.apply(null,[target_4,targets_5.apply(null,[target_4])])])]))}),m_1,clojure.core.cons.apply(null,[source_2,sources_3.apply(null,[source_2])])]))})), ((clojure.core.contains_QMARK_.apply(null,[tp_4.apply(null,[tag_2]),parent_3]))?(clojure.core.hash_map(clojure.core.keyword("","parent"),clojure.core.assoc.apply(null,[clojure.core.keyword("","parents").apply(null,[h_1]),tag_2,clojure.core.disj.apply(null,[clojure.core.get.apply(null,[tp_4,tag_2]),parent_3])]),clojure.core.keyword("","ancestors"),tf_7.apply(null,[clojure.core.keyword("","ancestors").apply(null,[h_1]),tag_2,td_5,parent_3,ta_6]),clojure.core.keyword("","descendants"),tf_7.apply(null,[clojure.core.keyword("","descendants").apply(null,[h_1]),parent_3,ta_6,tag_2,td_5]))):(h_1))))})))}).apply(null,[]); //====== //(defn distinct? "Returns true if no two of the arguments are =" {:tag Boolean} ([x] true) ([x y] (not (= x y))) ([x y & more] (if (not= x y) (loop [s #{y x} [x & etc :as xs] more] (if xs (if (contains? s x) false (recur (conj s x) etc)) true)) false))) //--- (function __clojure_core_fn_3547(){ return (clojure.JS.def(clojure.core,"distinct_QMARK_",clojure.JS.variadic(2,(function __clojure_core_fn_3547_distinct_QMARK_3549(x_1,y_2){switch(arguments.length){ case 1:return (true) case 2:return (clojure.core.not.apply(null,[clojure.lang.Util.equiv(x_1,y_2)]))} var vec__3556_13,xs_9,G__3554_5,etc_8,s_4,s_10,G__3554_11,etc_15,xs_16,x_14,s_12,x_7,vec__3555_6,more_3=clojure.JS.rest_args(this,arguments,2); return (((clojure.core.not_EQ_.apply(null,[x_1,y_2]))?(((s_4=clojure.core.hash_set(y_2,x_1)), (G__3554_5=more_3), (vec__3555_6=G__3554_5), (x_7=clojure.core.nth.apply(null,[vec__3555_6,(0),null])), (etc_8=clojure.core.nthrest.apply(null,[vec__3555_6,(1)])), (xs_9=vec__3555_6), ((function __loop(){var _rtn,_cnt;(s_10=s_4), (G__3554_11=G__3554_5);do{_cnt=0; _rtn=((s_12=s_10), (vec__3556_13=G__3554_11), (x_14=clojure.core.nth.apply(null,[vec__3556_13,(0),null])), (etc_15=clojure.core.nthrest.apply(null,[vec__3556_13,(1)])), (xs_16=vec__3556_13), ((xs_16)?(((clojure.core.contains_QMARK_.apply(null,[s_12,x_14]))?(false):((_cnt=1,_rtn=[clojure.core.conj.apply(null,[s_12,x_14]),etc_15],s_10=_rtn[0],G__3554_11=_rtn[1])))):(true)))}while(_cnt);return _rtn;})()))):(false)))}))))}).apply(null,[]); //====== //(defn iterator-seq "Returns a seq on a java.util.Iterator. Note that most collections\n providing iterators implement Iterable and thus support seq directly." [iter] (clojure.lang.IteratorSeq/create iter)) //--- (function __clojure_core_fn_3559(){ return (clojure.JS.def(clojure.core,"iterator_seq",(function __clojure_core_fn_3559_iterator_seq_3561(iter_1){ return (clojure.lang.IteratorSeq.create(iter_1))})))}).apply(null,[]); //====== //(defn enumeration-seq "Returns a seq on a java.lang.Enumeration" [e] (clojure.lang.EnumerationSeq/create e)) //--- (function __clojure_core_fn_3565(){ return (clojure.JS.def(clojure.core,"enumeration_seq",(function __clojure_core_fn_3565_enumeration_seq_3567(e_1){ return (clojure.lang.EnumerationSeq.create(e_1))})))}).apply(null,[]); // Skipping: (defn format "Formats a string using java.lang.String.format, see java.util.Formatter for format\n string syntax" [fmt & args] (String/format fmt (to-array args))) //====== //(defn printf "Prints formatted output, as per format" [fmt & args] (print (apply format fmt args))) //--- (function __clojure_core_fn_3577(){ return (clojure.JS.def(clojure.core,"printf",clojure.JS.variadic(1,(function __clojure_core_fn_3577_printf_3579(fmt_1){ var args_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.print.apply(null,[clojure.core.apply.apply(null,[clojure.core.format,fmt_1,args_2])]))}))))}).apply(null,[]); //====== //(def gen-class) //--- (function __clojure_core_fn_3583(){ return (clojure.JS.def(clojure.core,"gen_class",null))}).apply(null,[]); // Skipping: (defmacro ns "Sets *ns* to the namespace named by name (unevaluated), creating it\n if needed. references can be zero or more of: (:refer-clojure ...)\n (:require ...) (:use ...) (:import ...) (:load ...) (:gen-class)\n with the syntax of refer-clojure/require/use/import/load/gen-class\n respectively, except the arguments are unevaluated and need not be\n quoted. (:gen-class ...), when supplied, defaults to :name\n corresponding to the ns name, :main true, :impl-ns same as ns, and\n :init-impl-ns true. All options of gen-class are\n supported. The :gen-class directive is ignored when not\n compiling. If :gen-class is not supplied, when compiled only an\n nsname__init.class will be generated. If :refer-clojure is not used, a\n default (refer 'clojure) is used. Use of ns is preferred to\n individual calls to in-ns/require/use/import:\n\n (ns foo.bar\n (:refer-clojure :exclude [ancestors printf])\n (:require (clojure.contrib sql sql.tests))\n (:use (my.lib this that))\n (:import (java.util Date Timer Random)\n (java.sql Connection Statement)))" [name & references] (let [process-reference (fn [[kname & args]] (clojure.core/concat (clojure.core/list (symbol "clojure.core" (clojure.core/name kname))) (map (fn* [p1__3586] (list (quote quote) p1__3586)) args))) gen-class-clause (first (filter (fn* [p1__3587] (= :gen-class (first p1__3587))) references)) gen-class-call (when gen-class-clause (list* (quote clojure.core/gen-class) :name (.replace (str name) \- \_) :impl-ns name :main true (rest gen-class-clause))) references (remove (fn* [p1__3588] (= :gen-class (first p1__3588))) references)] (clojure.core/concat (clojure.core/list (quote do)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/in-ns)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list name))))) (when gen-class-call (list gen-class-call)) (when (and (not= name (quote clojure.core)) (not-any? (fn* [p1__3589] (= :refer-clojure (first p1__3589))) references)) (clojure.core/concat (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/refer)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list (quote clojure.core)))))))) (map process-reference references)))) // Skipping: (defmacro refer-clojure "Same as (refer 'clojure )" [& filters] (clojure.core/concat (clojure.core/list (quote clojure.core/refer)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote quote)) (clojure.core/list (quote clojure.core)))) filters)) // Skipping: (defmacro defonce "defs name to have the root value of the expr iff the named var has no root value, \n else expr is unevaluated" [name expr] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote v__3643__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote def)) (clojure.core/list name)))))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when-not)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote .hasRoot)) (clojure.core/list (quote v__3643__auto__)))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote def)) (clojure.core/list name) (clojure.core/list expr))))))) //====== //(defonce *loaded-libs* (ref (sorted-set))) //--- (function __clojure_core_fn_3653(){ var v__3643__auto___1; return (((v__3643__auto___1=clojure.JS.def(clojure.core,"_STAR_loaded_libs_STAR_",null)), (((v__3643__auto___1).hasRoot())?(null):(clojure.JS.def(clojure.core,"_STAR_loaded_libs_STAR_",clojure.core.ref.apply(null,[clojure.core.sorted_set.apply(null,[])]))))))}).apply(null,[]); //====== //(defonce *pending-paths* #{}) //--- (function __clojure_core_fn_3656(){ var v__3643__auto___1; return (((v__3643__auto___1=clojure.JS.def(clojure.core,"_STAR_pending_paths_STAR_",null)), (((v__3643__auto___1).hasRoot())?(null):(clojure.JS.def(clojure.core,"_STAR_pending_paths_STAR_",clojure.lang.PersistentHashSet.EMPTY)))))}).apply(null,[]); //====== //(defonce *loading-verbosely* false) //--- (function __clojure_core_fn_3659(){ var v__3643__auto___1; return (((v__3643__auto___1=clojure.JS.def(clojure.core,"_STAR_loading_verbosely_STAR_",null)), (((v__3643__auto___1).hasRoot())?(null):(clojure.JS.def(clojure.core,"_STAR_loading_verbosely_STAR_",false)))))}).apply(null,[]); //====== //(defn- throw-if "Throws an exception with a message if pred is true" [pred fmt & args] (when pred (let [message (apply format fmt args) exception (RT/makeException message) raw-trace (.getStackTrace exception) boring? (fn* [p1__3662] (not= (.getMethodName p1__3662) "doInvoke")) trace (into-array (drop 2 (drop-while boring? raw-trace)))] (.setStackTrace exception trace) (throw exception)))) //--- (function __clojure_core_fn_3663(){ return (clojure.JS.def(clojure.core,"throw_if",clojure.JS.variadic(2,(function __clojure_core_fn_3663_throw_if_3665(pred_1,fmt_2){ var message_4,exception_5,raw_trace_6,boring_QMARK__7,trace_8,args_3=clojure.JS.rest_args(this,arguments,2); return (((pred_1)?(((message_4=clojure.core.apply.apply(null,[clojure.core.format,fmt_2,args_3])), (exception_5=clojure.lang.RT.makeException(message_4)), (raw_trace_6=(exception_5).getStackTrace()), (boring_QMARK__7=(function __clojure_core_fn_3663_throw_if_3665_boring_QMARK_3667(p1__3662_1){ return (clojure.core.not_EQ_.apply(null,[clojure.JS.getOrRun(p1__3662_1,"getMethodName"),"doInvoke"]))})), (trace_8=clojure.core.into_array.apply(null,[clojure.core.drop.apply(null,[(2),clojure.core.drop_while.apply(null,[boring_QMARK__7,raw_trace_6])])])), (exception_5).setStackTrace(trace_8), (function __throw(){throw exception_5})())):(null)))}))))}).apply(null,[]); //====== //(defn- libspec? "Returns true if x is a libspec" [x] (or (symbol? x) (and (vector? x) (or (nil? (second x)) (keyword? (second x)))))) //--- (function __clojure_core_fn_3672(){ return (clojure.JS.def(clojure.core,"libspec_QMARK_",(function __clojure_core_fn_3672_libspec_QMARK_3674(x_1){ var or__962__auto___2,and__948__auto___3,or__962__auto___4; return (((or__962__auto___2=clojure.core.symbol_QMARK_.apply(null,[x_1])), ((or__962__auto___2)?(or__962__auto___2):(((and__948__auto___3=clojure.core.vector_QMARK_.apply(null,[x_1])), ((and__948__auto___3)?(((or__962__auto___4=clojure.core.nil_QMARK_.apply(null,[clojure.core.second.apply(null,[x_1])])), ((or__962__auto___4)?(or__962__auto___4):(clojure.core.keyword_QMARK_.apply(null,[clojure.core.second.apply(null,[x_1])]))))):(and__948__auto___3)))))))})))}).apply(null,[]); //====== //(defn- prependss "Prepends a symbol or a seq to coll" [x coll] (if (symbol? x) (cons x coll) (concat x coll))) //--- (function __clojure_core_fn_3678(){ return (clojure.JS.def(clojure.core,"prependss",(function __clojure_core_fn_3678_prependss_3680(x_1,coll_2){ return (((clojure.core.symbol_QMARK_.apply(null,[x_1]))?(clojure.core.cons.apply(null,[x_1,coll_2])):(clojure.core.concat.apply(null,[x_1,coll_2]))))})))}).apply(null,[]); //====== //(defn- root-resource "Returns the root directory path for a lib" [lib] (str \/ (.. (name lib) (replace \- \_) (replace \. \/)))) //--- (function __clojure_core_fn_3684(){ return (clojure.JS.def(clojure.core,"root_resource",(function __clojure_core_fn_3684_root_resource_3686(lib_1){ return (clojure.core.str.apply(null,["/",((clojure.core.name.apply(null,[lib_1])).replace("-","_")).replace(".","/")]))})))}).apply(null,[]); //====== //(defn- root-directory "Returns the root resource path for a lib" [lib] (let [d (root-resource lib)] (subs d 0 (.lastIndexOf d "/")))) //--- (function __clojure_core_fn_3690(){ return (clojure.JS.def(clojure.core,"root_directory",(function __clojure_core_fn_3690_root_directory_3692(lib_1){ var d_2; return (((d_2=clojure.core.root_resource.apply(null,[lib_1])), clojure.core.subs.apply(null,[d_2,(0),(d_2).lastIndexOf("/")])))})))}).apply(null,[]); // Skipping: (def load) //====== //(defn- load-one "Loads a lib given its name. If need-ns, ensures that the associated\n namespace exists after loading. If require, records the load so any\n duplicate loads can be skipped." [lib need-ns require] (load (root-resource lib)) (throw-if (and need-ns (not (find-ns lib))) "namespace '%s' not found after loading '%s'" lib (root-resource lib)) (when require (dosync (commute *loaded-libs* conj lib)))) //--- (function __clojure_core_fn_3699(){ return (clojure.JS.def(clojure.core,"load_one",(function __clojure_core_fn_3699_load_one_3701(lib_1,need_ns_2,require_3){ var and__948__auto___4; return (clojure.core.load.apply(null,[clojure.core.root_resource.apply(null,[lib_1])]), clojure.core.throw_if.apply(null,[((and__948__auto___4=need_ns_2), ((and__948__auto___4)?(clojure.core.not.apply(null,[clojure.core.find_ns.apply(null,[lib_1])])):(and__948__auto___4))),"namespace '%s' not found after loading '%s'",lib_1,clojure.core.root_resource.apply(null,[lib_1])]), ((require_3)?(clojure.lang.LockingTransaction.runInTransaction((function __clojure_core_fn_3699_load_one_3701_fn_3703(){ return (clojure.core.commute.apply(null,[clojure.core._STAR_loaded_libs_STAR_,clojure.core.conj,lib_1]))}))):(null)))})))}).apply(null,[]); //====== //(defn- load-all "Loads a lib given its name and forces a load of any libs it directly or\n indirectly loads. If need-ns, ensures that the associated namespace\n exists after loading. If require, records the load so any duplicate loads\n can be skipped." [lib need-ns require] (dosync (commute *loaded-libs* (fn* [p1__3708 p2__3709] (reduce conj p1__3708 p2__3709)) (binding [*loaded-libs* (ref (sorted-set))] (load-one lib need-ns require) (clojure.core/deref *loaded-libs*))))) //--- (function __clojure_core_fn_3710(){ return (clojure.JS.def(clojure.core,"load_all",(function __clojure_core_fn_3710_load_all_3712(lib_1,need_ns_2,require_3){ return (clojure.lang.LockingTransaction.runInTransaction((function __clojure_core_fn_3710_load_all_3712_fn_3714(){ return (clojure.core.commute.apply(null,[clojure.core._STAR_loaded_libs_STAR_,(function __clojure_core_fn_3710_load_all_3712_fn_3714_fn_3716(p1__3708_1,p2__3709_2){ return (clojure.core.reduce.apply(null,[clojure.core.conj,p1__3708_1,p2__3709_2]))}),clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_loaded_libs_STAR_,clojure.core.ref.apply(null,[clojure.core.sorted_set.apply(null,[])])])), (function __clojure_core_fn_3710_load_all_3712_fn_3714_fn_3719(){ return ((function __try(){try{var _rtn=(clojure.core.load_one.apply(null,[lib_1,need_ns_2,require_3]), clojure.core.deref.apply(null,[clojure.core._STAR_loaded_libs_STAR_]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())}).apply(null,[])]))})))})))}).apply(null,[]); //====== //(defn- load-lib "Loads a lib with options" [prefix lib & options] (throw-if (and prefix (pos? (.indexOf (name lib) (int \.)))) "lib names inside prefix lists must not contain periods") (let [lib (if prefix (symbol (str prefix \. lib)) lib) opts (apply hash-map options) {:keys [as reload reload-all require use verbose]} opts loaded (contains? (clojure.core/deref *loaded-libs*) lib) load (cond reload-all load-all (or reload (not require) (not loaded)) load-one) need-ns (or as use) filter-opts (select-keys opts (quote (:exclude :only :rename)))] (binding [*loading-verbosely* (or *loading-verbosely* verbose)] (if load (load lib need-ns require) (throw-if (and need-ns (not (find-ns lib))) "namespace '%s' not found" lib)) (when (and need-ns *loading-verbosely*) (printf "(clojure.core/in-ns '%s)\n" (ns-name *ns*))) (when as (when *loading-verbosely* (printf "(clojure.core/alias '%s '%s)\n" as lib)) (alias as lib)) (when use (when *loading-verbosely* (printf "(clojure.core/refer '%s" lib) (doseq [opt filter-opts] (printf " %s '%s" (key opt) (print-str (val opt)))) (printf ")\n")) (apply refer lib (mapcat seq filter-opts)))))) //--- (function __clojure_core_fn_3725(){ return (clojure.JS.def(clojure.core,"load_lib",clojure.JS.variadic(2,(function __clojure_core_fn_3725_load_lib_3727(prefix_1,lib_2){ var opts_5,and__948__auto___19,or__962__auto___15,and__948__auto___4,filter_opts_16,opt_20,loaded_13,reload_all_10,as_12,load_14,need_ns_15,lib_4,and__948__auto___19,or__962__auto___15,reload_11,use_8,verbose_7,or__962__auto___14,require_9,map__3729_6,sq__2041__auto___19,or__962__auto___17,options_3=clojure.JS.rest_args(this,arguments,2); return (clojure.core.throw_if.apply(null,[((and__948__auto___4=prefix_1), ((and__948__auto___4)?(clojure.lang.Numbers.isPos((clojure.core.name.apply(null,[lib_2])).indexOf(clojure.lang.RT.intCast(".")))):(and__948__auto___4))),"lib names inside prefix lists must not contain periods"]), ((lib_4=((prefix_1)?(clojure.core.symbol.apply(null,[clojure.core.str.apply(null,[prefix_1,".",lib_2])])):(lib_2))), (opts_5=clojure.core.apply.apply(null,[clojure.core.hash_map,options_3])), (map__3729_6=opts_5), (verbose_7=clojure.core.get.apply(null,[map__3729_6,clojure.core.keyword("","verbose")])), (use_8=clojure.core.get.apply(null,[map__3729_6,clojure.core.keyword("","use")])), (require_9=clojure.core.get.apply(null,[map__3729_6,clojure.core.keyword("","require")])), (reload_all_10=clojure.core.get.apply(null,[map__3729_6,clojure.core.keyword("","reload-all")])), (reload_11=clojure.core.get.apply(null,[map__3729_6,clojure.core.keyword("","reload")])), (as_12=clojure.core.get.apply(null,[map__3729_6,clojure.core.keyword("","as")])), (loaded_13=clojure.core.contains_QMARK_.apply(null,[clojure.core.deref.apply(null,[clojure.core._STAR_loaded_libs_STAR_]),lib_4])), (load_14=((reload_all_10)?(clojure.core.load_all):(((((or__962__auto___14=reload_11), ((or__962__auto___14)?(or__962__auto___14):(((or__962__auto___15=clojure.core.not.apply(null,[require_9])), ((or__962__auto___15)?(or__962__auto___15):(clojure.core.not.apply(null,[loaded_13]))))))))?(clojure.core.load_one):(null))))), (need_ns_15=((or__962__auto___15=as_12), ((or__962__auto___15)?(or__962__auto___15):(use_8)))), (filter_opts_16=clojure.core.select_keys.apply(null,[opts_5,clojure.JS.lit_list([clojure.core.keyword("","exclude"),clojure.core.keyword("","only"),clojure.core.keyword("","rename")])])), clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_loading_verbosely_STAR_,((or__962__auto___17=clojure.core._STAR_loading_verbosely_STAR_), ((or__962__auto___17)?(or__962__auto___17):(verbose_7)))])), (function __try(){try{var _rtn=(((load_14)?(load_14.apply(null,[lib_4,need_ns_15,require_9])):(clojure.core.throw_if.apply(null,[((and__948__auto___19=need_ns_15), ((and__948__auto___19)?(clojure.core.not.apply(null,[clojure.core.find_ns.apply(null,[lib_4])])):(and__948__auto___19))),"namespace '%s' not found",lib_4]))), ((((and__948__auto___19=need_ns_15), ((and__948__auto___19)?(clojure.core._STAR_loading_verbosely_STAR_):(and__948__auto___19))))?(clojure.core.printf.apply(null,["(clojure.core/in-ns '%s)\n",clojure.core.ns_name.apply(null,[clojure.core._STAR_ns_STAR_])])):(null)), ((as_12)?(((clojure.core._STAR_loading_verbosely_STAR_)?(clojure.core.printf.apply(null,["(clojure.core/alias '%s '%s)\n",as_12,lib_4])):(null)), clojure.core.alias.apply(null,[as_12,lib_4])):(null)), ((use_8)?(((clojure.core._STAR_loading_verbosely_STAR_)?(clojure.core.printf.apply(null,["(clojure.core/refer '%s",lib_4]), ((function __loop(){var _rtn,_cnt;(sq__2041__auto___19=clojure.core.seq.apply(null,[filter_opts_16]));do{_cnt=0; _rtn=((sq__2041__auto___19)?(((opt_20=clojure.core.first.apply(null,[sq__2041__auto___19])), ((true)?(((true)?(clojure.core.printf.apply(null,[" %s '%s",clojure.core.key.apply(null,[opt_20]),clojure.core.print_str.apply(null,[clojure.core.val.apply(null,[opt_20])])])):(null)), (_cnt=1,_rtn=[clojure.core.rest.apply(null,[sq__2041__auto___19])],sq__2041__auto___19=_rtn[0])):(null)))):(null))}while(_cnt);return _rtn;})()), clojure.core.printf.apply(null,[")\n"])):(null)), clojure.core.apply.apply(null,[clojure.core.refer,lib_4,clojure.core.mapcat.apply(null,[clojure.core.seq,filter_opts_16])])):(null)))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})()))}))))}).apply(null,[]); //====== //(defn- load-libs "Loads libs, interpreting libspecs, prefix lists, and flags for\n forwarding to load-lib" [& args] (let [flags (filter keyword? args) opts (interleave flags (repeat true)) args (filter (complement keyword?) args)] (doseq [arg args] (if (libspec? arg) (apply load-lib nil (prependss arg opts)) (let [[prefix & args] arg] (throw-if (nil? prefix) "prefix cannot be nil") (doseq [arg args] (apply load-lib prefix (prependss arg opts)))))))) //--- (function __clojure_core_fn_3732(){ return (clojure.JS.def(clojure.core,"load_libs",clojure.JS.variadic(0,(function __clojure_core_fn_3732_load_libs_3734(){ var sq__2041__auto___10,opts_3,vec__3736_7,arg_6,args_4,flags_2,sq__2041__auto___5,arg_11,prefix_8,args_9,args_1=clojure.JS.rest_args(this,arguments,0); return (((flags_2=clojure.core.filter.apply(null,[clojure.core.keyword_QMARK_,args_1])), (opts_3=clojure.core.interleave.apply(null,[flags_2,clojure.core.repeat.apply(null,[true])])), (args_4=clojure.core.filter.apply(null,[clojure.core.complement.apply(null,[clojure.core.keyword_QMARK_]),args_1])), ((function __loop(){var _rtn,_cnt;(sq__2041__auto___5=clojure.core.seq.apply(null,[args_4]));do{_cnt=0; _rtn=((sq__2041__auto___5)?(((arg_6=clojure.core.first.apply(null,[sq__2041__auto___5])), ((true)?(((true)?(((clojure.core.libspec_QMARK_.apply(null,[arg_6]))?(clojure.core.apply.apply(null,[clojure.core.load_lib,null,clojure.core.prependss.apply(null,[arg_6,opts_3])])):(((vec__3736_7=arg_6), (prefix_8=clojure.core.nth.apply(null,[vec__3736_7,(0),null])), (args_9=clojure.core.nthrest.apply(null,[vec__3736_7,(1)])), clojure.core.throw_if.apply(null,[clojure.core.nil_QMARK_.apply(null,[prefix_8]),"prefix cannot be nil"]), ((function __loop(){var _rtn,_cnt;(sq__2041__auto___10=clojure.core.seq.apply(null,[args_9]));do{_cnt=0; _rtn=((sq__2041__auto___10)?(((arg_11=clojure.core.first.apply(null,[sq__2041__auto___10])), ((true)?(((true)?(clojure.core.apply.apply(null,[clojure.core.load_lib,prefix_8,clojure.core.prependss.apply(null,[arg_11,opts_3])])):(null)), (_cnt=1,_rtn=[clojure.core.rest.apply(null,[sq__2041__auto___10])],sq__2041__auto___10=_rtn[0])):(null)))):(null))}while(_cnt);return _rtn;})()))))):(null)), (_cnt=1,_rtn=[clojure.core.rest.apply(null,[sq__2041__auto___5])],sq__2041__auto___5=_rtn[0])):(null)))):(null))}while(_cnt);return _rtn;})())))}))))}).apply(null,[]); //====== //(defn require "Loads libs, skipping any that are already loaded. Each argument is\n either a libspec that identifies a lib, a prefix list that identifies\n multiple libs whose names share a common prefix, or a flag that modifies\n how all the identified libs are loaded. Use :require in the ns macro \n in preference to calling this directly.\n\n Libs\n\n A 'lib' is a named set of resources in classpath whose contents define a\n library of Clojure code. Lib names are symbols and each lib is associated\n with a Clojure namespace and a Java package that share its name. A lib's\n name also locates its root directory within classpath using Java's\n package name to classpath-relative path mapping. All resources in a lib\n should be contained in the directory structure under its root directory.\n All definitions a lib makes should be in its associated namespace.\n\n 'require loads a lib by loading its root resource. The root resource path\n is derived from the root directory path by repeating its last component\n and appending '.clj'. For example, the lib 'x.y.z has root directory\n /x/y/z; root resource /x/y/z/z.clj. The root\n resource should contain code to create the lib's namespace and load any\n additional lib resources.\n\n Libspecs\n\n A libspec is a lib name or a vector containing a lib name followed by\n options expressed as sequential keywords and arguments.\n\n Recognized options: :as\n :as takes a symbol as its argument and makes that symbol an alias to the\n lib's namespace in the current namespace.\n\n Prefix Lists\n\n It's common for Clojure code to depend on several libs whose names have\n the same prefix. When specifying libs, prefix lists can be used to reduce\n repetition. A prefix list contains the shared prefix followed by libspecs\n with the shared prefix removed from the lib names. After removing the\n prefix, the names that remain must not contain any periods.\n\n Flags\n\n A flag is a keyword.\n Recognized flags: :reload, :reload-all, :verbose\n :reload forces loading of all the identified libs even if they are\n already loaded\n :reload-all implies :reload and also forces loading of all libs that the\n identified libs directly or indirectly load via require or use\n :verbose triggers printing information about each load, alias, and refer" [& args] (apply load-libs :require args)) //--- (function __clojure_core_fn_3739(){ return (clojure.JS.def(clojure.core,"require",clojure.JS.variadic(0,(function __clojure_core_fn_3739_require_3741(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[clojure.core.load_libs,clojure.core.keyword("","require"),args_1]))}))))}).apply(null,[]); //====== //(defn use "Like 'require, but also refers to each lib's namespace using\n clojure.core/refer. Use :use in the ns macro in preference to calling\n this directly.\n\n 'use accepts additional options in libspecs: :exclude, :only, :rename.\n The arguments and semantics for :exclude, :only, and :rename are the same\n as those documented for clojure.core/refer." [& args] (apply load-libs :require :use args)) //--- (function __clojure_core_fn_3745(){ return (clojure.JS.def(clojure.core,"use",clojure.JS.variadic(0,(function __clojure_core_fn_3745_use_3747(){ var args_1=clojure.JS.rest_args(this,arguments,0); return (clojure.core.apply.apply(null,[clojure.core.load_libs,clojure.core.keyword("","require"),clojure.core.keyword("","use"),args_1]))}))))}).apply(null,[]); //====== //(defn loaded-libs "Returns a sorted set of symbols naming the currently loaded libs" [] (clojure.core/deref *loaded-libs*)) //--- (function __clojure_core_fn_3751(){ return (clojure.JS.def(clojure.core,"loaded_libs",(function __clojure_core_fn_3751_loaded_libs_3753(){ return (clojure.core.deref.apply(null,[clojure.core._STAR_loaded_libs_STAR_]))})))}).apply(null,[]); // Skipping: (defn load "Loads Clojure code from resources in classpath. A path is interpreted as\n classpath-relative if it begins with a slash or relative to the root\n directory for the current namespace otherwise." [& paths] (doseq [path paths] (let [path (if (.startsWith path "/") path (str (root-directory (ns-name *ns*)) \/ path))] (when *loading-verbosely* (printf "(clojure.core/load \"%s\")\n" path) (flush)) (when-not (*pending-paths* path) (binding [*pending-paths* (conj *pending-paths* path)] (clojure.lang.RT/load (.substring path 1))))))) //====== //(defn compile "Compiles the namespace named by the symbol lib into a set of\n classfiles. The source for the lib must be in a proper\n classpath-relative directory. The output files will go into the\n directory specified by *compile-path*, and that directory too must\n be in the classpath." [lib] (binding [*compile-files* true] (load-one lib true true)) lib) //--- (function __clojure_core_fn_3766(){ return (clojure.JS.def(clojure.core,"compile",(function __clojure_core_fn_3766_compile_3768(lib_1){ return (clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_compile_files_STAR_,true])), (function __clojure_core_fn_3766_compile_3768_fn_3770(){ return ((function __try(){try{var _rtn=(clojure.core.load_one.apply(null,[lib_1,true,true]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())}).apply(null,[]), lib_1)})))}).apply(null,[]); //====== //(defn get-in "returns the value in a nested associative structure, where ks is a sequence of keys" [m ks] (reduce get m ks)) //--- (function __clojure_core_fn_3775(){ return (clojure.JS.def(clojure.core,"get_in",(function __clojure_core_fn_3775_get_in_3777(m_1,ks_2){ return (clojure.core.reduce.apply(null,[clojure.core.get,m_1,ks_2]))})))}).apply(null,[]); //====== //(defn assoc-in "Associates a value in a nested associative structure, where ks is a\n sequence of keys and v is the new value and returns a new nested structure. \n If any levels do not exist, hash-maps will be created." [m [k & ks] v] (if ks (assoc m k (assoc-in (get m k) ks v)) (assoc m k v))) //--- (function __clojure_core_fn_3781(){ return (clojure.JS.def(clojure.core,"assoc_in",(function __clojure_core_fn_3781_assoc_in_3784(m_1,p__3783_2,v_3){ var vec__3786_4,k_5,ks_6; return (((vec__3786_4=p__3783_2), (k_5=clojure.core.nth.apply(null,[vec__3786_4,(0),null])), (ks_6=clojure.core.nthrest.apply(null,[vec__3786_4,(1)])), ((ks_6)?(clojure.core.assoc.apply(null,[m_1,k_5,clojure.core.assoc_in.apply(null,[clojure.core.get.apply(null,[m_1,k_5]),ks_6,v_3])])):(clojure.core.assoc.apply(null,[m_1,k_5,v_3])))))})))}).apply(null,[]); //====== //(defn update-in "'Updates' a value in a nested associative structure, where ks is a\n sequence of keys and f is a function that will take the old value\n and any supplied args and return the new value, and returns a new\n nested structure. If any levels do not exist, hash-maps will be\n created." ([m [k & ks] f & args] (if ks (assoc m k (apply update-in (get m k) ks f args)) (assoc m k (apply f (get m k) args))))) //--- (function __clojure_core_fn_3789(){ return (clojure.JS.def(clojure.core,"update_in",clojure.JS.variadic(3,(function __clojure_core_fn_3789_update_in_3792(m_1,p__3791_2,f_3){ var vec__3794_5,k_6,ks_7,args_4=clojure.JS.rest_args(this,arguments,3); return (((vec__3794_5=p__3791_2), (k_6=clojure.core.nth.apply(null,[vec__3794_5,(0),null])), (ks_7=clojure.core.nthrest.apply(null,[vec__3794_5,(1)])), ((ks_7)?(clojure.core.assoc.apply(null,[m_1,k_6,clojure.core.apply.apply(null,[clojure.core.update_in,clojure.core.get.apply(null,[m_1,k_6]),ks_7,f_3,args_4])])):(clojure.core.assoc.apply(null,[m_1,k_6,clojure.core.apply.apply(null,[f_3,clojure.core.get.apply(null,[m_1,k_6]),args_4])])))))}))))}).apply(null,[]); //====== //(defn empty? "Returns true if coll has no items - same as (not (seq coll)). \n Please use the idiom (seq x) rather than (not (empty? x))" [coll] (not (seq coll))) //--- (function __clojure_core_fn_3797(){ return (clojure.JS.def(clojure.core,"empty_QMARK_",(function __clojure_core_fn_3797_empty_QMARK_3799(coll_1){ return (clojure.core.not.apply(null,[clojure.core.seq.apply(null,[coll_1])]))})))}).apply(null,[]); //====== //(defn coll? "Returns true if x implements IPersistentCollection" [x] (instance? clojure.lang.IPersistentCollection x)) //--- (function __clojure_core_fn_3803(){ return (clojure.JS.def(clojure.core,"coll_QMARK_",(function __clojure_core_fn_3803_coll_QMARK_3805(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.IPersistentCollection,x_1]))})))}).apply(null,[]); //====== //(defn list? "Returns true if x implements IPersistentList" [x] (instance? clojure.lang.IPersistentList x)) //--- (function __clojure_core_fn_3809(){ return (clojure.JS.def(clojure.core,"list_QMARK_",(function __clojure_core_fn_3809_list_QMARK_3811(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.IPersistentList,x_1]))})))}).apply(null,[]); //====== //(defn set? "Returns true if x implements IPersistentSet" [x] (instance? clojure.lang.IPersistentSet x)) //--- (function __clojure_core_fn_3815(){ return (clojure.JS.def(clojure.core,"set_QMARK_",(function __clojure_core_fn_3815_set_QMARK_3817(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.IPersistentSet,x_1]))})))}).apply(null,[]); //====== //(defn ifn? "Returns true if x implements IFn. Note that many data structures \n (e.g. sets and maps) implement IFn" [x] (instance? clojure.lang.IFn x)) //--- (function __clojure_core_fn_3821(){ return (clojure.JS.def(clojure.core,"ifn_QMARK_",(function __clojure_core_fn_3821_ifn_QMARK_3823(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.IFn,x_1]))})))}).apply(null,[]); //====== //(defn fn? "Returns true if x implements Fn, i.e. is an object created via fn." [x] (instance? clojure.lang.Fn x)) //--- (function __clojure_core_fn_3827(){ return (clojure.JS.def(clojure.core,"fn_QMARK_",(function __clojure_core_fn_3827_fn_QMARK_3829(x_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Fn,x_1]))})))}).apply(null,[]); //====== //(defn associative? "Returns true if coll implements Associative" [coll] (instance? clojure.lang.Associative coll)) //--- (function __clojure_core_fn_3833(){ return (clojure.JS.def(clojure.core,"associative_QMARK_",(function __clojure_core_fn_3833_associative_QMARK_3835(coll_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Associative,coll_1]))})))}).apply(null,[]); //====== //(defn sequential? "Returns true if coll implements Sequential" [coll] (instance? clojure.lang.Sequential coll)) //--- (function __clojure_core_fn_3839(){ return (clojure.JS.def(clojure.core,"sequential_QMARK_",(function __clojure_core_fn_3839_sequential_QMARK_3841(coll_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Sequential,coll_1]))})))}).apply(null,[]); //====== //(defn sorted? "Returns true if coll implements Sorted" [coll] (instance? clojure.lang.Sorted coll)) //--- (function __clojure_core_fn_3845(){ return (clojure.JS.def(clojure.core,"sorted_QMARK_",(function __clojure_core_fn_3845_sorted_QMARK_3847(coll_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Sorted,coll_1]))})))}).apply(null,[]); //====== //(defn reversible? "Returns true if coll implements Reversible" [coll] (instance? clojure.lang.Reversible coll)) //--- (function __clojure_core_fn_3851(){ return (clojure.JS.def(clojure.core,"reversible_QMARK_",(function __clojure_core_fn_3851_reversible_QMARK_3853(coll_1){ return (clojure.core.instance_QMARK_.apply(null,[clojure.lang.Reversible,coll_1]))})))}).apply(null,[]); // Skipping: (defn pmap "Like map, except f is applied in parallel. Semi-lazy in that the\n parallel computation stays ahead of the consumption, but doesn't\n realize the entire result unless required. Only useful for\n computationally intensive functions where the time of f dominates\n the coordination overhead." ([f coll] (let [n (inc (.. Runtime getRuntime availableProcessors)) agents (doall (map (fn* [p1__3857] (agent (f p1__3857))) (take n coll))) wget (fn [a] (await1 a) (clojure.core/deref a)) step (fn step [[x & xs :as s] [a & as :as acycle]] (if s (let [v (wget a)] (send a (fn [_] (f x))) (lazy-cons v (step xs as))) (map wget (take (count agents) acycle))))] (step (drop n coll) (cycle agents)))) ([f coll & colls] (let [step (fn step [cs] (when (every? seq cs) (lazy-cons (map first cs) (step (map rest cs)))))] (pmap (fn* [p1__3858] (apply f p1__3858)) (step (cons coll colls)))))) //====== //(def *1) //--- (function __clojure_core_fn_3896(){ return (clojure.JS.def(clojure.core,"_STAR_1",null))}).apply(null,[]); //====== //(def *2) //--- (function __clojure_core_fn_3899(){ return (clojure.JS.def(clojure.core,"_STAR_2",null))}).apply(null,[]); //====== //(def *3) //--- (function __clojure_core_fn_3902(){ return (clojure.JS.def(clojure.core,"_STAR_3",null))}).apply(null,[]); //====== //(def *e) //--- (function __clojure_core_fn_3905(){ return (clojure.JS.def(clojure.core,"_STAR_e",null))}).apply(null,[]); // Skipping: (defmacro declare "defs the supplied var names with no bindings, useful for making forward declarations." [& names] (clojure.core/concat (clojure.core/list (quote do)) (map (fn* [p1__3908] (list (quote def) p1__3908)) names))) //====== //(defn trampoline "trampoline can be used to convert algorithms requiring mutual\n recursion without stack consumption. Calls f with supplied args, if\n any. If f returns a fn, calls that fn with no arguments, and\n continues to repeat, until the return value is not a fn, then\n returns that non-fn value. Note that if you want to return a fn as a\n final value, you must wrap it in some data structure and unpack it\n after trampoline returns." ([f] (let [ret (f)] (if (fn? ret) (recur ret) ret))) ([f & args] (trampoline (fn* [] (apply f args))))) //--- (function __clojure_core_fn_3924(){ return (clojure.JS.def(clojure.core,"trampoline",clojure.JS.variadic(1,(function __clojure_core_fn_3924_trampoline_3926(f_1){switch(arguments.length){ case 1:var _cnt,_rtn,ret_2; do{_cnt=0;_rtn=((ret_2=f_1.apply(null,[])), ((clojure.core.fn_QMARK_.apply(null,[ret_2]))?((_cnt=1,_rtn=[ret_2],f_1=_rtn[0])):(ret_2))) }while(_cnt);return _rtn;} var args_2=clojure.JS.rest_args(this,arguments,1); return (clojure.core.trampoline.apply(null,[(function __clojure_core_fn_3924_trampoline_3926_fn_3929(){ return (clojure.core.apply.apply(null,[f_1,args_2]))})]))}))))}).apply(null,[]); //====== //(defn intern "Finds or creates a var named by the symbol name in the namespace\n ns (which can be a symbol or a namespace), setting its root binding\n to val if supplied. The namespace must exist. The var will adopt any\n metadata from the name symbol. Returns the var." ([ns name] (let [v (clojure.lang.Var/intern (the-ns ns) name)] (when (clojure.core/meta name) (.setMeta v (clojure.core/meta name))) v)) ([ns name val] (let [v (clojure.lang.Var/intern (the-ns ns) name val)] (when (clojure.core/meta name) (.setMeta v (clojure.core/meta name))) v))) //--- (function __clojure_core_fn_3934(){ return (clojure.JS.def(clojure.core,"intern",(function __clojure_core_fn_3934_intern_3936(ns_1,name_2,val_3){switch(arguments.length){ case 2:var v_3; return (((v_3=clojure.lang.Var.intern(clojure.core.the_ns.apply(null,[ns_1]),name_2)), ((clojure.core.meta.apply(null,[name_2]))?((v_3).setMeta(clojure.core.meta.apply(null,[name_2]))):(null)), v_3))} var v_4; return (((v_4=clojure.lang.Var.intern(clojure.core.the_ns.apply(null,[ns_1]),name_2,val_3)), ((clojure.core.meta.apply(null,[name_2]))?((v_4).setMeta(clojure.core.meta.apply(null,[name_2]))):(null)), v_4))})))}).apply(null,[]); // Skipping: (defmacro while "Repeatedly executes body while test expression is true. Presumes\n some side-effect will cause test to become false/nil. Returns nil" [test & body] (clojure.core/concat (clojure.core/list (quote clojure.core/loop)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat))) (clojure.core/list (clojure.core/concat (clojure.core/list (quote clojure.core/when)) (clojure.core/list test) body (clojure.core/list (clojure.core/concat (clojure.core/list (quote recur)))))))) //====== //(defn memoize "Returns a memoized version of a referentially transparent function. The\n memoized version of the function keeps a cache of the mapping from arguments\n to results and, when calls with the same arguments are repeated often, has\n higher performance at the expense of higher memory use." [f] (let [mem (atom {})] (fn [& args] (if-let [e (find (clojure.core/deref mem) args)] (val e) (let [ret (apply f args)] (swap! mem assoc args ret) ret))))) //--- (function __clojure_core_fn_3950(){ return (clojure.JS.def(clojure.core,"memoize",(function __clojure_core_fn_3950_memoize_3952(f_1){ var mem_2; return (((mem_2=clojure.core.atom.apply(null,[clojure.lang.PersistentArrayMap.EMPTY])), clojure.JS.variadic(0,(function __clojure_core_fn_3950_memoize_3952_fn_3954(){ var temp__3238__auto___2,e_3,ret_3,args_1=clojure.JS.rest_args(this,arguments,0); return (((temp__3238__auto___2=clojure.core.find.apply(null,[clojure.core.deref.apply(null,[mem_2]),args_1])), ((temp__3238__auto___2)?(((e_3=temp__3238__auto___2), clojure.core.val.apply(null,[e_3]))):(((ret_3=clojure.core.apply.apply(null,[f_1,args_1])), clojure.core.swap_BANG_.apply(null,[mem_2,clojure.core.assoc,args_1,ret_3]), ret_3)))))}))))})))}).apply(null,[]); // Skipping: (defmacro condp "Takes a binary predicate, an expression, and a set of clauses.\n Each clause can take the form of either:\n \n test-expr result-expr\n\n test-expr :>> result-fn\n\n Note :>> is an ordinary keyword.\n\n For each clause, (pred test-expr expr) is evaluated. If it returns\n logical true, the clause is a match. If a binary clause matches, the\n result-expr is returned, if a ternary clause matches, its result-fn,\n which must be a unary function, is called with the result of the\n predicate as its argument, the result of that call being the return\n value of condp. A single default expression can follow the clauses,\n and its value will be returned if no clause matches. If no default\n expression is provided and no clause matches, an\n IllegalArgumentException is thrown." [pred expr & clauses] (let [gpred (gensym "pred__") gexpr (gensym "expr__") emit (fn emit [pred expr args] (let [[[a b c :as clause] more] (split-at (if (= :>> (second args)) 3 2) args) n (count clause)] (cond (= 0 n) (clojure.core/concat (clojure.core/list (quote throw)) (clojure.core/list (clojure.core/concat (clojure.core/list (quote java.lang.IllegalArgumentException.)) (clojure.core/list "No matching clause")))) (= 1 n) a (= 2 n) (clojure.core/concat (clojure.core/list (quote if)) (clojure.core/list (clojure.core/concat (clojure.core/list pred) (clojure.core/list a) (clojure.core/list expr))) (clojure.core/list b) (clojure.core/list (emit pred expr more))) :else (clojure.core/concat (clojure.core/list (quote clojure.core/if-let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list (quote p__3959__auto__)) (clojure.core/list (clojure.core/concat (clojure.core/list pred) (clojure.core/list a) (clojure.core/list expr)))))) (clojure.core/list (clojure.core/concat (clojure.core/list c) (clojure.core/list (quote p__3959__auto__)))) (clojure.core/list (emit pred expr more)))))) gres (gensym "res__")] (clojure.core/concat (clojure.core/list (quote clojure.core/let)) (clojure.core/list (clojure.core/apply clojure.core/vector (clojure.core/concat (clojure.core/list gpred) (clojure.core/list pred) (clojure.core/list gexpr) (clojure.core/list expr)))) (clojure.core/list (emit gpred gexpr clauses))))) //====== //(load "core_proxy") //--- (function __clojure_core_fn_3977(){ return (clojure.core.load.apply(null,["core_proxy"]))}).apply(null,[]); //====== //(load "core_print") //--- (function __clojure_core_fn_3980(){ return (clojure.core.load.apply(null,["core_print"]))}).apply(null,[]); //====== //(load "genclass") //--- (function __clojure_core_fn_3983(){ return (clojure.core.load.apply(null,["genclass"]))}).apply(null,[]); //====== //(in-ns (quote clojure.core)) //--- (function __user_fn_3986(){ return (clojure.core.in_ns.apply(null,[clojure.core.symbol("clojure.core")]))}).apply(null,[]); //====== //(import (quote (java.io Writer))) //--- (function __clojure_core_fn_3992(){ return (clojure.core.import_.apply(null,[clojure.JS.lit_list([clojure.core.symbol("java.io"),clojure.core.symbol("Writer")])]))}).apply(null,[]); //====== //(def *print-length* nil) //--- (function __clojure_core_fn_3995(){ return (clojure.JS.def(clojure.core,"_STAR_print_length_STAR_",null))}).apply(null,[]); //====== //(def *print-level* nil) //--- (function __clojure_core_fn_3998(){ return (clojure.JS.def(clojure.core,"_STAR_print_level_STAR_",null))}).apply(null,[]); //====== //(defn- print-sequential [begin print-one sep end sequence w] (binding [*print-level* (and (not *print-dup*) *print-level* (dec *print-level*))] (if (and *print-level* (neg? *print-level*)) (.write w "#") (do (.write w begin) (when-let [xs (seq sequence)] (if (and (not *print-dup*) *print-length*) (loop [[x & xs] xs print-length *print-length*] (if (zero? print-length) (.write w "...") (do (print-one x w) (when xs (.write w sep) (recur xs (dec print-length)))))) (loop [[x & xs] xs] (print-one x w) (when xs (.write w sep) (recur xs))))) (.write w end))))) //--- (function __clojure_core_fn_4001(){ return (clojure.JS.def(clojure.core,"print_sequential",(function __clojure_core_fn_4001_print_sequential_4003(begin_1,print_one_2,sep_3,end_4,sequence_5,w_6){ var vec__4007_12,print_length_21,vec__4012_16,xs_18,x_17,xs_10,G__4010_11,and__948__auto___11,temp__3253__auto___9,and__948__auto___7,x_19,G__4006_11,print_length_15,xs_14,print_length_17,x_13,G__4006_16,xs_20,x_13,and__948__auto___8,xs_14,vec__4011_12,vec__4008_18,G__4010_15,and__948__auto___9; return (clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[clojure.core._var__STAR_print_level_STAR_,((and__948__auto___7=clojure.core.not.apply(null,[clojure.core._STAR_print_dup_STAR_])), ((and__948__auto___7)?(((and__948__auto___8=clojure.core._STAR_print_level_STAR_), ((and__948__auto___8)?(clojure.lang.Numbers.dec(clojure.core._STAR_print_level_STAR_)):(and__948__auto___8)))):(and__948__auto___7)))])), (function __try(){try{var _rtn=(((((and__948__auto___9=clojure.core._STAR_print_level_STAR_), ((and__948__auto___9)?(clojure.lang.Numbers.isNeg(clojure.core._STAR_print_level_STAR_)):(and__948__auto___9))))?((w_6).write("#")):((w_6).write(begin_1), ((temp__3253__auto___9=clojure.core.seq.apply(null,[sequence_5])), ((temp__3253__auto___9)?(((xs_10=temp__3253__auto___9), ((((and__948__auto___11=clojure.core.not.apply(null,[clojure.core._STAR_print_dup_STAR_])), ((and__948__auto___11)?(clojure.core._STAR_print_length_STAR_):(and__948__auto___11))))?(((G__4006_11=xs_10), (vec__4007_12=G__4006_11), (x_13=clojure.core.nth.apply(null,[vec__4007_12,(0),null])), (xs_14=clojure.core.nthrest.apply(null,[vec__4007_12,(1)])), (print_length_15=clojure.core._STAR_print_length_STAR_), ((function __loop(){var _rtn,_cnt;(G__4006_16=G__4006_11), (print_length_17=print_length_15);do{_cnt=0; _rtn=((vec__4008_18=G__4006_16), (x_19=clojure.core.nth.apply(null,[vec__4008_18,(0),null])), (xs_20=clojure.core.nthrest.apply(null,[vec__4008_18,(1)])), (print_length_21=print_length_17), ((clojure.lang.Numbers.isZero(print_length_21))?((w_6).write("...")):(print_one_2.apply(null,[x_19,w_6]), ((xs_20)?((w_6).write(sep_3), (_cnt=1,_rtn=[xs_20,clojure.lang.Numbers.dec(print_length_21)],G__4006_16=_rtn[0],print_length_17=_rtn[1])):(null)))))}while(_cnt);return _rtn;})()))):(((G__4010_11=xs_10), (vec__4011_12=G__4010_11), (x_13=clojure.core.nth.apply(null,[vec__4011_12,(0),null])), (xs_14=clojure.core.nthrest.apply(null,[vec__4011_12,(1)])), ((function __loop(){var _rtn,_cnt;(G__4010_15=G__4010_11);do{_cnt=0; _rtn=((vec__4012_16=G__4010_15), (x_17=clojure.core.nth.apply(null,[vec__4012_16,(0),null])), (xs_18=clojure.core.nthrest.apply(null,[vec__4012_16,(1)])), print_one_2.apply(null,[x_17,w_6]), ((xs_18)?((w_6).write(sep_3), (_cnt=1,_rtn=[xs_18],G__4010_15=_rtn[0])):(null)))}while(_cnt);return _rtn;})())))))):(null))), (w_6).write(end_4))))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())})))}).apply(null,[]); //====== //(defn- print-meta [o w] (when-let [m (meta o)] (when (and (pos? (count m)) (or *print-dup* (and *print-meta* *print-readably*))) (.write w "#^") (if (and (= (count m) 1) (:tag m)) (pr-on (:tag m) w) (pr-on m w)) (.write w " ")))) //--- (function __clojure_core_fn_4015(){ return (clojure.JS.def(clojure.core,"print_meta",(function __clojure_core_fn_4015_print_meta_4017(o_1,w_2){ var temp__3253__auto___3,m_4,and__948__auto___5,or__962__auto___6,and__948__auto___7,and__948__auto___5; return (((temp__3253__auto___3=clojure.core.meta.apply(null,[o_1])), ((temp__3253__auto___3)?(((m_4=temp__3253__auto___3), ((((and__948__auto___5=clojure.lang.Numbers.isPos(clojure.core.count.apply(null,[m_4]))), ((and__948__auto___5)?(((or__962__auto___6=clojure.core._STAR_print_dup_STAR_), ((or__962__auto___6)?(or__962__auto___6):(((and__948__auto___7=clojure.core._STAR_print_meta_STAR_), ((and__948__auto___7)?(clojure.core._STAR_print_readably_STAR_):(and__948__auto___7))))))):(and__948__auto___5))))?((w_2).write("#^"), ((((and__948__auto___5=clojure.lang.Util.equiv(clojure.core.count.apply(null,[m_4]),(1))), ((and__948__auto___5)?(clojure.core.keyword("","tag").apply(null,[m_4])):(and__948__auto___5))))?(clojure.core.pr_on.apply(null,[clojure.core.keyword("","tag").apply(null,[m_4]),w_2])):(clojure.core.pr_on.apply(null,[m_4,w_2]))), (w_2).write(" ")):(null)))):(null))))})))}).apply(null,[]); //====== //(defmethod print-method nil [o w] (.write w "nil")) //--- (function __clojure_core_fn_4021(){ return ((clojure.core.print_method).addMethod(null,(function __clojure_core_fn_4021_fn_4023(o_1,w_2){ return ((w_2).write("nil"))})))}).apply(null,[]); //====== //(defmethod print-dup nil [o w] (print-method o w)) //--- (function __clojure_core_fn_4027(){ return ((clojure.core.print_dup).addMethod(null,(function __clojure_core_fn_4027_fn_4029(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defn print-ctor [o print-args w] (.write w "#=(") (.write w (RT/className (class o))) (.write w ". ") (print-args o w) (.write w ")")) //--- (function __clojure_core_fn_4033(){ return (clojure.JS.def(clojure.core,"print_ctor",(function __clojure_core_fn_4033_print_ctor_4035(o_1,print_args_2,w_3){ return ((w_3).write("#=("), (w_3).write(clojure.lang.RT.className(clojure.core.class_.apply(null,[o_1]))), (w_3).write(". "), print_args_2.apply(null,[o_1,w_3]), (w_3).write(")"))})))}).apply(null,[]); //====== //(defmethod print-method :default [o w] (.write w "#<") (.write w (RT/simpleClassName (class o))) (.write w " ") (.write w (str o)) (.write w ">")) //--- (function __clojure_core_fn_4039(){ return ((clojure.core.print_method).addMethod(clojure.core.keyword("","default"),(function __clojure_core_fn_4039_fn_4041(o_1,w_2){ return ((w_2).write("#<"), (w_2).write(clojure.lang.RT.simpleClassName(clojure.core.class_.apply(null,[o_1]))), (w_2).write(" "), (w_2).write(clojure.core.str.apply(null,[o_1])), (w_2).write(">"))})))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.Keyword [o w] (.write w (str o))) //--- (function __clojure_core_fn_4045(){ return ((clojure.core.print_method).addMethod(clojure.lang.Keyword,(function __clojure_core_fn_4045_fn_4047(o_1,w_2){ return ((w_2).write(clojure.core.str.apply(null,[o_1])))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.Keyword [o w] (print-method o w)) //--- (function __clojure_core_fn_4051(){ return ((clojure.core.print_dup).addMethod(clojure.lang.Keyword,(function __clojure_core_fn_4051_fn_4053(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-method Number [o w] (.write w (str o))) //--- (function __clojure_core_fn_4057(){ return ((clojure.core.print_method).addMethod(java.lang.Number,(function __clojure_core_fn_4057_fn_4059(o_1,w_2){ return ((w_2).write(clojure.core.str.apply(null,[o_1])))})))}).apply(null,[]); //====== //(defmethod print-dup Number [o w] (print-ctor o (fn [o w] (print-dup (str o) w)) w)) //--- (function __clojure_core_fn_4063(){ return ((clojure.core.print_dup).addMethod(java.lang.Number,(function __clojure_core_fn_4063_fn_4065(o_1,w_2){ return (clojure.core.print_ctor.apply(null,[o_1,(function __clojure_core_fn_4063_fn_4065_fn_4067(o_1,w_2){ return (clojure.core.print_dup.apply(null,[clojure.core.str.apply(null,[o_1]),w_2]))}),w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.AFn [o w] (print-ctor o (fn [o w]) w)) //--- (function __clojure_core_fn_4072(){ return ((clojure.core.print_dup).addMethod(clojure.lang.AFn,(function __clojure_core_fn_4072_fn_4074(o_1,w_2){ return (clojure.core.print_ctor.apply(null,[o_1,(function __clojure_core_fn_4072_fn_4074_fn_4076(o_1,w_2){ return (null)}),w_2]))})))}).apply(null,[]); //====== //(prefer-method print-dup clojure.lang.IPersistentCollection clojure.lang.AFn) //--- (function __clojure_core_fn_4081(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_dup,clojure.lang.IPersistentCollection,clojure.lang.AFn]))}).apply(null,[]); //====== //(prefer-method print-dup java.util.Map clojure.lang.AFn) //--- (function __clojure_core_fn_4084(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_dup,java.util.Map,clojure.lang.AFn]))}).apply(null,[]); //====== //(prefer-method print-dup java.util.Collection clojure.lang.AFn) //--- (function __clojure_core_fn_4087(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_dup,java.util.Collection,clojure.lang.AFn]))}).apply(null,[]); //====== //(defmethod print-method Boolean [o w] (.write w (str o))) //--- (function __clojure_core_fn_4090(){ return ((clojure.core.print_method).addMethod(java.lang.Boolean,(function __clojure_core_fn_4090_fn_4092(o_1,w_2){ return ((w_2).write(clojure.core.str.apply(null,[o_1])))})))}).apply(null,[]); //====== //(defmethod print-dup Boolean [o w] (print-method o w)) //--- (function __clojure_core_fn_4096(){ return ((clojure.core.print_dup).addMethod(java.lang.Boolean,(function __clojure_core_fn_4096_fn_4098(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defn print-simple [o w] (print-meta o w) (.write w (str o))) //--- (function __clojure_core_fn_4102(){ return (clojure.JS.def(clojure.core,"print_simple",(function __clojure_core_fn_4102_print_simple_4104(o_1,w_2){ return (clojure.core.print_meta.apply(null,[o_1,w_2]), (w_2).write(clojure.core.str.apply(null,[o_1])))})))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.Symbol [o w] (print-simple o w)) //--- (function __clojure_core_fn_4108(){ return ((clojure.core.print_method).addMethod(clojure.lang.Symbol,(function __clojure_core_fn_4108_fn_4110(o_1,w_2){ return (clojure.core.print_simple.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.Symbol [o w] (print-method o w)) //--- (function __clojure_core_fn_4114(){ return ((clojure.core.print_dup).addMethod(clojure.lang.Symbol,(function __clojure_core_fn_4114_fn_4116(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.Var [o w] (print-simple o w)) //--- (function __clojure_core_fn_4120(){ return ((clojure.core.print_method).addMethod(clojure.lang.Var,(function __clojure_core_fn_4120_fn_4122(o_1,w_2){ return (clojure.core.print_simple.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.Var [o w] (.write w (str "#=(var " (.name (.ns o)) "/" (.sym o) ")"))) //--- (function __clojure_core_fn_4126(){ return ((clojure.core.print_dup).addMethod(clojure.lang.Var,(function __clojure_core_fn_4126_fn_4128(o_1,w_2){ return ((w_2).write(clojure.core.str.apply(null,["#=(var ",clojure.JS.getOrRun(clojure.JS.getOrRun(o_1,"ns"),"name"),"/",clojure.JS.getOrRun(o_1,"sym"),")"])))})))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.ISeq [o w] (print-meta o w) (print-sequential "(" pr-on " " ")" o w)) //--- (function __clojure_core_fn_4132(){ return ((clojure.core.print_method).addMethod(clojure.lang.ISeq,(function __clojure_core_fn_4132_fn_4134(o_1,w_2){ return (clojure.core.print_meta.apply(null,[o_1,w_2]), clojure.core.print_sequential.apply(null,["(",clojure.core.pr_on," ",")",o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.ISeq [o w] (print-method o w)) //--- (function __clojure_core_fn_4138(){ return ((clojure.core.print_dup).addMethod(clojure.lang.ISeq,(function __clojure_core_fn_4138_fn_4140(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.IPersistentList [o w] (print-method o w)) //--- (function __clojure_core_fn_4144(){ return ((clojure.core.print_dup).addMethod(clojure.lang.IPersistentList,(function __clojure_core_fn_4144_fn_4146(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(prefer-method print-method clojure.lang.IPersistentList clojure.lang.ISeq) //--- (function __clojure_core_fn_4150(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_method,clojure.lang.IPersistentList,clojure.lang.ISeq]))}).apply(null,[]); //====== //(prefer-method print-dup clojure.lang.IPersistentList clojure.lang.ISeq) //--- (function __clojure_core_fn_4153(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_dup,clojure.lang.IPersistentList,clojure.lang.ISeq]))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.IPersistentList [o w] (print-meta o w) (print-sequential "(" print-method " " ")" o w)) //--- (function __clojure_core_fn_4156(){ return ((clojure.core.print_method).addMethod(clojure.lang.IPersistentList,(function __clojure_core_fn_4156_fn_4158(o_1,w_2){ return (clojure.core.print_meta.apply(null,[o_1,w_2]), clojure.core.print_sequential.apply(null,["(",clojure.core.print_method," ",")",o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup java.util.Collection [o w] (print-ctor o (fn* [p1__4162 p2__4163] (print-sequential "[" print-dup " " "]" p1__4162 p2__4163)) w)) //--- (function __clojure_core_fn_4164(){ return ((clojure.core.print_dup).addMethod(java.util.Collection,(function __clojure_core_fn_4164_fn_4166(o_1,w_2){ return (clojure.core.print_ctor.apply(null,[o_1,(function __clojure_core_fn_4164_fn_4166_fn_4168(p1__4162_1,p2__4163_2){ return (clojure.core.print_sequential.apply(null,["[",clojure.core.print_dup," ","]",p1__4162_1,p2__4163_2]))}),w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.IPersistentCollection [o w] (print-meta o w) (.write w "#=(") (.write w (RT/className (class o))) (.write w "/create ") (print-sequential "[" print-dup " " "]" o w) (.write w ")")) //--- (function __clojure_core_fn_4173(){ return ((clojure.core.print_dup).addMethod(clojure.lang.IPersistentCollection,(function __clojure_core_fn_4173_fn_4175(o_1,w_2){ return (clojure.core.print_meta.apply(null,[o_1,w_2]), (w_2).write("#=("), (w_2).write(clojure.lang.RT.className(clojure.core.class_.apply(null,[o_1]))), (w_2).write("/create "), clojure.core.print_sequential.apply(null,["[",clojure.core.print_dup," ","]",o_1,w_2]), (w_2).write(")"))})))}).apply(null,[]); //====== //(prefer-method print-dup clojure.lang.IPersistentCollection java.util.Collection) //--- (function __clojure_core_fn_4179(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_dup,clojure.lang.IPersistentCollection,java.util.Collection]))}).apply(null,[]); //====== //(def char-escape-string {\newline "\\n", \tab "\\t", \return "\\r", \" "\\\"", \\ "\\\\", \formfeed "\\f", \backspace "\\b"}) //--- (function __clojure_core_fn_4182(){ return (clojure.JS.def(clojure.core,"char_escape_string",clojure.core.hash_map("\n","\\n","\t","\\t","\r","\\r","\"","\\\"","\\","\\\\","\f","\\f","\b","\\b")))}).apply(null,[]); //====== //(defmethod print-method String [s w] (if (or *print-dup* *print-readably*) (do (.append w \") (dotimes [n (count s)] (let [c (.charAt s n) e (char-escape-string c)] (if e (.write w e) (.append w c)))) (.append w \")) (.write w s)) nil) //--- (function __clojure_core_fn_4185(){ return ((clojure.core.print_method).addMethod(java.lang.String,(function __clojure_core_fn_4185_fn_4187(s_1,w_2){ var or__962__auto___3,n__2101__auto___3,n_4,c_5,e_6; return (((((or__962__auto___3=clojure.core._STAR_print_dup_STAR_), ((or__962__auto___3)?(or__962__auto___3):(clojure.core._STAR_print_readably_STAR_))))?((w_2).append("\""), ((n__2101__auto___3=clojure.lang.RT.intCast(clojure.core.count.apply(null,[s_1]))), ((function __loop(){var _rtn,_cnt;(n_4=clojure.lang.RT.intCast((0)));do{_cnt=0; _rtn=((clojure.lang.Numbers.lt(n_4,n__2101__auto___3))?(((c_5=(s_1).charAt(n_4)), (e_6=clojure.core.char_escape_string.apply(null,[c_5])), ((e_6)?((w_2).write(e_6)):((w_2).append(c_5)))), (_cnt=1,_rtn=[clojure.lang.Numbers.unchecked_inc(n_4)],n_4=_rtn[0])):(null))}while(_cnt);return _rtn;})())), (w_2).append("\"")):((w_2).write(s_1))), null)})))}).apply(null,[]); //====== //(defmethod print-dup String [s w] (print-method s w)) //--- (function __clojure_core_fn_4191(){ return ((clojure.core.print_dup).addMethod(java.lang.String,(function __clojure_core_fn_4191_fn_4193(s_1,w_2){ return (clojure.core.print_method.apply(null,[s_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.IPersistentVector [v w] (print-meta v w) (print-sequential "[" pr-on " " "]" v w)) //--- (function __clojure_core_fn_4197(){ return ((clojure.core.print_method).addMethod(clojure.lang.IPersistentVector,(function __clojure_core_fn_4197_fn_4199(v_1,w_2){ return (clojure.core.print_meta.apply(null,[v_1,w_2]), clojure.core.print_sequential.apply(null,["[",clojure.core.pr_on," ","]",v_1,w_2]))})))}).apply(null,[]); //====== //(defn- print-map [m print-one w] (print-sequential "{" (fn [e w] (do (print-one (key e) w) (.append w \space) (print-one (val e) w))) ", " "}" (seq m) w)) //--- (function __clojure_core_fn_4203(){ return (clojure.JS.def(clojure.core,"print_map",(function __clojure_core_fn_4203_print_map_4205(m_1,print_one_2,w_3){ return (clojure.core.print_sequential.apply(null,["{",(function __clojure_core_fn_4203_print_map_4205_fn_4207(e_1,w_2){ return (print_one_2.apply(null,[clojure.core.key.apply(null,[e_1]),w_2]), (w_2).append(" "), print_one_2.apply(null,[clojure.core.val.apply(null,[e_1]),w_2]))}),", ","}",clojure.core.seq.apply(null,[m_1]),w_3]))})))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.IPersistentMap [m w] (print-meta m w) (print-map m pr-on w)) //--- (function __clojure_core_fn_4212(){ return ((clojure.core.print_method).addMethod(clojure.lang.IPersistentMap,(function __clojure_core_fn_4212_fn_4214(m_1,w_2){ return (clojure.core.print_meta.apply(null,[m_1,w_2]), clojure.core.print_map.apply(null,[m_1,clojure.core.pr_on,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup java.util.Map [m w] (print-ctor m (fn* [p1__4218 p2__4219] (print-map (seq p1__4218) print-dup p2__4219)) w)) //--- (function __clojure_core_fn_4220(){ return ((clojure.core.print_dup).addMethod(java.util.Map,(function __clojure_core_fn_4220_fn_4222(m_1,w_2){ return (clojure.core.print_ctor.apply(null,[m_1,(function __clojure_core_fn_4220_fn_4222_fn_4224(p1__4218_1,p2__4219_2){ return (clojure.core.print_map.apply(null,[clojure.core.seq.apply(null,[p1__4218_1]),clojure.core.print_dup,p2__4219_2]))}),w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.IPersistentMap [m w] (print-meta m w) (.write w "#=(") (.write w (RT/className (class m))) (.write w "/create ") (print-map m print-dup w) (.write w ")")) //--- (function __clojure_core_fn_4229(){ return ((clojure.core.print_dup).addMethod(clojure.lang.IPersistentMap,(function __clojure_core_fn_4229_fn_4231(m_1,w_2){ return (clojure.core.print_meta.apply(null,[m_1,w_2]), (w_2).write("#=("), (w_2).write(clojure.lang.RT.className(clojure.core.class_.apply(null,[m_1]))), (w_2).write("/create "), clojure.core.print_map.apply(null,[m_1,clojure.core.print_dup,w_2]), (w_2).write(")"))})))}).apply(null,[]); //====== //(prefer-method print-dup clojure.lang.IPersistentCollection java.util.Map) //--- (function __clojure_core_fn_4235(){ return (clojure.core.prefer_method.apply(null,[clojure.core.print_dup,clojure.lang.IPersistentCollection,java.util.Map]))}).apply(null,[]); //====== //(defmethod print-method clojure.lang.IPersistentSet [s w] (print-meta s w) (print-sequential "#{" pr-on " " "}" (seq s) w)) //--- (function __clojure_core_fn_4238(){ return ((clojure.core.print_method).addMethod(clojure.lang.IPersistentSet,(function __clojure_core_fn_4238_fn_4240(s_1,w_2){ return (clojure.core.print_meta.apply(null,[s_1,w_2]), clojure.core.print_sequential.apply(null,["#{",clojure.core.pr_on," ","}",clojure.core.seq.apply(null,[s_1]),w_2]))})))}).apply(null,[]); //====== //(def char-name-string {\newline "newline", \tab "tab", \space "space", \backspace "backspace", \formfeed "formfeed", \return "return"}) //--- (function __clojure_core_fn_4244(){ return (clojure.JS.def(clojure.core,"char_name_string",clojure.core.hash_map("\n","newline","\t","tab"," ","space","\b","backspace","\f","formfeed","\r","return")))}).apply(null,[]); //====== //(defmethod print-method java.lang.Character [c w] (if (or *print-dup* *print-readably*) (do (.append w \\) (let [n (char-name-string c)] (if n (.write w n) (.append w c)))) (.append w c)) nil) //--- (function __clojure_core_fn_4247(){ return ((clojure.core.print_method).addMethod(java.lang.Character,(function __clojure_core_fn_4247_fn_4249(c_1,w_2){ var or__962__auto___3,n_3; return (((((or__962__auto___3=clojure.core._STAR_print_dup_STAR_), ((or__962__auto___3)?(or__962__auto___3):(clojure.core._STAR_print_readably_STAR_))))?((w_2).append("\\"), ((n_3=clojure.core.char_name_string.apply(null,[c_1])), ((n_3)?((w_2).write(n_3)):((w_2).append(c_1))))):((w_2).append(c_1))), null)})))}).apply(null,[]); //====== //(defmethod print-dup java.lang.Character [c w] (print-method c w)) //--- (function __clojure_core_fn_4253(){ return ((clojure.core.print_dup).addMethod(java.lang.Character,(function __clojure_core_fn_4253_fn_4255(c_1,w_2){ return (clojure.core.print_method.apply(null,[c_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup java.lang.Integer [o w] (print-method o w)) //--- (function __clojure_core_fn_4259(){ return ((clojure.core.print_dup).addMethod(java.lang.Integer,(function __clojure_core_fn_4259_fn_4261(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup java.lang.Double [o w] (print-method o w)) //--- (function __clojure_core_fn_4265(){ return ((clojure.core.print_dup).addMethod(java.lang.Double,(function __clojure_core_fn_4265_fn_4267(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.Ratio [o w] (print-method o w)) //--- (function __clojure_core_fn_4271(){ return ((clojure.core.print_dup).addMethod(clojure.lang.Ratio,(function __clojure_core_fn_4271_fn_4273(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup java.math.BigDecimal [o w] (print-method o w)) //--- (function __clojure_core_fn_4277(){ return ((clojure.core.print_dup).addMethod(java.math.BigDecimal,(function __clojure_core_fn_4277_fn_4279(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.PersistentHashMap [o w] (print-method o w)) //--- (function __clojure_core_fn_4283(){ return ((clojure.core.print_dup).addMethod(clojure.lang.PersistentHashMap,(function __clojure_core_fn_4283_fn_4285(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.PersistentHashSet [o w] (print-method o w)) //--- (function __clojure_core_fn_4289(){ return ((clojure.core.print_dup).addMethod(clojure.lang.PersistentHashSet,(function __clojure_core_fn_4289_fn_4291(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.PersistentVector [o w] (print-method o w)) //--- (function __clojure_core_fn_4295(){ return ((clojure.core.print_dup).addMethod(clojure.lang.PersistentVector,(function __clojure_core_fn_4295_fn_4297(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.LazilyPersistentVector [o w] (print-method o w)) //--- (function __clojure_core_fn_4301(){ return ((clojure.core.print_dup).addMethod(clojure.lang.LazilyPersistentVector,(function __clojure_core_fn_4301_fn_4303(o_1,w_2){ return (clojure.core.print_method.apply(null,[o_1,w_2]))})))}).apply(null,[]); // Skipping: (def primitives-classnames {Float/TYPE "Float/TYPE", Integer/TYPE "Integer/TYPE", Long/TYPE "Long/TYPE", Boolean/TYPE "Boolean/TYPE", Character/TYPE "Character/TYPE", Double/TYPE "Double/TYPE", Byte/TYPE "Byte/TYPE", Short/TYPE "Short/TYPE"}) // Skipping: (defmethod print-method Class [c w] (.write w (RT/className c))) // Skipping: (defmethod print-dup Class [c w] (cond (.isPrimitive c) (do (.write w "#=(identity ") (.write w (primitives-classnames c)) (.write w ")")) (.isArray c) (do (.write w "#=(java.lang.Class/forName \"") (.write w (RT/className c)) (.write w "\")")) :else (do (.write w "#=") (.write w (RT/className c))))) //====== //(defmethod print-method java.math.BigDecimal [b w] (.write w (str b)) (.write w "M")) //--- (function __clojure_core_fn_4322(){ return ((clojure.core.print_method).addMethod(java.math.BigDecimal,(function __clojure_core_fn_4322_fn_4324(b_1,w_2){ return ((w_2).write(clojure.core.str.apply(null,[b_1])), (w_2).write("M"))})))}).apply(null,[]); //====== //(defmethod print-method java.util.regex.Pattern [p w] (.write w "#\"") (loop [[c & r :as s] (seq (.pattern p)) qmode false] (when s (cond (= c \\) (let [[c2 & r2] r] (.append w \\) (.append w c2) (if qmode (recur r2 (not= c2 \E)) (recur r2 (= c2 \Q)))) (= c \") (do (if qmode (.write w "\\E\\\"\\Q") (.write w "\\\"")) (recur r qmode)) :else (do (.append w c) (recur r qmode))))) (.append w \")) //--- (function __clojure_core_fn_4328(){ return ((clojure.core.print_method).addMethod(java.util.regex.Pattern,(function __clojure_core_fn_4328_fn_4330(p_1,w_2){ var r2_18,c_5,s_7,s_14,vec__4335_11,qmode_10,r_6,G__4333_3,vec__4336_16,qmode_8,G__4333_9,r_13,vec__4334_4,c_12,c2_17,qmode_15; return ((w_2).write("#\""), ((G__4333_3=clojure.core.seq.apply(null,[(p_1).pattern()])), (vec__4334_4=G__4333_3), (c_5=clojure.core.nth.apply(null,[vec__4334_4,(0),null])), (r_6=clojure.core.nthrest.apply(null,[vec__4334_4,(1)])), (s_7=vec__4334_4), (qmode_8=false), ((function __loop(){var _rtn,_cnt;(G__4333_9=G__4333_3), (qmode_10=qmode_8);do{_cnt=0; _rtn=((vec__4335_11=G__4333_9), (c_12=clojure.core.nth.apply(null,[vec__4335_11,(0),null])), (r_13=clojure.core.nthrest.apply(null,[vec__4335_11,(1)])), (s_14=vec__4335_11), (qmode_15=qmode_10), ((s_14)?(((clojure.lang.Util.equiv(c_12,"\\"))?(((vec__4336_16=r_13), (c2_17=clojure.core.nth.apply(null,[vec__4336_16,(0),null])), (r2_18=clojure.core.nthrest.apply(null,[vec__4336_16,(1)])), (w_2).append("\\"), (w_2).append(c2_17), ((qmode_15)?((_cnt=1,_rtn=[r2_18,clojure.core.not_EQ_.apply(null,[c2_17,"E"])],G__4333_9=_rtn[0],qmode_10=_rtn[1])):((_cnt=1,_rtn=[r2_18,clojure.lang.Util.equiv(c2_17,"Q")],G__4333_9=_rtn[0],qmode_10=_rtn[1]))))):(((clojure.lang.Util.equiv(c_12,"\""))?(((qmode_15)?((w_2).write("\\E\\\"\\Q")):((w_2).write("\\\""))), (_cnt=1,_rtn=[r_13,qmode_15],G__4333_9=_rtn[0],qmode_10=_rtn[1])):(((clojure.core.keyword("","else"))?((w_2).append(c_12), (_cnt=1,_rtn=[r_13,qmode_15],G__4333_9=_rtn[0],qmode_10=_rtn[1])):(null))))))):(null)))}while(_cnt);return _rtn;})())), (w_2).append("\""))})))}).apply(null,[]); //====== //(defmethod print-dup java.util.regex.Pattern [p w] (print-method p w)) //--- (function __clojure_core_fn_4339(){ return ((clojure.core.print_dup).addMethod(java.util.regex.Pattern,(function __clojure_core_fn_4339_fn_4341(p_1,w_2){ return (clojure.core.print_method.apply(null,[p_1,w_2]))})))}).apply(null,[]); //====== //(defmethod print-dup clojure.lang.Namespace [n w] (.write w "#=(find-ns ") (print-dup (.name n) w) (.write w ")")) //--- (function __clojure_core_fn_4345(){ return ((clojure.core.print_dup).addMethod(clojure.lang.Namespace,(function __clojure_core_fn_4345_fn_4347(n_1,w_2){ return ((w_2).write("#=(find-ns "), clojure.core.print_dup.apply(null,[clojure.JS.getOrRun(n_1,"name"),w_2]), (w_2).write(")"))})))}).apply(null,[]); //====== //(def print-initialized true) //--- (function __clojure_core_fn_4351(){ return (clojure.JS.def(clojure.core,"print_initialized",true))}).apply(null,[]); clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/repl/000077500000000000000000000000001161102570000302415ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/repl/blank.gif000066400000000000000000000000601161102570000320130ustar00rootroot00000000000000GIF89a€!ù ,Œ©Ëí];clojure-logo-anim-03.gif000066400000000000000000000114671161102570000344250ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/replGIF89a çÿP‚ÚX‚ÕZÚX„Ð_†Æ[ŽàdŒàcÚcÂaÔ_‘Ìg”¹h“ÀpËo’Æf™¯j˜·aŸ£mŸ•i¢ˆm¡Žq›Áwœ½e°.o›âl¦€rŸ¿xšãvœÝs¡¶|›×e³8{ÒuŸÑo¬iz¢»m¯ai±[o²Om²Vk´Iy£Êv§³o¶Er·>‚¦È©·}ª½‡§Ã­›€²‹„¬Çx½K}¸s‹¯·ƒºg‰°¾€½b‰±ÅÀV}À\µÄ–³ä‘´ê™²ê‰Åb•¸Á‹µþ’³þœ´ß ´Ù™¶Ú”·à¸í¸ÃŸ¶ÕŠÈkšº×˜À¯½À »Ò“Énœ¿ºšºø•½ì›¾Ò—»ÿš¼ó¦¾Â”Ìwž¾èŸÅ­œÌx¨ÀÑ ÈœœÊ—ȨšÄڜ̋”ɨÀì¬ÀæœÏŸÏ{«Âà¦Æɦ˚©ÅÐÄÿ™Ð•ŒÜH ÆéĘ̂Äè§Ãõ¢Äû¨Åà©ÂûŸÒ„¢ÉצϙӥÆð”ÜI°Ȩ̀҅³ÇÓ›Úe«Ì¯ËɱÉÛ Ø‚¦Ñ¸–àUžÙ‰±Î¿ßV¨Ö¨ÏÞ¨Ô²²ÎÙ±×’·ÏÔ¥á`°Ù™°ÓØŸäi¶Óϵ׬¾ÐÙ¦ãiµÙ¡¬âi¹Úœ¿ÓÒ¹Ñþ¹Òø¬är½Óó´ÙÕºÚúÖî²å{¸ÛнÙÖÂÕï¸ß¬¿×é»ß§ÀÚ˽ݿ·á´Ãߨ´è„ÆÛÚÆÛçÅÙÿ¿âº¾å¢Ãâ±¾àÖºéËÛîÅÞã¹ê”ÃàÝËâÅÆãÍÅãÓÏàÙÁë–ÌáàÎå¶ÉãÚÉê˜ÓààÌæ¼ÈçÆÂíŸÈìŸÔæ¾Ïì¡Èî¨ÐçØ×äåÑæåÚäß×æÙÒêÁÏî©ÕèÔÖçàÕêÈÖêÎÉò±Ðð±ÞìÌÔñºÙîÌÝêëàêåÚìåãêßßíáßïÔÕôÂæïÖÝôÄçíïãóÅåñÞâõÍçñìâ÷Õêóçïñîéõâêôïðôãê÷×çøÝîöÞí÷òð÷ìõùèðûèöøõñûöúùðôûðóýøüûòöýòúüùþÿü!ÿ NETSCAPE2.0!ù ÿ, þÿ Hp ¿ƒ *\X¡?W“~­sȰ⿃®l,  £€p ;h‘àAn<ªT C/’ýõs`¥MlÀ\x0åÍŸ]ì4éÔô8 €Ÿ† ôÇm˜C{šléÏÞ7£6tHÖŸåCL#\$B‰.„lá…._äg€~&g¥QH5U?fTêégQYÑAÄ\úégh:Ö.åºi›¢oò$O¤¬½M#¥ˆ¦ÐmžþøÒ®›ôM·îú'ÍÔå»÷ÌÈ>òã×?1[ŽÂLÞyyÍl"<§€‚š,ü˜ãEs>øÐÎ?‹TñÃ@øñO€èýSÊ&Íüó '¾-óÏ$P1ž#¥‚…@ø€N?§lò`t¡üƒ'›Ô¸Mƒ61Ð7ûÙ„=íÜr¡tÝü3M)èü…E HPAî×Å@·HWã@òh¢‰+ö,ÔNUqÄ6ÿØÌ4I&5+e¶Ø…+òÔŽ+|t±Æ—®8‡} ùg?9(U4dO‡6Š(K®êè~?HÉ:PL ̸99št!)?4±šž2ÔÌ/ÌtšT@!ù ÿ,þÿ H »‚"œ‡m¤FABE ŸB…ùfEܸ±‹ýùû÷£ÉˆÚ@þ‹u²eDješE UIˆnšD–0Bw0- §q§J‚ûÞ)}·O`Ñ ¹ BƒFÁkƲËÖô)ÄXï "CVP¿v¯À ÌÊ6šO¯Ü ôC–L™v÷JÁ*u0Û¬ÑöáÓ öß°ºdý»«q®ïþfÍöØÆLã æv¯±gxûŽI>öoÇ~ΓYÇÍsãeÿüJ~÷£»ÃˆÛ5s kØ?x’ÑÖ)wÝvÝxÛ³÷/Úì™6‚Kx:×¾_ý;'9ž>Žæ컕ÙlÏ5sXöøýUÖ´£Å±u6öm –@ÙÆÒý£¶1å¿JˆÝõÏ+°Ès,¶üChÑø3ÏM¨ Äjtü#oÿx†dnýS$ØôC|uù1Ð0ž%8>Ú€NSi†ÜücO7ÿt³áQý¢š]~8ÃÜ?ëüRÉ$»€cŽ‹Ëx£ÐˆÉXUã r#PfY—• 9#¥–uUÂc;$j)H< ´Î0~|IŽ ™&BÛ8Ãœ !ù ÿ,þÿ H ¹‚"ü–ê3g"öID,ŸB…èÖâÉ–6Cö™u‘`?>E6þX¹DŠˆ!#B+ù¯Ë8o‘òfLb» 鲦‰œ@Šã3&I„趴ÇÌÑ/yíIË3äSšïu›6­›Å\»&dVÅFCmÚä)Ö?~h»¢*X'”è85û×mî¦Uµ|ÕË“ÝÀ.8} ûçin·¯6•Bœ˜_¾¦{ÿ‘BºF áPÿ¦mK–ëkÿXÅL$ Rfÿ ÏvÏSª®]ÿc§¶R ÛTë>õ/×*\Ák¥û§ÖÕqt¹toºõï[t×ÓûûÄÄFê&NtÊçr’‡õØ÷é‰bjûu¼]aÃÜyý÷ýÝ=µÿ…3òè&Ï2¦ðÃOt¸àSAT¦m÷Ï.¸œóO4ÁiHLLÈäR’ýsÊ&í¨ƒØ1ÿÔã‹ÿøÔÈ@Ì×Ä?íp÷Lkµ¼óO:Ç,–VÔ$á„ñbÌ‹åC6¥„ÔRÍ“Î9éÄãÏ–\v¹%AÖçCÁ ”8Ä°B 5àhC 1!™˜P¼$^W!…–FHýP„bà™g?%¹"åF>,á„MEXè‰è.Q&Ž59št‘’ŸJ8qÉ,îhzQ3¿0ƒX!ù ÿ,þÿ Hpà/WÍÖ\Èà´'3 qÓ6fáU=ãd3Î;Q äÈD\¶}\95¨4‚Ê,Ô3Ë,ü-„؃å¶Cv~>Õ‡Fˆqh ƒ’¤‰ ‡šdKv4J˜†•I#1‰zc&âX:? úΨæ<ÙR@!ù ÿ,þÿ Hà¤_*,øKˆ† 0pÀAt 3ŽˆÈ±cÄ/ze$ˆã€Ç“ ùo#Ê—qhT0ⓘˆò…BnÌ j2 £À4z²,H«)-¿’v,€0¡† d´ÂÕÊR9Ž(¨cW>ý Ö•+<ºè’¢@*\®ikå-7œÇþK“Òç)yÿÑâëõß‹Ž B¤˜€Ô¿1pªh¹ò1_t¿"(áߤ$|ƒöçÏ 6`àü ØV?Ž2˜#\@Á씎葩¼jÿƒx B bÿ $`‚żpÉ׫÷O Þ®Oì4ÁÂô"VX?—½±|¢þE˳å â`òd(Á‚µ üÖ8ô BÜ?Ö"ÐpƒÒF>Õœ  4à ý±Ð‡|Ãùò&…\óO+Ùeó$²ÀŠ@¦¤¸Â<þt¢ {…tòÏ;b"Є,18)öø<f“Ý8ÿ„ƒ <ÿDÑ_…9™¢ “¡ò4 ÍCCA˜35ᜳAÄÉ \@71™ô *\¢r‰6 õ¡fŠ_îÉ õ“ˆŸ„þÉ1}šá%gΓ…¢,DΙ™‘hA4BiFÚt:éR;clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/repl/dots.png000066400000000000000000000006651161102570000317270ustar00rootroot00000000000000‰PNG  IHDR ®t‚ésRGB®ÎétIMEØ ~”Ÿ\IDATHÇíÔÁJ”QÆáç˱ ‚ ,BtQøé”!c‚¶nÑJ(Â[i“àm¸Iº€a‹Üv‘n&jSˆå|XæÛ±vF-"ÄgùãÏ9çp¨r0‹9l`#óhú[1'bBÌø7š‹a5lD ¥¸&nˆ[ú#ém–2Qî,§7*¥˜Ô㋶oZâµ- Y·)ŽýO泚Á0ÐÜÈb”¿J×Rʈž‘ÎrNƶúRÆ"ZÎ<·ˆ“"n»Ò-×]U+Ð0ªðÖ'£Îhûà„¦]mŸ/àØQSNÜ]ª.=mŒÿIùiüÙüʽÌæT<ú]©Çc uÔ`½ºoÏ{{Ð0ls­Z@û \–µñn¿œ6¤®ß1mEÇŠ9fµôóDå¹›fL;§0é…ÊKw´L¹ O]Qt(4ºŸÃ®A¡ÏYßU¶ö·Eºš¯Ý ðLí —× …OIEND®B`‚clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/repl/repl.cljs000066400000000000000000000041721161102570000320640ustar00rootroot00000000000000(ns jsrepl) (def append-dom) (defn dom [o] (if (coll? o) (let [[tag attrs & body] o] (if (keyword? tag) (let [elem (.createElement document (name tag))] (when (map? attrs) (doseq [[k v] attrs] (when v (.setAttribute elem (name k) v)))) [(append-dom elem (if (map? attrs) body (cons attrs body)))]) (mapcat dom o))) (when o [(.createTextNode document (str o))]))) (defn append-dom [parent v] (doseq [i (dom v)] (.appendChild parent i)) parent) (def *print-class* nil) (defn repl-print [log text] (doseq [line (.split text #"\n")] (append-dom log [:div {:class (str "cg " (when *print-class* (str " " *print-class*)))} line])) (set! (.scrollTop log) (.scrollHeight log))) (defn postexpr [log input] (append-dom log [:table [:tbody [:tr [:td {:class "cg"} "user=> "] [:td (.replace (.value input) #"\n$" "")]]]])) (defmacro print-with-class [c m] `(binding [*print-class* ~c] (println ~m))) (set! *print-length* 103) (defmacro let-elem-ids [ids & body] `(let ~(vec (mapcat #(list % (list '.getElementById 'document (str %))) ids)) ~@body)) (set! (.onload window) (fn [] (let-elem-ids [log input status applet] (set! (.print window) #(repl-print log %)) (set! (.onkeypress input) (fn [ev] (when (== (.keyCode (or ev event)) 13) (let [[status-name text] (.tojs applet (.value input))] (if (= status-name "incomplete") (set! (.src status) "dots.png") (do (postexpr log input) (if (= status-name "js") (try (prn (.eval window text)) (catch Exception e (print-with-class "err" e) (set! *e e))) (print-with-class "err" text)) (setTimeout #(set! (.value input) "") 0) (set! (.src status) "blank.gif"))))))) (println "ClojureScript") (.focus input)))) clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/repl/repl.html000066400000000000000000000027021161102570000320720ustar00rootroot00000000000000 ClojureScript REPL
user=> 
clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/repl/repl.js000066400000000000000000000142431161102570000315450ustar00rootroot00000000000000(function(){ return (clojure.core.in_ns.apply(null,[clojure.core.symbol("jsrepl")]), clojure.core.refer.apply(null,[clojure.core.symbol("clojure.core")]))}).apply(null,[]); (function(){ return (clojure.JS.def(jsrepl,"append_dom",null))}).apply(null,[]); (function(){ return (clojure.JS.def(jsrepl,"dom",(function(o_1){ var elem_6,v_10,sq__3775__auto___7,k_9,vec__534_8,attrs_4,vec__533_2,body_5,tag_3; return (((clojure.core.coll_QMARK_.apply(null,[o_1]))?(((vec__533_2=o_1), (tag_3=clojure.core.nth.apply(null,[vec__533_2,(0),null])), (attrs_4=clojure.core.nth.apply(null,[vec__533_2,(1),null])), (body_5=clojure.core.nthrest.apply(null,[vec__533_2,(2)])), ((clojure.core.keyword_QMARK_.apply(null,[tag_3]))?(((elem_6=(clojure.JS.resolveVar("document",jsrepl)).createElement(clojure.core.name.apply(null,[tag_3]))), ((clojure.core.map_QMARK_.apply(null,[attrs_4]))?(((function(){var _rtn,_cnt;(sq__3775__auto___7=clojure.core.seq.apply(null,[attrs_4]));do{_cnt=0; _rtn=((sq__3775__auto___7)?(((vec__534_8=clojure.core.first.apply(null,[sq__3775__auto___7])), (k_9=clojure.core.nth.apply(null,[vec__534_8,(0),null])), (v_10=clojure.core.nth.apply(null,[vec__534_8,(1),null])), ((true)?(((true)?(((v_10)?((elem_6).setAttribute(clojure.core.name.apply(null,[k_9]),v_10)):(null))):(null)), (_cnt=1,_rtn=[clojure.core.rest.apply(null,[sq__3775__auto___7])],sq__3775__auto___7=_rtn[0])):(null)))):(null))}while(_cnt);return _rtn;})())):(null)), clojure.JS.lit_vector([jsrepl.append_dom.apply(null,[elem_6,((clojure.core.map_QMARK_.apply(null,[attrs_4]))?(body_5):(clojure.core.cons.apply(null,[attrs_4,body_5])))])]))):(clojure.core.mapcat.apply(null,[jsrepl.dom,o_1]))))):(((o_1)?(clojure.JS.lit_vector([(clojure.JS.resolveVar("document",jsrepl)).createTextNode(clojure.core.str.apply(null,[o_1]))])):(null)))))})))}).apply(null,[]); (function(){ return (clojure.JS.def(jsrepl,"append_dom",(function(parent_1,v_2){ var sq__3775__auto___3,i_4; return (((function(){var _rtn,_cnt;(sq__3775__auto___3=clojure.core.seq.apply(null,[jsrepl.dom.apply(null,[v_2])]));do{_cnt=0; _rtn=((sq__3775__auto___3)?(((i_4=clojure.core.first.apply(null,[sq__3775__auto___3])), ((true)?(((true)?((parent_1).appendChild(i_4)):(null)), (_cnt=1,_rtn=[clojure.core.rest.apply(null,[sq__3775__auto___3])],sq__3775__auto___3=_rtn[0])):(null)))):(null))}while(_cnt);return _rtn;})()), parent_1)})))}).apply(null,[]); (function(){ return (clojure.JS.def(jsrepl,"_STAR_print_class_STAR_",null))}).apply(null,[]); (function(){ return (clojure.JS.def(jsrepl,"repl_print",(function(log_1,text_2){ var sq__3775__auto___3,line_4; return (((function(){var _rtn,_cnt;(sq__3775__auto___3=clojure.core.seq.apply(null,[(text_2).split((/\n/))]));do{_cnt=0; _rtn=((sq__3775__auto___3)?(((line_4=clojure.core.first.apply(null,[sq__3775__auto___3])), ((true)?(((true)?(jsrepl.append_dom.apply(null,[log_1,clojure.JS.lit_vector([clojure.core.keyword("","div"),clojure.core.hash_map(clojure.core.keyword("","class"),clojure.core.str.apply(null,["cg ",((jsrepl._STAR_print_class_STAR_)?(clojure.core.str.apply(null,[" ",jsrepl._STAR_print_class_STAR_])):(null))])),line_4])])):(null)), (_cnt=1,_rtn=[clojure.core.rest.apply(null,[sq__3775__auto___3])],sq__3775__auto___3=_rtn[0])):(null)))):(null))}while(_cnt);return _rtn;})()), (log_1.scrollTop=clojure.JS.getOrRun(log_1,"scrollHeight")))})))}).apply(null,[]); (function(){ return (clojure.JS.def(jsrepl,"postexpr",(function(log_1,input_2){ return (jsrepl.append_dom.apply(null,[log_1,clojure.JS.lit_vector([clojure.core.keyword("","table"),clojure.JS.lit_vector([clojure.core.keyword("","tbody"),clojure.JS.lit_vector([clojure.core.keyword("","tr"),clojure.JS.lit_vector([clojure.core.keyword("","td"),clojure.core.hash_map(clojure.core.keyword("","class"),"cg"),"user=> "]),clojure.JS.lit_vector([clojure.core.keyword("","td"),(clojure.JS.getOrRun(input_2,"value")).replace((/\n$/),"")])])])])]))})))}).apply(null,[]); (function(){ return (clojure.core._var__STAR_print_length_STAR_.set((103)))}).apply(null,[]); (function(){ return ((clojure.JS.resolveVar("window",jsrepl).onload=(function(){ var log_1,input_2,status_3,applet_4; return (((log_1=(clojure.JS.resolveVar("document",jsrepl)).getElementById("log")), (input_2=(clojure.JS.resolveVar("document",jsrepl)).getElementById("input")), (status_3=(clojure.JS.resolveVar("document",jsrepl)).getElementById("status")), (applet_4=(clojure.JS.resolveVar("document",jsrepl)).getElementById("applet")), (clojure.JS.resolveVar("window",jsrepl).print=(function(p1__586_1){ return (jsrepl.repl_print.apply(null,[log_1,p1__586_1]))})), (input_2.onkeypress=(function(ev_1){ var or__3114__auto___2,vec__596_2,status_name_3,text_4; return (((clojure.lang.Numbers.equiv(clojure.JS.getOrRun(((or__3114__auto___2=ev_1), ((or__3114__auto___2)?(or__3114__auto___2):(clojure.JS.resolveVar("event",jsrepl)))),"keyCode"),(13)))?(((vec__596_2=(applet_4).tojs(clojure.JS.getOrRun(input_2,"value"))), (status_name_3=clojure.core.nth.apply(null,[vec__596_2,(0),null])), (text_4=clojure.core.nth.apply(null,[vec__596_2,(1),null])), ((clojure.lang.Util.equiv(status_name_3,"incomplete"))?((status_3.src="dots.png")):(jsrepl.postexpr.apply(null,[log_1,input_2]), ((clojure.lang.Util.equiv(status_name_3,"js"))?((function(){ var e_3; return ((function(){try{var _rtn=(clojure.core.prn.apply(null,[(clojure.JS.resolveVar("window",jsrepl)).eval(text_4)]))} catch(e_3){_rtn=clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[jsrepl._var__STAR_print_class_STAR_,"err"])), (function(){ return ((function(){try{var _rtn=(clojure.core.println.apply(null,[e_3]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())}).apply(null,[]), clojure.core._var__STAR_e.set(e_3)}return _rtn})())}).apply(null,[])):(clojure.lang.Var.pushThreadBindings(clojure.core.hash_map.apply(null,[jsrepl._var__STAR_print_class_STAR_,"err"])), (function(){ return ((function(){try{var _rtn=(clojure.core.println.apply(null,[text_4]))} finally{clojure.lang.Var.popThreadBindings()}return _rtn})())}).apply(null,[]))), clojure.JS.resolveVar("setTimeout",jsrepl).apply(null,[(function(){ return ((input_2.value=""))}),(0)]), (status_3.src="blank.gif"))))):(null)))})), clojure.core.println.apply(null,["ClojureScript"]), clojure.JS.getOrRun(input_2,"focus")))})))}).apply(null,[]); clojure-contrib_1.2.0.orig/clojurescript/src/clojure/contrib/clojurescript/rt.js000066400000000000000000001776171161102570000303050ustar00rootroot00000000000000// Copyright (c) Chris Houser, Sep 2008 - Jan 2009. 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. // Runtime support for code generated by tojs.clj clojure = { JS: { global: this, merge: function( t, s ) { for( var i in s ) { t[ i ] = s[ i ]; } return t; }, Class: { classname: "clojure.JS.Class", hashCode: function() { return clojure.lang.Util.hash( this.classname ); }, isAssignableFrom: function(base) { return base.classset[this.classname];}, getSuperclass: function() { return this.extend || null; }, getInterfaces: function() { return this.implement || null; } } }, lang: { Namespace: function( n, m ) { this.name = n; // FIXME: this pollutes the namespace clojure.JS.merge( this, m || {} ); } } }; clojure.JS.Class.constructor = clojure.JS.Class; clojure.JS.Class.classset = { Class: true }; if( ! clojure.JS.global["java"] ) { java = { lang: { String: {}, Character: {}, Class: {}, Number: {}, Boolean: {} }, math: { BigDecimal: {} }, util: { Collection: {}, Map: {}, Set: {}, regex: { Pattern: {} } } }; } clojure = { JS: { merge: clojure.JS.merge, global: clojure.JS.global, Class: clojure.JS.Class, objectType: typeof {}, functionType: typeof function(){}, stringType: typeof "", numberType: typeof 0, variadic: function( arity, f ) { f.arity = arity; f.isVariadic = true; return f; }, resolveVar: function( sym, ctxns ) { return ctxns[ sym ] || clojure[ sym ] || clojure.JS.global[ sym ]; }, def: function( ns, name, init ) { var v = new clojure.lang.Var( ns, name ); ns["_var_" + name] = v; v.push( init ); return v; }, variadic_sentinel: {}, rest_args: function( varflag, args, i ) { if( varflag === clojure.JS.variadic_sentinel ) return args[ args.length - 1 ]; return new clojure.lang.ArraySeq( null, args, i ); }, invoke: function( obj, methodname, args ) { return obj[ methodname ].apply( obj, args ); }, getOrRun: function( obj, prop ) { var val = obj[ prop ]; if( typeof val === clojure.JS.functionType || (typeof val === clojure.JS.objectType && "apply" in val) ) { return val.apply( obj, [] ); } return val; }, lit_list: function( a ) { if( a.length > 0 ) return new clojure.lang.ArraySeq( null, a, 0 ); return clojure.lang.PersistentList.EMPTY; }, lit_vector: function( a ) { return clojure.lang.LazilyPersistentVector.createOwning( a ); }, implement: function( cls, name, extend, implement ) { clojure.JS.merge( cls, clojure.JS.Class ); cls.classname = name; cls.extend = extend; cls.implement = implement; cls.classset = {}; cls.classset[ name ] = true; if( implement ) { for( var i = 0; i < implement.length; ++i ) { if( ! implement[ i ] ) throw "Can't implement null: " + name; clojure.JS.merge( cls.classset, implement[ i ].classset ); } } }, definterface: function( pkg, name, implement ) { var cls = pkg[ name ] = {}; clojure.JS.implement( cls, name, null, implement ); return cls; }, defclass: function( pkg, name, opts ) { var cls = pkg[ name ] = opts.init || function() {}; clojure.JS.implement( cls, name, opts.extend, opts.implement ); if( 'extend' in opts ) { cls.prototype = new opts.extend; cls.prototype.constructor = cls; clojure.JS.merge( cls.classset, opts.extend.classset ); } if( opts.statics ) { clojure.JS.merge( cls, opts.statics ); } if( opts.methods ) { clojure.JS.merge( cls.prototype, opts.methods ); } return cls; }, instanceq: function( c, o ){ if( o === null ) return false; if( typeof o === clojure.JS.functionType && ! ("constructor" in o) ) return false; // a Java class? if( o.constructor === c ) return true; if( ! o.constructor.classset ) return false; // builtin class that doesn't match? return o.constructor.classset[ c.classname ]; }, relayPrintMethod: function( jsclass, javaclass, ctor ) { var m = clojure.core.print_method; m.addMethod( jsclass, function(o,w) { return (clojure.core.get( m.methodTable, javaclass ) .apply(null, [ctor ? ctor(o) : o, w])); }); }, bitcount: function(n){ var rtn = 0; for( ; n; n >>= 1) { rtn += n & 1; } return rtn; }, ObjSeq: { create: function( obj ) { var i, pairs = []; for( i in obj ) { pairs.push( [i, obj[i]] ); } return clojure.lang.ArraySeq.create( pairs ); } } }, lang: { Namespace: clojure.lang.Namespace, Numbers: { isZero: function(x) { return x === 0; }, isPos: function(x) { return x > 0; }, isNeg: function(x) { return x < 0; }, minus: function(x,y) { return y === undefined ? -x : x - y; }, inc: function(x) { return x + 1; }, dec: function(x) { return x - 1; }, add: function(x,y) { return x + y; }, multiply: function(x,y) { return x * y; }, divide: function(x,y) { return x / y; }, quotient: function(x,y) { return parseInt(x / y); }, remainder: function(x,y) { return x % y; }, equiv: function(x,y) { return x == y; }, lt: function(x,y) { return x < y; }, lte: function(x,y) { return x <= y; }, gt: function(x,y) { return x > y; }, gte: function(x,y) { return x >= y; }, compare: function(x,y) { return (x> 2)); }, equal: function(x,y) { return x == y; }, equiv: function(x,y) { if( x == y ) return true; if( x !== null ) { if( typeof x == clojure.JS.numberType ) return clojure.lang.Numbers.equiv(x,y); else if( x.equiv && y.equiv ) return x.equiv( y ); else if( x.equals ) return x.equals( y ); } return false; }, isInteger: function(x) { return typeof x == clojure.JS.numberType; } }, RT: { EMPTY_ARRAY: [], conj: function( coll, x ) { if( coll === null ) return new clojure.lang.PersistentList( null, x ); return coll.cons( x ); }, seqToArray: function(s) { var i = 0, ret = new Array( clojure.count( s ) ); for( ; s !== null; ++i, s = s.rest() ) ret[ i ] = s.first(); return ret; }, intCast: function(i) { return parseInt(i); }, makeStringBuilder: function(s) { return new clojure.JS.StringBuilder( s===undefined ? "" : s ); }, className: function(c) { if( "classname" in c ) return c.classname; if( "name" in c ) return c.name; var s = "" + c, m = /^\[JavaClass (.*)]$/.exec(s); if( m ) return m[1]; return s; }, simpleClassName: function(c) { // FIXME: should generate simple name return clojure.lang.RT.className(c); } } } }; clojure.core = new clojure.lang.Namespace("clojure.core",{ in_ns: function(s) { var i, nsparts = s.getName().split('.'), base = clojure.JS.global; for( i = 0; i < nsparts.length; ++i ) { if( ! base[nsparts[i]] ) { base[nsparts[i]] = new clojure.lang.Namespace(nsparts[i]); } base = base[nsparts[i]]; } }, refer: function(s) {}, load: function(s) {}, seq: function(coll){ if( coll === null ) return null; else if( coll.seq ) return coll.seq(); //else if( coll.constructor === String ) // return clojure.lang.StringSeq.create(coll); else if( typeof coll.length == clojure.JS.numberType ) return clojure.lang.ArraySeq.create(coll); else if( typeof coll === clojure.JS.objectType ) return clojure.JS.ObjSeq.create(coll); throw ("Don't know how to create ISeq from: " + (typeof coll) + " " + coll.constructor.name); }, apply: function( f ) { var i, newargs = [], s, eagercount, oldargs = arguments, arglen = oldargs.length; if( f.isVariadic ) { // lazy eagercount = Math.min( f.arity, arglen - 2 ); for( i = 0; i < eagercount; ++i ) { newargs.push( oldargs[ i + 1 ] ); } if( eagercount == f.arity ) { if( arglen - eagercount < 3 ) { newargs.push( clojure.core.seq( oldargs[ arglen - 1 ] ) ); } else { newargs.push( clojure.core.concat( new clojure.lang.ArraySeq( null, oldargs, eagercount + 1, arglen - 1 ), oldargs[ arglen - 1 ] ) ); } } else { s = clojure.core.seq( oldargs[ arglen - 1 ] ); for( ; s && newargs.length < f.arity; s = s.rest() ) { newargs.push( s.first() ); } if( s ) newargs.push( s ); } return f.apply( clojure.JS.variadic_sentinel, newargs ); } else { // non-lazy for( i = 1; i < arglen - 1; ++i ) { newargs.push( oldargs[ i ] ); } for( s = oldargs[ arglen - 1]; s; s = s.rest()) { newargs.push( s.first() ); } return f.apply( null, newargs ); } }, first: function(x) { if( x === null ) return null; if( x.first ) return x.first(); var seq = clojure.core.seq( x ); if( seq === null ) return null; return seq.first(); }, rest: function(x) { if( x === null ) return null; if( x.rest ) return x.rest(); var seq = clojure.core.seq( x ); if( seq === null ) return null; return seq.rest(); }, second: function(x) { return clojure.first(clojure.rest(x)); }, cons: function( x, coll ) { var y = clojure.core.seq( coll ); if( y === null ) return new clojure.lang.PersistentList( null, x ); return y.cons( x ); }, instance_QMARK_: function( c, o ) { return clojure.JS.instanceq( c, o ); }, class_QMARK_: function(o) { return clojure.JS.instanceq(clojure.JS.Class,o);}, number_QMARK_: function(o) { return clojure.JS.instanceq( Number, o ); }, string_QMARK_: function(o) { return clojure.JS.instanceq( String, o ); }, integer_QMARK_: function(o) { return parseInt( o ) === o; }, find: function(coll, key) { if( coll == null ) return null; else if( coll.containsKey ) { if( coll.containsKey( key ) ) return new clojure.lang.MapEntry( key, coll.get( key ) ); return null; } return coll.entryAt( key ); }, get: function(coll, key, notFound ) { var usenull = notFound === undefined; if( coll === null ) return usenull ? null : notFound; if( coll.valAt ) return coll.valAt( key, notFound ); if( coll.containsKey ) return (usenull || coll.containsKey( key )) ? coll.get( key ) : notFound; if( coll.contains ) return (usenull || coll.contains( key )) ? coll.get( key ) : notFound; return (usenull || key in coll) ? coll[ key ] : notFound; }, nth: function(coll, n, notFound) { var usenull = (notFound === undefined), seq, i; if( coll === null ) return usenull ? null : notFound; if( coll.nth ) return usenull || n < coll.count() ? coll.nth(n) : notFound; if( coll.get ) return usenull || n < coll.size() ? coll.get(n) : notFound; if( coll.seq ) { for( seq = coll.seq(), i = 0; i <= n && seq; seq = seq.rest() ) { if( i == n ) return seq.first(); } if( usenull ) throw "IndexOutOfBoundsException"; return notFound; } return usenull || n < coll.length ? coll[n] : notFound; }, contains_QMARK_: function(coll, key) { if( coll === null ) return false; if( coll.containsKey ) return coll.containsKey( key ) ? true : false; if( coll.contains ) return coll.contains( key ) ? true : false; return key in coll; }, hash_map: function() { return clojure.lang.PersistentHashMap.create( arguments ); }, hash_set: function() { return clojure.lang.PersistentHashSet.create( arguments ); }, to_array: function(coll){ if( coll === null ) return clojure.lang.RT.EMPTY_ARRAY; if( coll.toArray ) return coll.toArray(); if( typeof coll === clojure.JS.stringType ) { var i = 0, rtn = new Array( coll.length ); for( ; i < coll.length; ++i ) { rtn[i] = coll[i]; } return rtn; } if( coll.constructor === Array ) { return coll.slice(0); } throw "Unable to convert: " + coll.constructor.classname + " to Array"; }, keyword: function(a,b) { if( b === undefined ) return clojure.lang.Keyword.intern( null, a ); return clojure.lang.Keyword.intern( a, b ); }, symbol: function(a,b) { if( b === undefined ) return clojure.lang.Symbol.intern( null, a ); return clojure.lang.Symbol.intern( a, b ); }, assoc: function( coll, key, val ) { if( coll === null ) return new clojure.lang.PersistentArrayMap([key, val]); return coll.assoc( key, val ); }, count: function(x) { if( x === null ) return 0; if( x.count ) return x.count(); if( x.length != undefined ) return x.length; throw ("count not supported on: " + (typeof x) + " " + x.constructor); }, class_: function(o) { if( o === null || o === undefined ) return null; if( typeof o === clojure.JS.functionType && ! ("constructor" in o) ) return java.lang.Class; return o.constructor || typeof o; }, import_: function() { // do nothing }, identical_QMARK_: function( a, b ) { return a === b; }, keys: function(coll) { return clojure.lang.APersistentMap.KeySeq.create(clojure.core.seq(coll)); }, vals: function(coll) { return clojure.lang.APersistentMap.ValSeq.create(clojure.core.seq(coll)); } }); clojure.JS.definterface( clojure.JS, "Collection" ); clojure.JS.defclass( clojure.JS, "StringBuilder", { init: function( x ) { this.a = [ x ]; }, methods: { append: function( x ) { this.a.push( x ); return this; }, toString: function() { return this.a.join(''); } } }); clojure.JS.defclass( clojure.JS, "String", { init: function(s) { this.s = s; this.length = s.length; }, methods: { charAt: function(x) { return this.s.charAt(x); }, toString: function() { return this.s; } } }); clojure.JS.definterface( clojure.lang, "IObj" ); clojure.JS.definterface( clojure.lang, "IMeta" ); clojure.JS.defclass( clojure.lang, "Obj", { implement: [ clojure.lang.IObj ], init: function(_meta) { this._meta = _meta; }, methods: { meta: function() { return this._meta; } } }); clojure.JS.definterface( clojure.lang, "IReduce" ); clojure.JS.definterface( clojure.lang, "IPersistentCollection" ); clojure.JS.definterface( clojure.lang, "ISeq", [clojure.lang.IPersistentCollection] ); clojure.JS.definterface( clojure.lang, "IndexedSeq", [clojure.lang.ISeq] ); clojure.JS.defclass( clojure.lang, "ASeq", { implement: [clojure.lang.ISeq], methods: { equals: function( obj ) { var s = this.seq(), ms = obj.seq(); for( ; s !== null; s = s.rest(), ms = ms.rest() ) { if( ms === null || !clojure.lang.Util.equal( s.first(), ms.first() )) return false; } if( ms !== null ) return false; return true; }, hashCode: function() { throw "not yet implemented"; }, count: function() { var i = 1, s = this.rest(); for( ; s; s = s.rest() ) i += 1; return i; }, seq: function(){ return this; }, cons: function(o){ return new clojure.lang.Cons( null, o, this ); }, toArray: function(){ return clojure.lang.RT.seqToArray( this.seq() ); }, containsAll: function(c){ throw "not yet implemented"; }, size: function(){ return this.count(); }, isEmpty: function(){ return this.count() == 0; }, contains: function(c){ throw "not yet implemented"; } } }); clojure.JS.defclass( clojure.lang, "Cons", { extend: clojure.lang.ASeq, init: function( _meta, _first, _rest ) { this._meta = _meta; this._first = _first; this._rest = _rest; }, methods: { first: function(){ return this._first; }, rest: function(){ return this._rest; }, count: function(){ return 1 + clojure.count( this._rest ); }, seq: function(){ return this; }, withMeta: function(_meta){ return new clojure.lang.Cons( _meta, this._first, this._rest ); } } }); clojure.JS.defclass( clojure.lang, "ArraySeq", { extend: clojure.lang.ASeq, implement: [clojure.lang.IndexedSeq, clojure.lang.IReduce], init: function( _meta, a, i, len ) { this._meta = _meta; this.a = a; this.i = i; this.len = (len === undefined) ? a.length : len; }, statics: { create: function( a ) { if( a && a.length ) return new clojure.lang.ArraySeq( null, a, 0 ); return null; } }, methods: { first: function() { return this.a[this.i]; }, rest: function() { if( this.i + 1 < this.len ) return new clojure.lang.ArraySeq( this._meta, this.a, this.i + 1, this.len); return null; }, count: function() { return this.len - this.i; }, index: function() { return this.i; }, withMeta: function( _meta ) { return new clojure.lang.ArraySeq( _meta, this.array, this.i, this.len ); }, reduce: function( fn, start ) { var ret = (start===undefined) ? this.a[this.i] : fn(start,this.a[this.i]), x = this.i + 1; for( ; x < this.len; ++x ) { ret = fn( ret, this.a[x] ); } return ret; }, seq: function() { return this; } } }); clojure.JS.defclass( clojure.lang, "LazyCons", { extend: clojure.lang.ASeq, init: function(f,_first,_rest) { this.f = f; this._first = _first === undefined ? clojure.lang.LazyCons.sentinel :_first; this._rest = _rest === undefined ? clojure.lang.LazyCons.sentinel :_rest; }, statics: { sentinel: {} }, methods: { first: function() { if( this._first === clojure.lang.LazyCons.sentinel ) this._first = this.f(); return this._first; }, rest: function() { if( this._rest === clojure.lang.LazyCons.sentinel ) { if( this._first === clojure.lang.LazyCons.sentinel ) { this.first(); } this._rest = clojure.core.seq( this.f(null) ); this.f = null; } return this._rest; }, withMeta: function(_meta) { if( _meta == this.meta() ) return this; //force before copying this.rest(); return new clojure.lang.LazyCons( _meta, this._first, this._rest ); }, seq: function() { return this; } } }); clojure.JS.defclass( clojure.lang, "Var", { init: function( ns, name ) { this.ns = ns; this.name = name; this.stack = []; }, statics: { stack: [], pushThreadBindings: function( m ) { var vars=[], bs = m.seq(), e; for( ; bs; bs = bs.rest()) { e = bs.first(); vars.push( e.key() ); e.key().push( e.val() ); } clojure.lang.Var.stack.push( vars ); }, popThreadBindings: function() { var i = 0, vars = clojure.lang.Var.stack.pop(); for( ; i < vars.length; ++i ) { vars[i].pop(); } } }, methods: { push: function( val ) { this.stack.push( val ); this.ns[ this.name ] = val; }, pop: function() { this.stack.pop(); this.ns[ this.name ] = this.stack[ this.stack.length - 1 ]; }, set: function( val ) { this.stack.pop(); this.push( val ); }, get: function() { return this.ns[ this.name ]; }, hasRoot: function() { return this.stack.length > 0; }, toString: function() { if( this.ns !== null ) return "#=(var " + this.ns.name + "/" + this.name + ")"; return "#"; }, hashCode: function() { return clojure.lang.Util.hash( this.ns + "/" + this.name ); } } }); clojure.JS.definterface( clojure.lang, "IFn" ); clojure.JS.defclass( clojure.lang, "AFn", { extend: clojure.lang.Obj, implement: [clojure.lang.IFn], methods: { apply: function( obj, args ){ return this.invoke.apply( this, args ); } } }); clojure.JS.definterface( clojure.lang, "IPersistentStack", [clojure.lang.IPersistentCollection] ); clojure.JS.definterface( clojure.lang, "Sequential" ); clojure.JS.definterface( clojure.lang, "Reversible" ); clojure.JS.definterface( clojure.lang, "Named" ); clojure.JS.defclass( clojure.lang, "Keyword", { extend: clojure.lang.AFn, implement: [clojure.lang.Named], init: function( ns, name ) { this._ns = ns; this._name = name; }, statics: { table: {}, intern: function( ns, name ) { var key = (ns || "") + "/" + name, obj = clojure.lang.Keyword.table[ key ]; if( obj ) return obj; return clojure.lang.Keyword.table[ key ] = new clojure.lang.Keyword( ns, name ); } }, methods: { toString: function() { return ":" + (this.ns ? this.ns+"/" : "") + this._name; }, compareTo: function(o) { if( this == o ) return 0; if( this._ns === null && o._ns !== null ) return -1; if( this._ns !== null ) { if( o._ns === null ) return 1; var nsc = clojure.JS.compare(this._ns, o._ns); if( nsc !== 0 ) return nsc; } return clojure.JS.compare(this._name, o._name); }, getNamespace: function() { return this._ns; }, getName: function() { return this._name; }, hashCode: function() { return clojure.lang.Util.hash( this._ns + "/" + this._name ); }, invoke: function(coll, notFound) { return clojure.core.get( coll,this,notFound);} } }); clojure.JS.defclass( clojure.lang, "Ratio", {} ); clojure.JS.defclass( clojure.lang, "Symbol", { extend: clojure.lang.AFn, implement: [clojure.lang.Named], init: function( ns, name ) { this._ns = ns; this._name = name; }, statics: { table: {}, intern: function( ns, name ) { var key = (ns || "") + "/" + name, obj = clojure.lang.Symbol.table[ key ]; if( obj ) return obj; return clojure.lang.Symbol.table[ key ] = new clojure.lang.Symbol( ns, name ); } }, methods: { toString: function() { return (this.ns ? this.ns+"/" : "") + this._name; }, compareTo: function(o) { if( this == o ) return 0; if( this._ns === null && o._ns !== null ) return -1; if( this._ns !== null ) { if( o._ns === null ) return 1; var nsc = clojure.JS.compare(this._ns, o._ns); if( nsc !== 0 ) return nsc; } return clojure.JS.compare(this._name, o._name); }, getNamespace: function() { return this._ns; }, getName: function() { return this._name; }, hashCode: function() { return clojure.lang.Util.hash( this._ns + "/" + this._name ); }, invoke: function(coll, notFound) { return clojure.core.get( coll,this,notFound); } } }); clojure.JS.definterface( clojure.lang, "IPersistentList", [clojure.lang.Sequential, clojure.lang.IPersistentStack] ); clojure.JS.defclass( clojure.lang, "EmptyList", { extend: clojure.lang.Obj, implement: [clojure.lang.IPersistentList, clojure.JS.Collection], init: function( _meta ) { this._meta = _meta; }, methods: { cons: function(o) { return new clojure.lang.PersistentList( this.meta(), o ); }, empty: function() { return this; }, withMeta: function(m) { if( m != this.meta() ) return new clojure.lang.EmptyList( m ); return this; }, peek: function() { return null; }, pop: function() { throw "Can't pop empty list"; }, count: function() { return 0; }, seq: function() { return null; }, size: function() { return 0; }, isEmpty: function() { return true; }, contains: function() { return false; }, toArray: function() { return clojure.lang.RT.EMPTY_ARRAY; }, containsAll: function( coll ) { return coll.isEmpty(); } } }); clojure.JS.definterface( clojure.lang, "IMapEntry" ); clojure.JS.definterface( clojure.lang, "Associative", [ clojure.lang.IPersistentCollection ] ); clojure.JS.definterface( clojure.lang, "IPersistentVector", [ clojure.lang.Associative, clojure.lang.Sequential, clojure.lang.IPersistentStack, clojure.lang.Reversible ]); clojure.JS.defclass( clojure.lang, "AMapEntry", { implement: [ clojure.lang.IMapEntry, clojure.lang.IPersistentVector ], methods: { empty: function(){ return null; }, equals: function(o){ return clojure.lang.APersistentVector.doEquals(this,o); }, hashCode: function(){ throw "not implemented yet"; }, toString: function(){ return this.key() + " " + this.val(); var sw = new clojure.JS.StringWriter(); clojure.lang.RT.print( this, sw ); return sw.toString(); }, length: function(){ return 2; }, nth: function(i){ switch(i){ case 0: return this.key(); case 1: return this.val(); default: throw "Index out of bounds"; } }, asVector: function(){ return clojure.lang.LazilyPersistentVector.createOwning( this.key(), this.val() ); }, assocN: function(i,v){ return this.asVector().assocN(i,v); }, count: function(){ return 2; }, seq: function(){ return this.asVector().seq(); }, cons: function(o){ return this.asVector().cons(o); }, containsKey: function(k){ return this.asVector().containsKey(k); }, entryAt: function(k){ return this.asVector().entryAt(k); }, assoc: function(k,v){ return this.asVector().assoc(k,v); }, valAt: function(k,notFound){ return this.asVector().valAt(k,notFound); }, peek: function(){ return this.val(); }, pop: function(){ return clojure.lang.LazilyPersistentVector.createOwning( this.key() ); }, rseq: function(){ return this.asVector().rseq(); } } }); clojure.JS.defclass( clojure.lang, "MapEntry", { extend: clojure.lang.AMapEntry, init: function(k,v){ this._key = k; this._val = v; }, methods: { key: function(){ return this._key; }, val: function(){ return this._val; }, getKey: function(){ return this._key; }, getValue: function(){ return this._val; } } }); clojure.JS.defclass( clojure.lang, "PersistentList", { extend: clojure.lang.ASeq, implement: [clojure.lang.IPersistentList, clojure.lang.IReduce], init: function( _meta, _first, _rest, _count ) { this._meta = _meta || null; this._first = _first; this._rest = _rest || null; this._count = _count || 1; }, statics: { creator: clojure.JS.variadic(0,function(){ var args = clojure.JS.rest_args(this,arguments,0), ret, i; if( clojure.JS.instanceq( clojure.lang.ArraySeq, args ) ) { ret = clojure.lang.PersistentList.EMPTY; for( i = args.a.length - 1; i >= 0; --i ) { ret = ret.cons( args.a[ i ] ); } return ret; } throw "Not yet implemented: clojure.lang.PersistentList.creator with non-ArraySeq"; }), EMPTY: new clojure.lang.EmptyList(null) }, methods: { first: function(){ return this._first; }, rest: function(){ if( this._count == 1 ) return null; return this._rest; }, peek: function(){ return this.first; }, pop: function(){ if( this._rest === null ) return this.empty(); return this._rest; }, count: function(){ return this._count; }, cons: function(o){ return new clojure.lang.PersistentList( this._meta, o, this, this._count + 1 ); }, empty: function(){ return clojure.lang.PersistentList.EMPTY.withMeta( this._meta ); }, withMeta: function( _meta ){ if( _meta != this._meta ) return new clojure.lang.PersistentList( this._meta, this._first, this._rest, this._count ); return this; }, reduce: function( f, start ){ var ret = (start === undefined) ? this.first() : f( start, this.first() ), s = this.rest(); for( ; s !== null; s = s.rest() ) ret = f( ret, s.first() ); return ret; } } }); clojure.JS.defclass( clojure.lang, "APersistentVector", { extend: clojure.lang.AFn, implement: [clojure.lang.IPersistentVector], init: function( _meta ) { this._meta = _meta; }, methods: { meta: function() { return this._meta; }, peek: function() { if( this.count() > 0 ) return this.nth( this.count() - 1 ); return null; }, seq: function() { if( this.count() > 0 ) return new clojure.lang.APersistentVector.Seq( null, this, 0 ); return null; }, rseq: function() { if( this.count() > 0 ) return new clojure.lang.APersistentVector.RSeq( null, this, this.count() - 1); return null; }, equals: function() { throw "not implemented yet"; }, hashCode: function() { throw "not implemented yet"; }, get: function(i) { return this.nth(i); }, indexOf: function( o ){ var i = 0, len = this.count(); for( ; i < len; ++i ) if( clojure.lang.Util.equal( this.nth( i ), o ) ) return i; return -1; }, lastIndexOf: function( o ){ for( var i = this.count() - 1; i >= 0; --i ) if( clojure.lang.Util.equal( this.nth( i ), o ) ) return i; return -1; }, subList: function( fromi, toi ) { return clojure.lang.RT.subvec( this, fromi, toi ); }, invoke: function( i ) { if( clojure.lang.Util.isInteger(i) ) return this.nth( parseInt( i ) ); throw "Key must be integer"; }, peek: function() { if( this.count() > 0 ) return this.nth( this.count() - 1 ); return null }, constainsKey: function(k){ if( ! clojure.lang.Util.isInteger( k ) ) return false; var i = parseInt(k); return i >= 0 && i < this.count(); }, entryAt: function(k){ if( clojure.lang.Util.isInteger( k ) ) { var i = parseInt(k); if( i >= 0 && i < this.count() ) return new clojure.lang.MapEntry( k, this.nth(i) ); } return null; }, assoc: function(k,v){ if( clojure.lang.Util.isInteger( k ) ) { var i = parseInt(k); return this.assocN(i,v); } throw "Key must be integer"; }, valAt: function(k, notFound){ if( clojure.lang.Util.isInteger( k ) ) { var i = parseInt(k); if( i >= 0 && i < this.count() ) return this.nth(i); } if( notFound === undefined ) return null; return notFound; }, toArray: function(){ return clojure.lang.RT.seqToArray( this.seq() ); }, containsAll: function(){ throw "not implemented yet"; }, size: function(){ return this.count(); }, isEmpty: function(){ return this.count() === 0; }, contains: function(o){ for( var s = this.seq(); s !== null; s = s.rest() ) { if( clojure.lang.Util.equal( s.first(), o ) ) return true; } return false; }, length: function(){ return this.count(); }, compareTo: function(v){ var i, c, len = this.count(); if( len < v.count() ) return -1; else if( len > v.count() ) return 1; for( i = 0; i < len; ++i ) { c = this.nth(i).compareTo( v.nth(i) ); if( c != 0 ) return c; } return 0; } } }); clojure.JS.defclass( clojure.lang.APersistentVector, "Seq", { extend: clojure.lang.ASeq, implement: [clojure.lang.IndexedSeq, clojure.lang.IReduce], init: function( _meta, v, i){ this._meta = _meta; this.v = v; this.i = i; }, methods: { seq: function(){ return this; }, first: function(){ return this.v.nth(this.i); }, rest: function(){ if( this.i + 1 < this.v.count() ) return new clojure.lang.APersistentVector.Seq( this._meta, this.v, this.i + 1 ); return null; }, index: function(){ return this.i; }, count: function(){ return this.v.count() - this.i; }, withMeta: function(_meta){ return new clojure.lang.APersistentVector.Seq( _meta, this.v, this.i ); }, reduce: function( fn, start ) { var ret = (start === undefined) ? this.v.nth(this.i) : fn(start,this.v.nth(this.i)), x = this.i + 1; for( ; x < this.count(); ++x ) { ret = fn( ret, this.v.nth(x) ); } return ret; } } }); clojure.JS.defclass( clojure.lang.APersistentVector, "RSeq", { init: function( _meta, v, i){ this._meta = _meta; this.v = v; this.i = i; }, methods: { seq: function(){ return this; }, first: function(){ return this.v.nth(this.i); }, rest: function(){ if( this.i > 0 ) return new clojure.lang.APersistentVector.RSeq( this._meta, this.v, this.i - 1 ); return null; }, index: function(){ return this.i; }, count: function(){ return this.i + 1; }, withMeta: function(_meta){ return new clojure.lang.APersistentVector.RSeq( _meta, this.v, this.i ); } } }); clojure.JS.defclass( clojure.lang, "LazilyPersistentVector", { extend: clojure.lang.APersistentVector, init: function( _meta, ary, v ) { this._meta = _meta; this.ary = ary; this._v = v; }, statics: { createOwning: function(ary) { if(ary.length === 0) return clojure.lang.PersistentVector.EMPTY; return new clojure.lang.LazilyPersistentVector( null, ary, null ); }, create: function(coll) { return clojure.lang.LazilyPersistentVector.createOwning(coll.toArray()); } }, methods: { toArray: function() { return this.ary; }, nth: function(i) { return this.ary[i]; }, assocN: function(i,val) { return this.v().assoc(i,val); }, count: function() { return this.ary.length; }, cons: function(o) { return this.v().cons(o); }, empty: function() { return clojure.lang.PersistentVector.EMPTY.withMeta(this._meta); }, pop: function() { return this.v().pop(); }, v: function() { if( this._v === null ) this._v = clojure.lang.PersistentVector.create(this.ary); return this._v; }, withMeta: function(meta) { if( meta != this._meta ) return new clojure.lang.LazilyPersistentVector( meta, this.ary, this.v ); return this; } } }); clojure.JS.defclass( clojure.lang, "PersistentVector", { extend: clojure.lang.APersistentVector, init: function( _meta, cnt, shift, root, tail ) { clojure.lang.APersistentVector.call( this, _meta ); this.cnt = cnt; this.shift = shift; this.root = root; this.tail = tail; }, statics: { create: function( items ) { var i = 0, ret = clojure.lang.PersistentVector.EMPTY; for( ; i < items.length; ++i ) { ret = ret.cons( items[ i ] ); } return ret; } }, methods: { tailoff: function() { return this.cnt - this.tail.length; }, nth: function( i ) { if( i >= 0 && i < this.cnt ) { if( i >= this.tailoff() ) { return this.tail[ i & 0x01f ]; } var arr = this.root, level = this.shift; for( ; level > 0; level -= 5 ) { arr = arr[ (i >>> level) & 0x01f ]; } return arr[ i & 0x01f ]; } throw "IndexOutOfBoundsException"; }, assocN: function( i, val ) { if( i >= 0 && i < this.cnt ) { if( i >= this.tailoff() ) { var newTail = this.tail.slice( 0 ); newTail[ i & 0x01f ] = val; return new clojure.lang.PersistentVector( this.meta(), this.cnt, this.shift, this.root, newTail ); } return new clojure.lang.PersistentVector( this.meta(), this.cnt, this.shift, this.doAssoc( this.shift, this.root, i, val), this.tail ); } if( i == this.cnt ) { return this.cons( val ); } throw "IndexOutOfBoundsException"; }, doAssoc: function( level, arr, i, val ) { var subidx, ret = arr.slice( 0 ); if( level == 0 ) { ret[ i & 0x01f ] = val; } else { subidx = (i >>> level) & 0x01f; ret[ subidx ] = this.doAssoc( level - 5, arr[ subidx ], i, val ); } return ret; }, count: function() { return this.cnt; }, withMeta: function( _meta ) { return new clojure.lang.PersistentVector( _meta, this.cnt, this.shift, this.root, this.tail ); }, cons: function( val ) { var newTail, expansion, newroot, newshift; if( this.tail.length < 32 ) { newTail = this.tail.concat( [val] ); return new clojure.lang.PersistentVector( this.meta(), this.cnt + 1, this.shift, this.root, newTail ); } expansion = [null]; newroot = this.pushTail( this.shift-5, this.root, this.tail, expansion); newshift = this.shift; if( expansion[0] != null ) { newroot = [newroot, expansion[0]]; newshift += 5; } return new clojure.lang.PersistentVector( this.meta(), this.cnt+1, newshift, newroot, [val] ); }, empty: function() { return clojure.lang.PersistentVector.EMPTY.withMeta( this.meta() ); }, pushTail: function( level, arr, tailNode, expansion) { var ret, newchild; if( level == 0 ) { newchild = tailNode; } else { newchild = this.pushTail( level - 5, arr[arr.length - 1], tailNode, expansion); if( expansion[0] == null ) { ret = arr.slice( 0 ); ret[ arr.length - 1 ] = newchild; return ret; } else { newchild = expansion[0]; } } //expansion if( arr.length == 32 ) { expansion[0] = [newchild]; return arr; } expansion[0] = null; return arr.concat([newchild]); }, pop: function() { if( this.cnt == 0 ) { throw "IllegalStateException: Can't pop empty vector"; } if( this.cnt == 1 ) { return clojure.lang.PersistentVector.EMPTY.withMeta( this.meta() ); } var newTail, ptail, newroot, newshift; if( this.tail.length > 1 ) { newTail = this.tail.slice( 0, this.tail.length - 1 ); return new clojure.lang.PersistentVector( this.meta(), this.cnt - 1, this.shift, this.root, newTail ); } ptail = [null]; newroot = this.popTail( this.shift - 5, this.root, ptail ); newshift = this.shift; if( newroot == null ) { newroot = clojure.lang.RT.EMPTY_ARRAY; } if( this.shift > 5 && newroot.length == 1 ) { newroot = newroot[0]; newshift -= 5; } return new clojure.lang.PersistentVector( this.meta(), this.cnt - 1, newshift, newroot, ptail[0] ); }, popTail: function( shift, arr, ptail ) { if( shift > 0 ) { var newchild = this.popTail( shift - 5, arr[ arr.length - 1 ], ptail ), ret; if( newchild != null ) { ret = arr.slice( 0 ); ret[ arr.length - 1 ] = newchild; return ret; } } if( shift == 0 ) { ptail[0] = arr[ arr.length - 1 ]; } //contraction if( arr.length == 1 ) { return null; } return arr.slice( 0, arr.length - 1 ); } } }); clojure.lang.PersistentVector.EMPTY = new clojure.lang.PersistentVector( {}, 0, 5, clojure.lang.RT.EMPTY_ARRAY, clojure.lang.RT.EMPTY_ARRAY ); clojure.JS.definterface( clojure.lang, "IPersistentMap", [clojure.lang.Associative]); clojure.JS.defclass( clojure.lang, "APersistentMap", { extend: clojure.lang.AFn, implement: [clojure.lang.IPersistentMap, clojure.JS.Collection], init: function(_meta) { this._meta = _meta; this._hash = -1; }, methods: { cons: function(o){ if( clojure.JS.instanceq( clojure.lang.IPersistentVector, o ) ) { if( o.count() != 2 ) throw "Vector arg to map conj must be a pair"; return this.assoc( o.nth(0), o.nth(1) ); } var e, ret = this, es = clojure.core.seq( o ); for( ; es; es = es.rest() ) { e = es.first(); ret = ret.assoc( e.getKey(), e.getValue() ); } return ret; }, equals: function(m){ if( ! clojure.JS.instanceq( clojure.lang.IPersistentMap, m ) ) return false; if( m.count() != this.count() || m.hashCode() != this.hashCode() ) return false; var e, me, s = this.seq(); for( ; s; s = s.rest() ) { e = s.first(); me = m.entryAt( e.getKey() ); if( me === null || ! clojure.lang.Util.equal( e.getValue(), me.getValue() )) { return false; } } return true; }, hashCode: function(){ if( this._hash == -1 ) { var e, hash = this.count(), s = this.seq(); for( ; s; s = s.rest() ) { e = s.first(); hash ^= clojure.lang.Util.hashCombine( clojure.lang.Util.hash( e.getKey() ), clojure.lang.Util.hash( e.getValue() ) ); } this._hash = hash; } return _hash; }, containsAll: function(){ throw "not implemented yet"; }, invoke: function(k,notFound){ return this.valAt(k,notFound); }, toArray: function(){ return clojure.lang.RT.seqToArray( this.seq() ); }, size: function(){ return this.count(); }, isEmpty: function(){ return this.count() === 0; }, contains: function(e){ if( clojure.JS.instanceq( clojure.lang.MapEntry, e ) ) { var v = this.entryAt( e.getKey() ); return (v!==null && clojure.lang.Util.equal(v.getValue(),e.getValue())); } return false; } } }); clojure.JS.defclass( clojure.lang.APersistentMap, "KeySeq", { extend: clojure.lang.ASeq, init: function(_meta, _seq) { this._meta = _meta; this._seq = _seq; }, statics: { create: function(seq){ if(seq === null) return null; return new clojure.lang.APersistentMap.KeySeq(null,seq); } }, methods: { first: function(){ return this._seq.first().getKey(); }, rest: function(){ return clojure.lang.APersistentMap.KeySeq.create( this._seq.rest() ); }, withMeta: function(_meta){ return new clojure.lang.APersistentMap.KeySeq( _meta, this._seq ); } } }); clojure.JS.defclass( clojure.lang.APersistentMap, "ValSeq", { extend: clojure.lang.ASeq, init: function(_meta, _seq) { this._meta = _meta; this._seq = _seq; }, statics: { create: function(seq){ if(seq === null) return null; return new clojure.lang.APersistentMap.ValSeq(seq); } }, methods: { first: function(){ return this._seq.first().getValue(); }, rest: function(){ return clojure.lang.APersistentMap.ValSeq.create( this._seq.rest() ); }, withMeta: function(_meta){ return new clojure.lang.APersistentMap.ValSeq( _meta, this._seq ); } } }); clojure.JS.defclass( clojure.lang, "PersistentHashMap", { extend: clojure.lang.APersistentMap, init: function(_meta, _count, _root){ this._meta = _meta; this._count = _count; this._root = _root; }, statics: { create: function(init){ var ret = clojure.lang.PersistentHashMap.EMPTY, s = clojure.core.seq( init ); for( ; s; s=s.rest().rest() ){ if( s.rest() === null ) throw "No value supplied for key: " + s.first(); ret = ret.assoc( s.first(), clojure.core.second( s ) ); } return ret; }, mask: function(hash, shift){ return (hash >>> shift) & 0x01f; } }, methods:{ containsKey: function(key){ return this.entryAt(key) !== null; }, entryAt: function(k){ return this._root.find(clojure.lang.Util.hash(k),k);}, assoc: function(k,v){ var addedLeaf=[null], newroot = this._root.assoc( 0, clojure.lang.Util.hash(k), k, v, addedLeaf ); if( newroot == this._root ) return this; return new clojure.lang.PersistentHashMap( this._meta, this._count + (addedLeaf[0] === null ? 0 : 1), newroot ); }, valAt: function(k, notFound){ var e = this.entryAt(k); if( e !== null ) return e.val(); if( notFound === undefined ) return null; return notFound; }, assocEx: function(k,v){ if(this.containsKey(k)) throw "Key already present"; return this.assoc(k,v); }, without: function(k){ var newroot = this._root.without( clojure.lang.Util.hash(k), k ); if( newroot == this._root ) return this; if( newroot == null ) return this.empty(); return new clojure.lang.PersistentHashMap( this._meta, this._count-1, newroot ); }, count: function(){ return this._count; }, seq: function(){ return this._root.nodeSeq(); }, empty: function(){ return clojure.lang.PersistentHashMap.EMPTY.withMeta( this._meta ); }, withMeta: function(_meta){ return new clojure.lang.PersistentHashMap( _meta, this._count,this._root); } } }); clojure.JS.defclass( clojure.lang.PersistentHashMap, "EmptyNode", { methods: { assoc: function(shift, hash, key, val, addedLeaf){ var ret = new clojure.lang.PersistentHashMap.LeafNode( hash, key, val ); addedLeaf[0] = ret; return ret; }, without: function(h,k){ return this; }, find: function(h,k){ return null; }, nodeSeq: function(){ return null;}, getHash: function(){ return 0;} } }); clojure.lang.PersistentHashMap.EMPTY = new clojure.lang.PersistentHashMap( null, 0, new clojure.lang.PersistentHashMap.EmptyNode() ); clojure.JS.defclass( clojure.lang.PersistentHashMap, "FullNode", { init: function(nodes, shift){ this._nodes = nodes; this._shift = shift; this._hash = nodes[0].getHash(); }, statics: { bitpos: function(hash, shift) { return 1 << clojure.lang.PersistentHashMap.mask( hash, shift ); } }, methods: { assoc: function( levelShift, hash, key, val, addedLeaf ) { var newnodes, PHM = clojure.lang.PersistentHashMap, idx = PHM.mask( hash, this._shift ), n = this._nodes[idx].assoc( this._shift+5, hash, key, val, addedLeaf); if( n == this._nodes[idx] ) return this; else { newnodes = nodes.slice(); newnodes[idx] = n; return new PHM.FullNode( newnodes, this._shift ); } }, without: function(hash, key){ var newnodes, PHM = clojure.lang.PersistentHashMap, idx = PHM.mask( hash, this._shift ), n = this._nodes[idx].without( hash, key ); if( n != this._nodes[idx] ) { newnodes = nodes.slice(); if( n == null ) { nodes.splice( idx, 1 ); return new PHM.BitmapIndexedNode( ~PHM.FullNode.bitpos(hash,this._shift), newnodes, this._shift ); } newnodes[ idx ] = n; return new PHM.FullNode( newnodes, this._shift ); } return this; }, find: function(hash, key) { return (nodes[clojure.lang.PersistentHashMap.mask( hash, this._shift )] .find( hash, key )); }, nodeSeq: function(){ return clojure.lang.PersistentHashMap.FullNode.Seq.create( this, 0 ); }, getHash: function(){ return this._hash; } } }); clojure.JS.defclass( clojure.lang.PersistentHashMap.FullNode, "Seq", { extend: clojure.lang.ASeq, init: function( _meta, s, i, node ) { this._meta = _meta; this.s = s; this.i = i; this.node = node; }, statics: { create: function(node, i){ if( i >= node.nodes.length ) return null; return new clojure.lang.PersistentHashMap.FullNode.Seq( null, node.nodes[i].nodeSeq(), i, node ); } }, methods: { first: function(){ return this.s.first(); }, rest: function(){ var Seq = clojure.lang.PersistentHashMap.FullNode.Seq, nexts = this.s.rest(); if( nexts ) return new Seq( null, nexts, this.i, this.node ); return Seq.create( node,this.i+1); }, withMeta: function(_meta){ return new clojure.lang.PersistentHashMap.FullNode.Seq( _meta, this.s, this.i, this.node ); } } }); clojure.JS.defclass( clojure.lang.PersistentHashMap, "BitmapIndexedNode", { init: function(bitmap, nodes, shift) { this.bitmap = bitmap; this.nodes = nodes; this.shift = shift; this._hash = nodes[0].getHash(); }, statics: { bitpos: function(hash, shift) { return 1 << clojure.lang.PersistentHashMap.mask( hash, shift ); }, createA: function(bitmap, nodes, shift){ var PHM = clojure.lang.PersistentHashMap; if(bitmap == -1) return new PHM.FullNode( nodes, shift ); return new PHM.BitmapIndexedNode( bitmap, nodes, shift ); }, createB: function(shift, branch, hash, key, val, addedLeaf){ var PHM = clojure.lang.PersistentHashMap; return (new PHM.BitmapIndexedNode( PHM.BitmapIndexedNode.bitpos(branch.getHash(), shift), [branch], shift)).assoc( shift, hash, key, val, addedLeaf ); } }, methods: { index: function(bit) { return clojure.JS.bitcount(this.bitmap & (bit-1) );}, assoc: function(levelShift, hash, key, val, addedLeaf){ var newnodes, n, BIN = clojure.lang.PersistentHashMap.BitmapIndexedNode, bit = BIN.bitpos( hash, this.shift ), idx = this.index( bit ); if((this.bitmap & bit) != 0) { n = this.nodes[idx].assoc( this.shift+5, hash, key, val, addedLeaf); if( n == this.nodes[idx] ) return this; else { newnodes = this.nodes.slice(); newnodes[idx] = n; return new BIN( this.bitmap, newnodes, this.shift ); } } else { addedLeaf[0]= new clojure.lang.PersistentHashMap.LeafNode(hash,key,val); newnodes = this.nodes.slice(); newnodes.splice( idx, 0, addedLeaf[0] ); return BIN.createA( this.bitmap | bit, newnodes, this.shift ); } }, without: function( hash, key ) { var BIN = clojure.lang.PersistentHashMap.BitmapIndexedNode, bit = BIN.bitpos( hash, this.shift ), idx, n, newnodes; if((this.bitmap & bit) !== 0) { idx = this.index( bit ); n = this.nodes[ idx ].without( hash, key ); if( n != this.nodes[ idx ] ) { if( n === null ) { if( this.bitmap == bit ) return null; newnodes = this.nodes.slice(); newnodes.splice( idx, 1 ); return new BIN( this.bitmap & ~bit, newnodes, this.shift ); } newnodes = this.nodes.slice(); newnodes[ idx ] = n; return new BIN( this.bitmap, newnodes, this.shift ); } } return this; }, find: function( hash, key ) { var BIN = clojure.lang.PersistentHashMap.BitmapIndexedNode, bit = BIN.bitpos( hash, this.shift ); if((this.bitmap & bit) !== 0) return this.nodes[ this.index(bit) ].find( hash, key ); return null; }, getHash: function(){ return this._hash; }, nodeSeq: function(){ return clojure.lang.PersistentHashMap.BitmapIndexedNode.Seq.create( this, 0 ); } } }); clojure.JS.defclass( clojure.lang.PersistentHashMap.BitmapIndexedNode, "Seq", { extend: clojure.lang.ASeq, init: function( _meta, s, i, node ) { this._meta = _meta; this.s = s; this.i = i; this.node = node; }, statics: { create: function(node, i){ if( i >= node.nodes.length ) return null; return new clojure.lang.PersistentHashMap.BitmapIndexedNode.Seq( null, node.nodes[i].nodeSeq(), i, node ); } }, methods: { first: function(){ return this.s.first(); }, rest: function(){ var Seq = clojure.lang.PersistentHashMap.BitmapIndexedNode.Seq, nexts = this.s.rest(); if( nexts ) return new Seq( null, nexts, this.i, this.node ); return Seq.create( this.node, this.i+1 ); }, withMeta: function(_meta){ return new clojure.lang.PersistentHashMap.BitmapIndexedNode.Seq( _meta, this.s, this.i, this.node ); } } }); clojure.JS.defclass( clojure.lang.PersistentHashMap, "LeafNode", { extend: clojure.lang.AMapEntry, init: function( hash, key, val ) { this.hash = hash; this._key = key; this._val = val; }, methods: { assoc: function(shift, hash, key, val, addedLeaf) { var newLeaf, PHM = clojure.lang.PersistentHashMap; if( hash == this.hash ) { if( clojure.lang.Util.equal( key, this._key ) ) { if( val == this._val ) return this; return new PHM.LeafNode( hash, key, val ); } newLeaf = new PHM.LeafNode( hash, key, val ); addedLeaf[0] = newLeaf; return new PHM.HashCollisionNode( hash, [this, newLeaf] ); } return PHM.BitmapIndexedNode.createB( shift, this, hash, key, val, addedLeaf ); }, without: function(hash, key){ if(hash == this.hash && clojure.lang.Util.equal( key, this._key )) return null; return this; }, find: function(hash, key){ if(hash == this.hash && clojure.lang.Util.equal( key, this._key )) return this; return null; }, nodeSeq: function(){ return clojure.core.cons( this, null ); }, getHash: function(){ return this.hash; }, key: function(){ return this._key; }, val: function(){ return this._val; }, getKey: function(){ return this._key; }, getValue: function(){ return this._val; } } }); clojure.JS.defclass( clojure.lang.PersistentHashMap, "HashCollisionNode", { init: function(hash, leaves){ this.hash = hash; this.leaves = leaves; }, methods: { assoc: function(shift, hash, key, val, addedLeaf) { var idx, newLeaves, PHM = clojure.lang.PersistentHashMap; if( hash == this.hash ) { idx = this.findIndex( hash, key ); if( idx != -1 ) { if( this.leaves[idx].val == val ) return this; newLeaves = this.leaves.slice(); newLeaves[idx] = new PHM.LeafNode( hash, key, val ); return new PHM.HashCollisionNode( hash, newLeaves ); } addedLeaf[0] = new PHM.LeafNode( hash, key, val ); newLeaves = this.leaves.concat( addedLeaf ); return new PHM.HashCollisionNode( hash, newLeaves ); } return PHM.BitmapIndexedNode.createB(shift,this,hash,key,val,addedLeaf); }, without: function(hash, key){ var idx = this.findIndex( hash, key ); if( idx != -1 ) return leaves[ idx ]; return null; }, find: function(hash, key){ var idx = this.findIndex(hash, key); if(idx != -1) return this.leaves[idx]; return null; }, nodeSeq: function(){ return clojure.lang.ArraySeq.create(this.leaves); }, findIndex: function(hash, key){ for( var i = 0; i < this.leaves.length; ++i ) { if( this.leaves[i].find( hash, key ) != null ) return i; } return -1; }, getHash: function(){ return this.hash; } } }); // XXX dirty little hack until such time as PersistentArrayMap is ported clojure.lang.PersistentArrayMap = clojure.lang.PersistentHashMap; clojure.JS.definterface( clojure.lang, "IPersistentSet", [ clojure.lang.IPersistentCollection ] ); clojure.JS.defclass( clojure.lang, "APersistentSet", { extend: clojure.lang.AFn, implement: [ clojure.lang.IPersistentSet ], init: function( meta, impl ) { this._meta = meta; this.impl = impl; this._hash = -1; }, methods: { contains: function(key){ return this.impl.containsKey(key); }, get: function(key){ return this.impl.valAt(key); }, count: function(){ return this.impl.count(); }, seq: function(){ return clojure.core.keys( this.impl ); }, invoke: function(key){ return this.get(key); }, equals: function(m) { if( ! clojure.instanceq( clojure.lang.IPersistentSet ) ) return false; if( m.count() != this.count() || m.hashCode() != this.hashCode() ) return false; for( var s = this.seq(); s; s = s.rest() ) { if( ! m.contains( s.first() ) ) return false; } return true; }, hashCode: function() { if( this._hash == -1 ) { var hash = this.count(), s = this.seq(); for( ; s; s = s.rest() ) { hash = clojure.lang.Util.hashCombine( hash, clojure.lang.Util.hash( s.first() ) ); } this._hash = hash; } return this._hash; }, toArray: function(){ return clojure.lang.RT.seqToArray( this.seq() ); }, containsAll: function(c){ throw "not yet implemented"; }, size: function(){ return this.count(); }, isEmpty: function(){ return this.count() == 0; } } }); clojure.JS.defclass( clojure.lang, "PersistentHashSet", { extend: clojure.lang.APersistentSet, init: function( meta, impl ) { clojure.lang.APersistentSet.call( this, meta, impl ); }, statics: { create: function(init){ var ret = clojure.lang.PersistentHashSet.EMPTY, s = clojure.core.seq( init ); for( ; s; s=s.rest() ){ ret = ret.cons( s.first() ); } return ret; } }, methods: { disjoin: function(key) { if( this.contains(key) ) return new clojure.lang.PersistentHashSet( this._meta, this.impl.without(key)); return this; }, cons: function(o) { if( this.contains(o) ) return this; return new clojure.lang.PersistentHashSet( this._meta, this.impl.assoc(o)); }, empty: function(){ return clojure.lang.PersistentHashSet.EMPTY.withMeta( this._meta ); }, withMeta: function(_meta){ return new clojure.lang.PersistentHashSet( _meta, this.impl ); } } }); clojure.lang.PersistentHashSet.EMPTY = new clojure.lang.PersistentHashSet( null, clojure.lang.PersistentHashMap.EMPTY ); clojure.JS.defclass( clojure.lang, "MultiFn", { extend: clojure.lang.AFn, init: function( dispatchFn, defaultDispatchVal ) { this.dispatchFn = dispatchFn; this.defaultDispatchVal = defaultDispatchVal; this.methodTable = clojure.lang.PersistentHashMap.EMPTY; this.methodCache = clojure.lang.PersistentHashMap.EMPTY; this.preferTable = clojure.lang.PersistentHashMap.EMPTY; this.cachedHierarchy = null; }, methods: { addMethod: function( dispatchVal, method ){ this.methodTable = this.methodTable.assoc( dispatchVal, method ); this.resetCache(); return this; }, removeMethod: function( dispatchVal ){ this.methodTable = this.methodTable.without( dispatchVal ); this.resetCache(); return this; }, preferMethod: function( dispatchValX, dispatchValY ){ if( this.prefers( dispatchValY, dispatchValX ) ) throw ("Preference conflict: " + dispatchValY + " is already preferred to" + dispatchValX); var oldset = clojure.core.get( this.preferTable, dispatchValX, clojure.lang.PersistentHashSet.EMPTY); this.preferTable = this.preferTable.assoc( dispatchValX, clojure.core.conj( oldset, dispatchValY ) ); this.resetCache(); return this; }, prefers: function(x,y) { var xprefs = this.preferTable.valAt(x); return xprefs && xprefs.contains(y); }, isA: function(x,y) { return clojure.core.isa_QMARK_( x, y ); }, dominates: function(x,y) { return this.prefers(x,y) || this.isA(x,y); }, resetCache: function() { this.methodCache = this.methodTable; this.cachedHierarchy = clojure.core.global_hierarchy; return this.methodCache; }, getFn: function(dispatchVal) { if( this.cachedHierarchy != clojure.core.global_hierarchy ) this.resetCache(); var targetFn = this.methodCache.valAt( dispatchVal ) || this.findAndCacheBestMethod( dispatchVal ) || this.methodTable.valAt( this.defaultDispatchVal ); if( targetFn === null ) throw "No method for dispatch value: " + dispatchVal; return targetFn; }, findAndCacheBestMethod: function( dispatchVal ) { var e, bestEntry = null, s = this.methodTable.seq(); for( ; s; s = s.rest() ) { e = s.first(); if( this.isA( dispatchVal, e.getKey() ) ) { if( bestEntry===null || this.dominates(e.getKey(),bestEntry.getKey())) bestEntry = e; if( ! this.dominates( bestEntry.getKey(), e.getKey() ) ) throw ["Multiple methods match dispatch value:", dispatchVal, "->", e.getKey(), "and", bestEntry.getKey(), "and neither is preferred"].join(' '); } } if( bestEntry === null ) return null; // skip multi-threading protection this.methodCache = this.methodCache.assoc( dispatchVal, bestEntry.getValue()); return bestEntry.getValue(); }, invoke: function() { return (this.getFn( this.dispatchFn.apply( null, arguments ) ) .apply( null, arguments )); } } }); clojure.core.print_method = new clojure.lang.MultiFn( function (x, writer){ return clojure.core.class_(x); }, clojure.core.keyword("","default")); clojure.core.print_method.addMethod( java.lang.Class, function(o,w) { w.write("#="+clojure.lang.RT.className(o)); }); clojure.JS.relayPrintMethod( Number, java.lang.Number ); clojure.JS.relayPrintMethod( Array, java.util.Collection ); clojure.JS.relayPrintMethod( Boolean, java.lang.Boolean ); clojure.JS.relayPrintMethod( String, java.lang.String, function(o) { return new clojure.JS.String(o); } ); clojure.JS.relayPrintMethod( clojure.JS.Class, java.lang.Class ); clojure.JS.def(clojure.core,"_STAR_print_readably_STAR_",true); clojure.JS.implement( clojure.lang.Namespace, "Namespace" ); clojure.lang.Namespace.find = function( s ) { return clojure.JS.global[ s.getName() ]; }; clojure.JS.merge( clojure.lang.Namespace.prototype, { getMappings: function() { return this; }, hashCode: function() { return clojure.hash( this.name ); } }); clojure.core.in_ns(clojure.core.symbol("user")); (function() { var buf = []; function write(s) { s = s.toString(); var last, parts = s.split(/\n/); if( parts.length == 1 ) { buf.push(s); } else { last = parts.pop(); print( buf.join('') + parts.join('\n') ); buf = [ last ]; } } clojure.core._STAR_out_STAR_ = { append: write, write: write }; })(); clojure-contrib_1.2.0.orig/clojurescript/support-for-clojurescript.patch000066400000000000000000000343571161102570000267400ustar00rootroot00000000000000commit cef3bc5f654eb56def1bcedac661fb681ca6ae9e Author: Chouser Date: Fri Jan 16 02:47:42 2009 -0500 ClojureScript support diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj index 9b18b00..297eb71 100644 --- a/src/clj/clojure/core.clj +++ b/src/clj/clojure/core.clj @@ -321,7 +321,7 @@ (if more (recur (. sb (append (str (first more)))) (rest more)) (str sb))) - (new StringBuilder #^String (str x)) ys))) + (clojure.lang.RT/makeStringBuilder (str x)) ys))) (defn symbol? @@ -559,7 +559,7 @@ {:inline (fn [x y] `(. clojure.lang.Numbers (add ~x ~y))) :inline-arities #{2}} ([] 0) - ([x] (cast Number x)) + ([x] (clojure.lang.RT/numberCast x)) ([x y] (. clojure.lang.Numbers (add x y))) ([x y & more] (reduce + (+ x y) more))) @@ -569,7 +569,7 @@ {:inline (fn [x y] `(. clojure.lang.Numbers (multiply ~x ~y))) :inline-arities #{2}} ([] 1) - ([x] (cast Number x)) + ([x] (clojure.lang.RT/numberCast x)) ([x y] (. clojure.lang.Numbers (multiply x y))) ([x y & more] (reduce * (* x y) more))) @@ -1501,12 +1501,12 @@ (defn range "Returns a lazy seq of nums from start (inclusive) to end (exclusive), by step, where start defaults to 0 and step to 1." - ([end] (if (and (> end 0) (<= end (. Integer MAX_VALUE))) + ([end] (if (and (> end 0) (<= end clojure.lang.RT/IntegerMaxValue)) (new clojure.lang.Range 0 end) (take end (iterate inc 0)))) ([start end] (if (and (< start end) - (>= start (. Integer MIN_VALUE)) - (<= end (. Integer MAX_VALUE))) + (>= start clojure.lang.RT/IntegerMinValue) + (<= end clojure.lang.RT/IntegerMaxValue)) (new clojure.lang.Range start end) (take (- end start) (iterate inc start)))) ([start end step] @@ -1573,7 +1573,7 @@ ([#^java.util.Comparator comp coll] (when (and coll (not (zero? (count coll)))) (let [a (to-array coll)] - (. java.util.Arrays (sort a comp)) + (clojure.lang.RT/sortArray a comp) (seq a))))) (defn sort-by @@ -1663,7 +1663,7 @@ [& agents] (io! "await in transaction" (when *agent* - (throw (new Exception "Can't await in agent action"))) + (throw (clojure.lang.RT/makeException "Can't await in agent action"))) (let [latch (new java.util.concurrent.CountDownLatch (count agents)) count-down (fn [agent] (. latch (countDown)) agent)] (doseq [agent agents] @@ -1683,7 +1683,7 @@ [timeout-ms & agents] (io! "await-for in transaction" (when *agent* - (throw (new Exception "Can't await in agent action"))) + (throw (clojure.lang.RT/makeException "Can't await in agent action"))) (let [latch (new java.util.concurrent.CountDownLatch (count agents)) count-down (fn [agent] (. latch (countDown)) agent)] (doseq [agent agents] @@ -2007,6 +2007,7 @@ (import '(java.lang.reflect Array)) +(import '(clojure.lang RT)) (defn alength "Returns the length of the Java array. Works on arrays of all @@ -2026,7 +2027,7 @@ {:inline (fn [a i] `(. clojure.lang.RT (aget ~a ~i))) :inline-arities #{2}} ([array idx] - (clojure.lang.Reflector/prepRet (. Array (get array idx)))) + (clojure.lang.Reflector/prepRet (RT/aget array idx))) ([array idx & idxs] (apply aget (aget array idx) idxs))) @@ -2036,7 +2037,7 @@ {:inline (fn [a i v] `(. clojure.lang.RT (aset ~a ~i ~v))) :inline-arities #{3}} ([array idx val] - (. Array (set array idx val)) + (RT/aset array idx val) val) ([array idx idx2 & idxv] (apply aset (aget array idx) idx2 idxv))) @@ -2193,6 +2194,10 @@ "Returns a set of the distinct elements of coll." [coll] (apply hash-set coll)) +(defn class? + "Returns true if x is an instance of Class" + [x] (instance? Class x)) + (defn #^{:private true} filter-key [keyfn pred amap] (loop [ret {} es (seq amap)] @@ -2228,7 +2233,7 @@ [x] (if (instance? clojure.lang.Namespace x) x - (or (find-ns x) (throw (Exception. (str "No namespace: " x " found")))))) + (or (find-ns x) (throw (RT/makeException (str "No namespace: " x " found")))))) (defn ns-name "Returns the name of the namespace, a symbol." @@ -2261,7 +2266,7 @@ (defn ns-imports "Returns a map of the import mappings for the namespace." [ns] - (filter-key val (partial instance? Class) (ns-map ns))) + (filter-key val class? (ns-map ns))) (defn refer "refers to all public vars of ns, subject to filters. @@ -2279,7 +2284,8 @@ to a symbol different from the var's name, in order to prevent clashes. Use :use in the ns macro in preference to calling this directly." [ns-sym & filters] - (let [ns (or (find-ns ns-sym) (throw (new Exception (str "No namespace: " ns-sym)))) + (let [ns (or (find-ns ns-sym) + (throw (RT/makeException (str "No namespace: " ns-sym)))) fs (apply hash-map filters) nspublics (ns-publics ns) rename (or (:rename fs) {}) @@ -2411,7 +2417,7 @@ true) (= firstb :as) (pb ret (second bs) gvec) :else (if seen-rest? - (throw (new Exception "Unsupported binding form, only :as can follow & parameter")) + (throw (RT/makeException "Unsupported binding form, only :as can follow & parameter")) (recur (pb ret firstb (list `nth gvec n nil)) (inc n) (rest bs) @@ -2442,7 +2448,7 @@ (symbol? b) (-> bvec (conj b) (conj v)) (vector? b) (pvec bvec b v) (map? b) (pmap bvec b v) - :else (throw (new Exception (str "Unsupported binding form: " b)))))) + :else (throw (RT/makeException (str "Unsupported binding form: " b)))))) process-entry (fn [bvec b] (pb bvec (key b) (val b)))] (if (every? symbol? (keys bmap)) bindings @@ -2590,7 +2596,7 @@ StringWriter. Returns the string created by any nested printing calls." [& body] - `(let [s# (new java.io.StringWriter)] + `(let [s# (clojure.lang.RT/makeStringWriter)] (binding [*out* s#] ~@body (str s#)))) @@ -2636,7 +2642,7 @@ logical true." [x] `(when-not ~x - (throw (new Exception (str "Assert failed: " (pr-str '~x)))))) + (throw (clojure.lang.RT/makeException (str "Assert failed: " (pr-str '~x)))))) (defn test "test [v] finds fn at key :test in var metadata and calls it, @@ -2710,7 +2716,7 @@ (defn rand "Returns a random floating point number between 0 (inclusive) and 1 (exclusive)." - ([] (. Math (random))) + ([] (RT/random)) ([n] (* n (rand)))) (defn rand-int @@ -2820,7 +2826,7 @@ "Reads the file named by f into a string and returns it." [#^String f] (with-open [r (new java.io.BufferedReader (new java.io.FileReader f))] - (let [sb (new StringBuilder)] + (let [sb (RT/makeStringBuilder)] (loop [c (. r (read))] (if (neg? c) (str sb) @@ -3104,10 +3110,6 @@ (send-off agt fill) (drain)))) -(defn class? - "Returns true if x is an instance of Class" - [x] (instance? Class x)) - (defn alter-var-root "Atomically alters the root binding of var v by applying f to its current value plus any args" @@ -3193,7 +3195,7 @@ relationships." ([tag] (descendants global-hierarchy tag)) ([h tag] (if (class? tag) - (throw (java.lang.UnsupportedOperationException. "Can't get descendants of classes")) + (throw (RT/makeUnsupportedException "Can't get descendants of classes")) (not-empty (get (:descendants h) tag))))) (defn derive @@ -3223,9 +3225,9 @@ (or (when-not (contains? (tp tag) parent) (when (contains? (ta tag) parent) - (throw (Exception. (print-str tag "already has" parent "as ancestor")))) + (throw (RT/makeException (print-str tag "already has" parent "as ancestor")))) (when (contains? (ta parent) tag) - (throw (Exception. (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) + (throw (RT/makeException (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) :ancestors (tf (:ancestors h) tag td parent ta) :descendants (tf (:descendants h) parent ta tag td)}) @@ -3366,7 +3368,7 @@ [pred fmt & args] (when pred (let [message (apply format fmt args) - exception (Exception. message) + exception (RT/makeException message) raw-trace (.getStackTrace exception) boring? #(not= (.getMethodName %) "doInvoke") trace (into-array (drop 2 (drop-while boring? raw-trace)))] diff --git a/src/clj/clojure/core_print.clj b/src/clj/clojure/core_print.clj index 7a79a90..1ecc597 100644 --- a/src/clj/clojure/core_print.clj +++ b/src/clj/clojure/core_print.clj @@ -75,14 +75,14 @@ (defn print-ctor [o print-args #^Writer w] (.write w "#=(") - (.write w (.getName #^Class (class o))) + (.write w (RT/className (class o))) (.write w ". ") (print-args o w) (.write w ")")) (defmethod print-method :default [o, #^Writer w] (.write w "#<") - (.write w (.getSimpleName (class o))) + (.write w (RT/simpleClassName (class o))) (.write w " ") (.write w (str o)) (.write w ">")) @@ -148,7 +148,7 @@ (defmethod print-dup clojure.lang.IPersistentCollection [o, #^Writer w] (print-meta o w) (.write w "#=(") - (.write w (.getName #^Class (class o))) + (.write w (RT/className (class o))) (.write w "/create ") (print-sequential "[" print-dup " " "]" o w) (.write w ")")) @@ -202,7 +202,7 @@ (defmethod print-dup clojure.lang.IPersistentMap [m, #^Writer w] (print-meta m w) (.write w "#=(") - (.write w (.getName (class m))) + (.write w (RT/className (class m))) (.write w "/create ") (print-map m print-dup w) (.write w ")")) @@ -252,7 +252,7 @@ Short/TYPE "Short/TYPE"}) (defmethod print-method Class [#^Class c, #^Writer w] - (.write w (.getName c))) + (.write w (RT/className c))) (defmethod print-dup Class [#^Class c, #^Writer w] (cond @@ -262,11 +262,11 @@ (.write w ")")) (.isArray c) (do (.write w "#=(java.lang.Class/forName \"") - (.write w (.getName c)) + (.write w (RT/className c)) (.write w "\")")) :else (do (.write w "#=") - (.write w (.getName c))))) + (.write w (RT/className c))))) (defmethod print-method java.math.BigDecimal [b, #^Writer w] (.write w (str b)) diff --git a/src/jvm/clojure/lang/Compiler.java b/src/jvm/clojure/lang/Compiler.java index d9033ac..eb4890a 100644 --- a/src/jvm/clojure/lang/Compiler.java +++ b/src/jvm/clojure/lang/Compiler.java @@ -202,7 +202,8 @@ static final public Var NEXT_LOCAL_NUM = Var.create(0); static final public Var RET_LOCAL_NUM = Var.create(); //DynamicClassLoader -static final public Var LOADER = Var.create(); +static final public Var LOADER = Var.intern(Namespace.findOrCreate(Symbol.create("clojure.core")), + Symbol.create("*private-compiler-loader*")); public enum C{ STATEMENT, //value ignored @@ -2975,7 +2976,8 @@ static public class FnExpr implements Expr{ { Var.popThreadBindings(); } - fn.compile(); + if(! RT.booleanCast(RT.COMPILER_ANALYZE_ONLY.get())) + fn.compile(); return fn; } diff --git a/src/jvm/clojure/lang/RT.java b/src/jvm/clojure/lang/RT.java index a277f89..699c0d1 100644 --- a/src/jvm/clojure/lang/RT.java +++ b/src/jvm/clojure/lang/RT.java @@ -32,6 +32,9 @@ static final public Boolean T = Boolean.TRUE;//Keyword.intern(Symbol.create(null static final public Boolean F = Boolean.FALSE;//Keyword.intern(Symbol.create(null, "t")); static final public String LOADER_SUFFIX = "__init"; +static final public Integer IntegerMaxValue = Integer.MAX_VALUE; +static final public Integer IntegerMinValue = Integer.MIN_VALUE; + //simple-symbol->class final static IPersistentMap DEFAULT_IMPORTS = map( // Symbol.create("RT"), "clojure.lang.RT", @@ -202,6 +205,7 @@ final static Var PRINT_READABLY = Var.intern(CLOJURE_NS, Symbol.create("*print-r final static Var PRINT_DUP = Var.intern(CLOJURE_NS, Symbol.create("*print-dup*"), F); final static Var WARN_ON_REFLECTION = Var.intern(CLOJURE_NS, Symbol.create("*warn-on-reflection*"), F); final static Var ALLOW_UNRESOLVED_VARS = Var.intern(CLOJURE_NS, Symbol.create("*allow-unresolved-vars*"), F); +final static Var COMPILER_ANALYZE_ONLY = Var.intern(CLOJURE_NS, Symbol.create("*compiler-analyze-only*"), F); final static Var IN_NS_VAR = Var.intern(CLOJURE_NS, Symbol.create("in-ns"), F); final static Var NS_VAR = Var.intern(CLOJURE_NS, Symbol.create("ns"), F); @@ -963,6 +967,10 @@ static public double doubleCast(double x){ return x; } +static public Number numberCast(Object x){ + return (Number)x; +} + static public IPersistentMap map(Object... init){ if(init == null) return PersistentArrayMap.EMPTY; @@ -1707,4 +1715,43 @@ synchronized public static DynamicClassLoader getRootClassLoader() { ROOT_CLASSLOADER = new DynamicClassLoader(); return ROOT_CLASSLOADER; } + +////////////// ClojureScript support ///////////////////////////////// + +static public StringBuilder makeStringBuilder(){ + return new StringBuilder(); +} + +static public StringBuilder makeStringBuilder(String x){ + return new StringBuilder(x); +} + +static public StringWriter makeStringWriter(){ + return new StringWriter(); +} + +static public Exception makeException(String msg){ + return new Exception(msg); +} + +static public Exception makeUnsupportedException(String msg){ + return new UnsupportedOperationException(msg); +} + +static public void sortArray(Object[] a, Comparator c){ + Arrays.sort(a, c); +} + +static public double random(){ + return Math.random(); +} + +static public String className(Class c){ + return c.getName(); +} + +static public String simpleClassName(Class c){ + return c.getSimpleName(); +} + } clojure-contrib_1.2.0.orig/clojurescript/tests/000077500000000000000000000000001161102570000216575ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/clojurescript/tests/t01.cljs000066400000000000000000000005231161102570000231400ustar00rootroot00000000000000; This may look like Clojure, but it's actually ClojureScript. Macros ; may be used here, but should be defined elsewhere, in regular ; Clojure code. (ns n01se) (defn script-src [] (for [elem (.getElementsByTagName document "script")] (if-let [src (.src elem)] src "--none--"))) (doseq [src (script-src)] (prn src)) clojure-contrib_1.2.0.orig/clojurescript/tests/t02.cljs000066400000000000000000000011361161102570000231420ustar00rootroot00000000000000; This may look like Clojure, but it's actually ClojureScript. Macros ; may be used here, but should be defined elsewhere, in regular ; Clojure code. (ns n01se) (defn my-take "Returns a lazy seq of the first n items in coll, or all items if there are fewer than n." [n coll] (when (and (pos? n) (seq coll)) (lazy-cons (first coll) (my-take (dec n) (rest coll))))) (defn script-src [] (for [elem (.getElementsByTagName document "script")] (do (prn :next) (if-let [src (.src elem)] src "--none--")))) (doseq [src (my-take 2 (script-src))] (prn src)) clojure-contrib_1.2.0.orig/clojurescript/tests/t03.cljs000066400000000000000000000002741161102570000231450ustar00rootroot00000000000000(ns net.n01se) (def x 5) (def y 10) (defn bind-test [] (when (= x 2) (set! y 90)) (binding [x (dec x) y (inc y)] (when (pos? x) (bind-test))) (prn x y)) (bind-test) clojure-contrib_1.2.0.orig/clojurescript/tests/t04.cljs000066400000000000000000000005751161102570000231520ustar00rootroot00000000000000; This may look like Clojure, but it's actually ClojureScript. Macros ; may be used here, but should be defined elsewhere, in regular ; Clojure code. (ns n01se) (defn script-src [] (for [elem (.getElementsByTagName document "script")] (do (prn :next) (if-let [src (.src elem)] src "--none--")))) (doseq [src (take 2 (script-src))] (prn src)) clojure-contrib_1.2.0.orig/clojurescript/tests/t05.js000066400000000000000000000052211161102570000226250ustar00rootroot00000000000000function vToString( v ) { var a = new Array( v.count() ); for( var i = 0; i < v.count(); ++i ) { a[ i ] = v.nth( i ); } return ['[', a.join(' '), ']'].join(''); } var v = clojure.lang.PersistentVector.EMPTY; for( var i = 0; i < 100; ++i ) { v = v.cons( i * 10 ); } print( vToString( v ) ); print( vToString( v.assocN( 20, 999 ) ) ); var a = []; for( v2 = v; v2.count() > 0; v2 = v2.pop() ) { a.push( v2.peek() ); } print( a ); v = clojure.lang.PersistentVector.EMPTY; for( var i = 0; i < 100000; ++i ) { v = v.cons( i ); } for(; v.count() > 0; v = v.pop() ) { v.peek() }; print( vToString( clojure.lang.PersistentVector.create( [ 'a', 'b', 'c', 'd', 'e' ] ) ) ); function time( msg, fn, reps ) { reps = reps || 1; var start = new Date(); var last; for( var i = 0; i < reps; ++i ) { last = fn(); } var end = new Date(); print( msg + ': ' + (end - start) + ' msecs' ); return last; } var Rand = (function(){ var cycle = 1000000; var rnd = new Array( cycle ); var idx = -1; for( var i = 0; i < cycle; ++i ) { rnd[i] = Math.random(); } return { reset: function() { idx = -1; }, next: function( r ) { idx = (idx + 1) % cycle; return Math.floor( rnd[ idx ] * r ); } }; })(); function suite( size, writes, reads, reps ) { print( "Suite size: " + size + ", writes: " + writes + ", reads: " + reads ); var a = []; var p = clojure.lang.PersistentVector.EMPTY; time( " Array push", function() { for( var i = 0; i < size; i++ ) { a.push( i ); } }, reps ); time( " PV cons ", function() { for( var i = 0; i < size; i++ ) { p = p.cons( i ); } }, reps ); var ta = 0; time( " Array set ", function() { Rand.reset(); for( var i = 0; i < writes; ++i ) { a[ Rand.next( size ) ] = i; } for( var j = 0; j < reads; ++j ) { ta += a[ Rand.next( size ) ]; } }, reps); var tp = 0; time( " PV set ", function() { Rand.reset(); for( var i = 0; i < writes; ++i ) { p = p.assocN( Rand.next( size ), i ); } for( var j = 0; j < reads; ++j ) { tp += p.nth( Rand.next( size ) ); } }, reps); print( "Done: " + ta + ", " + tp + "\n" ); } suite( 100000, 10000, 20000 ); suite( 30, 10000, 20000, 50 ); suite( 100000, 10000, 0 ); suite( 30, 10000, 0, 50 ); suite( 100000, 0, 20000 ); suite( 30, 0, 20000, 100 ); /* var p = clojure.lang.PersistentVector.EMPTY; for( var i = 0; i < 1088; i++ ) { //for( var i = 0; i < 1056; i++ ) { p = p.cons( i ); } print( p.nth( p.count() - 33 ) ) print( p.cons("oops").nth( p.count() - 33 ) ) */ //print( clojure.lang.PersistentVector.EMPTY.constructor ); print('done'); clojure-contrib_1.2.0.orig/clojurescript/tests/t06.cljs000066400000000000000000000002471161102570000231500ustar00rootroot00000000000000(ns test) (defn setText []) (prn :yo) (prn (-> clojure .print-method .methodTable)) (prn (JQuery "#nice")) (prn (.ready ($ document) test/setText)) (prn (+ 1 2 3 4)) clojure-contrib_1.2.0.orig/epl-v10.html000066400000000000000000000311651161102570000177050ustar00rootroot00000000000000 Eclipse Public License - Version 1.0

Eclipse Public License - v 1.0

THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.

1. DEFINITIONS

"Contribution" means:

a) in the case of the initial Contributor, the initial code and documentation distributed under this Agreement, and

b) in the case of each subsequent Contributor:

i) changes to the Program, and

ii) additions to the Program;

where such changes and/or additions to the Program originate from and are distributed by that particular Contributor. A Contribution 'originates' from a Contributor if it was added to the Program by such Contributor itself or anyone acting on such Contributor's behalf. Contributions do not include additions to the Program which: (i) are separate modules of software distributed in conjunction with the Program under their own license agreement, and (ii) are not derivative works of the Program.

"Contributor" means any person or entity that distributes the Program.

"Licensed Patents" mean patent claims licensable by a Contributor which are necessarily infringed by the use or sale of its Contribution alone or when combined with the Program.

"Program" means the Contributions distributed in accordance with this Agreement.

"Recipient" means anyone who receives the Program under this Agreement, including all Contributors.

2. GRANT OF RIGHTS

a) Subject to the terms of this Agreement, each Contributor hereby grants Recipient a non-exclusive, worldwide, royalty-free copyright license to reproduce, prepare derivative works of, publicly display, publicly perform, distribute and sublicense the Contribution of such Contributor, if any, and such derivative works, in source code and object code form.

b) Subject to the terms of this Agreement, each Contributor hereby grants Recipient a non-exclusive, worldwide, royalty-free patent license under Licensed Patents to make, use, sell, offer to sell, import and otherwise transfer the Contribution of such Contributor, if any, in source code and object code form. This patent license shall apply to the combination of the Contribution and the Program if, at the time the Contribution is added by the Contributor, such addition of the Contribution causes such combination to be covered by the Licensed Patents. The patent license shall not apply to any other combinations which include the Contribution. No hardware per se is licensed hereunder.

c) Recipient understands that although each Contributor grants the licenses to its Contributions set forth herein, no assurances are provided by any Contributor that the Program does not infringe the patent or other intellectual property rights of any other entity. Each Contributor disclaims any liability to Recipient for claims brought by any other entity based on infringement of intellectual property rights or otherwise. As a condition to exercising the rights and licenses granted hereunder, each Recipient hereby assumes sole responsibility to secure any other intellectual property rights needed, if any. For example, if a third party patent license is required to allow Recipient to distribute the Program, it is Recipient's responsibility to acquire that license before distributing the Program.

d) Each Contributor represents that to its knowledge it has sufficient copyright rights in its Contribution, if any, to grant the copyright license set forth in this Agreement.

3. REQUIREMENTS

A Contributor may choose to distribute the Program in object code form under its own license agreement, provided that:

a) it complies with the terms and conditions of this Agreement; and

b) its license agreement:

i) effectively disclaims on behalf of all Contributors all warranties and conditions, express and implied, including warranties or conditions of title and non-infringement, and implied warranties or conditions of merchantability and fitness for a particular purpose;

ii) effectively excludes on behalf of all Contributors all liability for damages, including direct, indirect, special, incidental and consequential damages, such as lost profits;

iii) states that any provisions which differ from this Agreement are offered by that Contributor alone and not by any other party; and

iv) states that source code for the Program is available from such Contributor, and informs licensees how to obtain it in a reasonable manner on or through a medium customarily used for software exchange.

When the Program is made available in source code form:

a) it must be made available under this Agreement; and

b) a copy of this Agreement must be included with each copy of the Program.

Contributors may not remove or alter any copyright notices contained within the Program.

Each Contributor must identify itself as the originator of its Contribution, if any, in a manner that reasonably allows subsequent Recipients to identify the originator of the Contribution.

4. COMMERCIAL DISTRIBUTION

Commercial distributors of software may accept certain responsibilities with respect to end users, business partners and the like. While this license is intended to facilitate the commercial use of the Program, the Contributor who includes the Program in a commercial product offering should do so in a manner which does not create potential liability for other Contributors. Therefore, if a Contributor includes the Program in a commercial product offering, such Contributor ("Commercial Contributor") hereby agrees to defend and indemnify every other Contributor ("Indemnified Contributor") against any losses, damages and costs (collectively "Losses") arising from claims, lawsuits and other legal actions brought by a third party against the Indemnified Contributor to the extent caused by the acts or omissions of such Commercial Contributor in connection with its distribution of the Program in a commercial product offering. The obligations in this section do not apply to any claims or Losses relating to any actual or alleged intellectual property infringement. In order to qualify, an Indemnified Contributor must: a) promptly notify the Commercial Contributor in writing of such claim, and b) allow the Commercial Contributor to control, and cooperate with the Commercial Contributor in, the defense and any related settlement negotiations. The Indemnified Contributor may participate in any such claim at its own expense.

For example, a Contributor might include the Program in a commercial product offering, Product X. That Contributor is then a Commercial Contributor. If that Commercial Contributor then makes performance claims, or offers warranties related to Product X, those performance claims and warranties are such Commercial Contributor's responsibility alone. Under this section, the Commercial Contributor would have to defend claims against the other Contributors related to those performance claims and warranties, and if a court requires any other Contributor to pay any damages as a result, the Commercial Contributor must pay those damages.

5. NO WARRANTY

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the appropriateness of using and distributing the Program and assumes all risks associated with its exercise of rights under this Agreement , including but not limited to the risks and costs of program errors, compliance with applicable laws, damage to or loss of data, programs or equipment, and unavailability or interruption of operations.

6. DISCLAIMER OF LIABILITY

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

7. GENERAL

If any provision of this Agreement is invalid or unenforceable under applicable law, it shall not affect the validity or enforceability of the remainder of the terms of this Agreement, and without further action by the parties hereto, such provision shall be reformed to the minimum extent necessary to make such provision valid and enforceable.

If Recipient institutes patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Program itself (excluding combinations of the Program with other software or hardware) infringes such Recipient's patent(s), then such Recipient's rights granted under Section 2(b) shall terminate as of the date such litigation is filed.

All Recipient's rights under this Agreement shall terminate if it fails to comply with any of the material terms or conditions of this Agreement and does not cure such failure in a reasonable period of time after becoming aware of such noncompliance. If all Recipient's rights under this Agreement terminate, Recipient agrees to cease use and distribution of the Program as soon as reasonably practicable. However, Recipient's obligations under this Agreement and any licenses granted by Recipient relating to the Program shall continue and survive.

Everyone is permitted to copy and distribute copies of this Agreement, but in order to avoid inconsistency the Agreement is copyrighted and may only be modified in the following manner. The Agreement Steward reserves the right to publish new versions (including revisions) of this Agreement from time to time. No one other than the Agreement Steward has the right to modify this Agreement. The Eclipse Foundation is the initial Agreement Steward. The Eclipse Foundation may assign the responsibility to serve as the Agreement Steward to a suitable separate entity. Each new version of the Agreement will be given a distinguishing version number. The Program (including Contributions) may always be distributed subject to the version of the Agreement under which it was received. In addition, after a new version of the Agreement is published, Contributor may elect to distribute the Program (including its Contributions) under the new version. Except as expressly stated in Sections 2(a) and 2(b) above, Recipient receives no rights or licenses to the intellectual property of any Contributor under this Agreement, whether expressly, by implication, estoppel or otherwise. All rights in the Program not expressly granted under this Agreement are reserved.

This Agreement is governed by the laws of the State of New York and the intellectual property laws of the United States of America. No party to this Agreement will bring a legal action under this Agreement more than one year after the cause of action arose. Each party waives its rights to a jury trial in any resulting litigation.

clojure-contrib_1.2.0.orig/launchers/000077500000000000000000000000001161102570000176115ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/launchers/bash/000077500000000000000000000000001161102570000205265ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/launchers/bash/clj-env-dir000066400000000000000000000042251161102570000225660ustar00rootroot00000000000000#!/bin/bash # Copyright (c) Stephen C. Gilardi. 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. # # clj-env-dir Launches Clojure, passing along command line arguments. This # launcher can be configured using environment variables and # makes it easy to include directories full of classpath roots # in CLASSPATH. # # scgilardi (gmail) # Created 7 January 2009 # # Environment variables (optional): # # CLOJURE_EXT Colon-delimited list of paths to directories whose top-level # contents are (either directly or as symbolic links) jar # files and/or directories whose paths will be in Clojure's # classpath. The value of the CLASSPATH environment variable # for Clojure will include these top-level paths followed by # the previous value of CLASSPATH (if any). # default: # example: /usr/local/share/clojure/ext:$HOME/.clojure.d/ext # # CLOJURE_JAVA The command to launch a JVM instance for Clojure # default: java # example: /usr/local/bin/java6 # # CLOJURE_OPTS Java options for this JVM instance # default: # example:"-Xms32M -Xmx128M -server" # # CLOJURE_MAIN The Java class to launch # default: clojure.main # example: clojure.contrib.repl_ln set -o errexit #set -o nounset #set -o xtrace if [ -n "${CLOJURE_EXT:-}" ]; then OLD="$IFS" IFS=":" EXT="$(find -H $CLOJURE_EXT -mindepth 1 -maxdepth 1 -print0 | tr \\0 \:)" IFS="$OLD" if [ -n "${CLASSPATH:-}" ]; then export CLASSPATH="$EXT$CLASSPATH" else export CLASSPATH="${EXT%:}" fi fi JAVA=${CLOJURE_JAVA:-java} OPTS=${CLOJURE_OPTS:-} MAIN=${CLOJURE_MAIN:-clojure.main} exec $JAVA $OPTS $MAIN "$@" clojure-contrib_1.2.0.orig/pom.xml000066400000000000000000000076261161102570000171550ustar00rootroot00000000000000 1.2.0 UTF-8 4.0.0 org.clojure clojure-contrib 1.2.0 http://clojure.org/ Clojure user contributions library. ${artifactId} Eclipse Public License 1.0 http://opensource.org/licenses/eclipse-1.0.php repo org.clojure clojure ${clojure.version} clojure-snapshots http://build.clojure.org/snapshots false true clojure-releases http://build.clojure.org/releases true false local clojure.jar org.clojure clojure ${clojure.version} system ${clojure.jar} src/main/clojure src/examples/clojure src/test/clojure com.theoryinpractise clojure-maven-plugin 1.3.2 true clojure\.contrib\.jmx\.Bean clojure\.contrib\.fnmap\.PersistentFnMap clojure\.contrib\.condition\.Condition clojure\.contrib\.repl-ln compile-clojure compile compile test-clojure test test maven-assembly-plugin src/main/assembly/dist.xml clojure-releases scp://build.clojure.org/srv/www/releases clojure-contrib_1.2.0.orig/src/000077500000000000000000000000001161102570000164145ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/000077500000000000000000000000001161102570000202325ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/000077500000000000000000000000001161102570000216755ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/000077500000000000000000000000001161102570000233405ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/000077500000000000000000000000001161102570000250005ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/accumulators/000077500000000000000000000000001161102570000275025ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/accumulators/examples.clj000066400000000000000000000056621161102570000320230ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Accumulator application examples ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ns #^{:author "Konrad Hinsen" :skip-wiki true :doc "Examples for using accumulators"} clojure.contrib.accumulators.examples (:use [clojure.contrib.accumulators :only (combine add add-items empty-vector empty-list empty-queue empty-set empty-map empty-counter empty-counter-with-total empty-sum empty-product empty-maximum empty-minimum empty-min-max empty-mean-variance empty-string empty-tuple)])) ; Vector accumulator: combine is concat, add is conj (combine [:a :b] [:c :d] [:x :y]) (add [:a :b] :c) (add-items empty-vector [:a :b :a]) ; List accumulator: combine is concat, add is conj (combine '(:a :b) '(:c :d) '(:x :y)) (add '(:a :b) :c) (add-items empty-list [:a :b :a]) ; Queue accumulator (let [q1 (add-items empty-queue [:a :b :a]) q2 (add-items empty-queue [:x :y])] (combine q1 q2)) ; Set accumulator: combine is union, add is conj (combine #{:a :b} #{:c :d} #{:a :d}) (add #{:a :b} :c) (add-items empty-set [:a :b :a]) ; Map accumulator: combine is merge, add is conj (combine {:a 1} {:b 2 :c 3} {}) (add {:a 1} [:b 2]) (add-items empty-map [[:a 1] [:b 2] [:a 0]]) ; Counter accumulator (let [c1 (add-items empty-counter [:a :b :a]) c2 (add-items empty-counter [:x :y])] (combine c1 c2)) ; Counter-with-total accumulator (let [c1 (add-items empty-counter-with-total [:a :b :a]) c2 (add-items empty-counter-with-total [:x :y])] (combine c1 c2)) ; Sum accumulator: combine is addition (let [s1 (add-items empty-sum [1 2 3]) s2 (add-items empty-sum [-1 -2 -3])] (combine s1 s2)) ; Product accumulator: combine is multiplication (let [p1 (add-items empty-product [2 3]) p2 (add-items empty-product [(/ 1 2)])] (combine p1 p2)) ; Maximum accumulator: combine is max (let [m1 (add-items empty-maximum [2 3]) m2 (add-items empty-maximum [(/ 1 2)])] (combine m1 m2)) ; Minimum accumulator: combine is min (let [m1 (add-items empty-minimum [2 3]) m2 (add-items empty-minimum [(/ 1 2)])] (combine m1 m2)) ; Min-max accumulator: combination of minimum and maximum (let [m1 (add-items empty-min-max [2 3]) m2 (add-items empty-min-max [(/ 1 2)])] (combine m1 m2)) ; Mean-variance accumulator: sample mean and sample variance (let [m1 (add-items empty-mean-variance [2 4]) m2 (add-items empty-mean-variance [6])] (combine m1 m2)) ; String accumulator: combine is concatenation (combine "a" "b" "c" "def") (add "a" (char 44)) (add-items empty-string [(char 55) (char 56) (char 57)]) ; Accumulator tuples permit to update several accumulators in parallel (let [pair (empty-tuple [empty-vector empty-string])] (add-items pair [[1 "a"] [2 "b"]])) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/condition/000077500000000000000000000000001161102570000267665ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/condition/example.clj000066400000000000000000000033721161102570000311200ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; clojure.contrib.condition.example.clj ;; ;; scgilardi (gmail) ;; Created 09 June 2009 (ns clojure.contrib.condition.example (:use (clojure.contrib [condition :only (handler-case print-stack-trace raise *condition*)]))) (defn func [x y] "Raises an exception if x is negative" (when (neg? x) (raise :type :illegal-argument :arg 'x :value x)) (+ x y)) (defn main [] ;; simple handler (handler-case :type (println (func 3 4)) (println (func -5 10)) (handle :illegal-argument (print-stack-trace *condition*)) (println 3)) ;; multiple handlers (handler-case :type (println (func 4 1)) (println (func -3 22)) (handle :overflow (print-stack-trace *condition*)) (handle :illegal-argument (print-stack-trace *condition*))) ;; nested handlers (handler-case :type (handler-case :type nil nil (println 1) (println 2) (println 3) (println (func 8 2)) (println (func -6 17)) ;; no handler for :illegal-argument (handle :overflow (println "nested") (print-stack-trace *condition*))) (println (func 3 4)) (println (func -5 10)) (handle :illegal-argument (println "outer") (print-stack-trace *condition*)))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/datalog/000077500000000000000000000000001161102570000264135ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/datalog/example.clj000066400000000000000000000123011161102570000305350ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; example.clj ;; ;; A Clojure implementation of Datalog - Example ;; ;; straszheimjeffrey (gmail) ;; Created 2 March 2009 (ns clojure.contrib.datalog.example (:use [clojure.contrib.datalog :only (build-work-plan run-work-plan)] [clojure.contrib.datalog.rules :only (<- ?- rules-set)] [clojure.contrib.datalog.database :only (make-database add-tuples)] [clojure.contrib.datalog.util :only (*trace-datalog*)])) (def db-base (make-database (relation :employee [:id :name :position]) (index :employee :name) (relation :boss [:employee-id :boss-id]) (index :boss :employee-id) (relation :can-do-job [:position :job]) (index :can-do-job :position) (relation :job-replacement [:job :can-be-done-by]) ;(index :job-replacement :can-be-done-by) (relation :job-exceptions [:id :job]))) (def db (add-tuples db-base [:employee :id 1 :name "Bob" :position :boss] [:employee :id 2 :name "Mary" :position :chief-accountant] [:employee :id 3 :name "John" :position :accountant] [:employee :id 4 :name "Sameer" :position :chief-programmer] [:employee :id 5 :name "Lilian" :position :programmer] [:employee :id 6 :name "Li" :position :technician] [:employee :id 7 :name "Fred" :position :sales] [:employee :id 8 :name "Brenda" :position :sales] [:employee :id 9 :name "Miki" :position :project-management] [:employee :id 10 :name "Albert" :position :technician] [:boss :employee-id 2 :boss-id 1] [:boss :employee-id 3 :boss-id 2] [:boss :employee-id 4 :boss-id 1] [:boss :employee-id 5 :boss-id 4] [:boss :employee-id 6 :boss-id 4] [:boss :employee-id 7 :boss-id 1] [:boss :employee-id 8 :boss-id 7] [:boss :employee-id 9 :boss-id 1] [:boss :employee-id 10 :boss-id 6] [:can-do-job :position :boss :job :management] [:can-do-job :position :accountant :job :accounting] [:can-do-job :position :chief-accountant :job :accounting] [:can-do-job :position :programmer :job :programming] [:can-do-job :position :chief-programmer :job :programming] [:can-do-job :position :technician :job :server-support] [:can-do-job :position :sales :job :sales] [:can-do-job :position :project-management :job :project-management] [:job-replacement :job :pc-support :can-be-done-by :server-support] [:job-replacement :job :pc-support :can-be-done-by :programming] [:job-replacement :job :payroll :can-be-done-by :accounting] [:job-exceptions :id 4 :job :pc-support])) (def rules (rules-set (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) (:employee :id ?e-id :name ?x) (:employee :id ?b-id :name ?y)) (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) (:works-for :employee ?z :boss ?y)) (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) (:can-do-job :position ?pos :job ?y)) (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) (:employee-job* :employee ?x :job ?z)) (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) (:employee :name ?x :position ?z) (if = ?z :boss)) (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) (:employee :id ?id :name ?x) (not! :job-exceptions :id ?id :job ?y)) (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) (not! :employee-job :employee ?y :job :pc-support)))) (def wp-1 (build-work-plan rules (?- :works-for :employee '??name :boss ?x))) (run-work-plan wp-1 db {'??name "Albert"}) (def wp-2 (build-work-plan rules (?- :employee-job :employee '??name :job ?x))) (binding [*trace-datalog* true] (run-work-plan wp-2 db {'??name "Li"})) (def wp-3 (build-work-plan rules (?- :bj :name '??name :boss ?x))) (run-work-plan wp-3 db {'??name "Albert"}) (def wp-4 (build-work-plan rules (?- :works-for :employee ?x :boss ?y))) (run-work-plan wp-4 db {}) ;; End of file clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/miglayout/000077500000000000000000000000001161102570000270125ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/miglayout/example.clj000066400000000000000000000040661161102570000311450ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; clojure.contrib.miglayout.example ;; ;; A temperature converter using miglayout. Demonstrates accessing ;; components by their id constraint. ;; ;; scgilardi (gmail) ;; Created 31 May 2009 (ns clojure.contrib.miglayout.example (:import (javax.swing JButton JFrame JLabel JPanel JTextField SwingUtilities)) (:use (clojure.contrib [miglayout :only (miglayout components)] [swing-utils :only (add-key-typed-listener)]))) (defn fahrenheit "Converts a Celsius temperature to Fahrenheit. Input and output are strings. Returns \"input?\" if the input can't be parsed as a Double." [celsius] (try (format "%.2f" (+ 32 (* 1.8 (Double/parseDouble celsius)))) (catch NumberFormatException _ "input?"))) (defn- handle-key "Clears output on most keys, shows conversion on \"Enter\"" [event out] (.setText out (if (= (.getKeyChar event) \newline) (fahrenheit (-> event .getComponent .getText)) ""))) (defn converter-ui "Lays out and shows a Temperature Converter UI" [] (let [panel (miglayout (JPanel.) (JTextField. 6) {:id :input} (JLabel. "\u00b0Celsius") :wrap (JLabel.) {:id :output} (JLabel. "\u00b0Fahrenheit")) {:keys [input output]} (components panel)] (add-key-typed-listener input handle-key output) (doto (JFrame. "Temperature Converter") (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE) (.add panel) (.pack) (.setVisible true)))) (defn main "Invokes converter-ui in the AWT Event thread" [] (SwingUtilities/invokeLater converter-ui)) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/monads/000077500000000000000000000000001161102570000262615ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/monads/examples.clj000066400000000000000000000325401161102570000305750ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Monad application examples ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ns #^{:author "Konrad Hinsen" :skip-wiki true :doc "Examples for using monads"} clojure.contrib.monads.examples (:use [clojure.contrib.monads :only (domonad with-monad m-lift m-seq m-reduce m-when sequence-m maybe-m state-m fetch-state set-state writer-m write cont-m run-cont call-cc maybe-t)]) (:require (clojure.contrib [accumulators :as accu]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Sequence manipulations with the sequence monad ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Note: in the Haskell world, this monad is called the list monad. ; The Clojure equivalent to Haskell's lists are (possibly lazy) ; sequences. This is why I call this monad "sequence". All sequences ; created by sequence monad operations are lazy. ; Monad comprehensions in the sequence monad work exactly the same ; as Clojure's 'for' construct, except that :while clauses are not ; available. (domonad sequence-m [x (range 5) y (range 3)] (+ x y)) ; Inside a with-monad block, domonad is used without the monad name. (with-monad sequence-m (domonad [x (range 5) y (range 3)] (+ x y))) ; Conditions are written with :when, as in Clojure's for form: (domonad sequence-m [x (range 5) y (range (+ 1 x)) :when (= (+ x y) 2)] (list x y)) ; :let is also supported like in for: (domonad sequence-m [x (range 5) y (range (+ 1 x)) :let [sum (+ x y) diff (- x y)] :when (= sum 2)] (list diff)) ; An example of a sequence function defined in terms of a lift operation. (with-monad sequence-m (defn pairs [xs] ((m-lift 2 #(list %1 %2)) xs xs))) (pairs (range 5)) ; Another way to define pairs is through the m-seq operation. It takes ; a sequence of monadic values and returns a monadic value containing ; the sequence of the underlying values, obtained from chaining together ; from left to right the monadic values in the sequence. (with-monad sequence-m (defn pairs [xs] (m-seq (list xs xs)))) (pairs (range 5)) ; This definition suggests a generalization: (with-monad sequence-m (defn ntuples [n xs] (m-seq (replicate n xs)))) (ntuples 2 (range 5)) (ntuples 3 (range 5)) ; Lift operations can also be used inside a monad comprehension: (domonad sequence-m [x ((m-lift 1 (partial * 2)) (range 5)) y (range 2)] [x y]) ; The m-plus operation does concatenation in the sequence monad. (domonad sequence-m [x ((m-lift 2 +) (range 5) (range 3)) y (m-plus (range 2) '(10 11))] [x y]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Handling failures with the maybe monad ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Maybe monad versions of basic arithmetic (with-monad maybe-m (def m+ (m-lift 2 +)) (def m- (m-lift 2 -)) (def m* (m-lift 2 *))) ; Division is special for two reasons: we can't call it m/ because that's ; not a legal Clojure symbol, and we want it to fail if a division by zero ; is attempted. It is best defined by a monad comprehension with a ; :when clause: (defn safe-div [x y] (domonad maybe-m [a x b y :when (not (zero? b))] (/ a b))) ; Now do some non-trivial computation with division ; It fails for (1) x = 0, (2) y = 0 or (3) y = -x. (with-monad maybe-m (defn some-function [x y] (let [one (m-result 1)] (safe-div one (m+ (safe-div one (m-result x)) (safe-div one (m-result y))))))) ; An example that doesn't fail: (some-function 2 3) ; And two that do fail, at different places: (some-function 2 0) (some-function 2 -2) ; In the maybe monad, m-plus selects the first monadic value that ; holds a valid value. (with-monad maybe-m (m-plus (some-function 2 0) (some-function 2 -2) (some-function 2 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Random numbers with the state monad ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; A state monad item represents a computation that changes a state and ; returns a value. Its structure is a function that takes a state argument ; and returns a two-item list containing the value and the updated state. ; It is important to realize that everything you put into a state monad ; expression is a state monad item (thus a function), and everything you ; get out as well. A state monad does not perform a calculation, it ; constructs a function that does the computation when called. ; First, we define a simple random number generator with explicit state. ; rng is a function of its state (an integer) that returns the ; pseudo-random value derived from this state and the updated state ; for the next iteration. This is exactly the structure of a state ; monad item. (defn rng [seed] (let [m 259200 value (/ (float seed) (float m)) next (rem (+ 54773 (* 7141 seed)) m)] [value next])) ; We define a convenience function that creates an infinite lazy seq ; of values obtained from iteratively applying a state monad value. (defn value-seq [f seed] (lazy-seq (let [[value next] (f seed)] (cons value (value-seq f next))))) ; Next, we define basic statistics functions to check our random numbers (defn sum [xs] (apply + xs)) (defn mean [xs] (/ (sum xs) (count xs))) (defn variance [xs] (let [m (mean xs) sq #(* % %)] (mean (for [x xs] (sq (- x m)))))) ; rng implements a uniform distribution in the interval [0., 1.), so ; ideally, the mean would be 1/2 (0.5) and the variance 1/12 (0.8333). (mean (take 1000 (value-seq rng 1))) (variance (take 1000 (value-seq rng 1))) ; We make use of the state monad to implement a simple (but often sufficient) ; approximation to a Gaussian distribution: the sum of 12 random numbers ; from rng's distribution, shifted by -6, has a distribution that is ; approximately Gaussian with 0 mean and variance 1, by virtue of the central ; limit theorem. ; In the first version, we call rng 12 times explicitly and calculate the ; shifted sum in a monad comprehension: (def gaussian1 (domonad state-m [x1 rng x2 rng x3 rng x4 rng x5 rng x6 rng x7 rng x8 rng x9 rng x10 rng x11 rng x12 rng] (- (+ x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) 6.))) ; Let's test it: (mean (take 1000 (value-seq gaussian1 1))) (variance (take 1000 (value-seq gaussian1 1))) ; Of course, we'd rather have a loop construct for creating the 12 ; random numbers. This would be easy if we could define a summation ; operation on random-number generators, which would then be used in ; combination with reduce. The lift operation gives us exactly that. ; More precisely, we need (m-lift 2 +), because we want both arguments ; of + to be lifted to the state monad: (def gaussian2 (domonad state-m [sum12 (reduce (m-lift 2 +) (replicate 12 rng))] (- sum12 6.))) ; Such a reduction is often quite useful, so there's m-reduce predefined ; to simplify it: (def gaussian2 (domonad state-m [sum12 (m-reduce + (replicate 12 rng))] (- sum12 6.))) ; The statistics should be strictly the same as above, as long as ; we use the same seed: (mean (take 1000 (value-seq gaussian2 1))) (variance (take 1000 (value-seq gaussian2 1))) ; We can also do the subtraction of 6 in a lifted function, and get rid ; of the monad comprehension altogether: (with-monad state-m (def gaussian3 ((m-lift 1 #(- % 6.)) (m-reduce + (replicate 12 rng))))) ; Again, the statistics are the same: (mean (take 1000 (value-seq gaussian3 1))) (variance (take 1000 (value-seq gaussian3 1))) ; For a random point in two dimensions, we'd like a random number generator ; that yields a list of two random numbers. The m-seq operation can easily ; provide it: (with-monad state-m (def rng2 (m-seq (list rng rng)))) ; Let's test it: (rng2 1) ; fetch-state and get-state can be used to save the seed of the random ; number generator and go back to that saved seed later on: (def identical-random-seqs (domonad state-m [seed (fetch-state) x1 rng x2 rng _ (set-state seed) y1 rng y2 rng] (list [x1 x2] [y1 y2]))) (identical-random-seqs 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Logging with the writer monad ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; A basic logging example (domonad (writer-m accu/empty-string) [x (m-result 1) _ (write "first step\n") y (m-result 2) _ (write "second step\n")] (+ x y)) ; For a more elaborate application, let's trace the recursive calls of ; a naive implementation of a Fibonacci function. The starting point is: (defn fib [n] (if (< n 2) n (let [n1 (dec n) n2 (dec n1)] (+ (fib n1) (fib n2))))) ; First we rewrite it to make every computational step explicit ; in a let expression: (defn fib [n] (if (< n 2) n (let [n1 (dec n) n2 (dec n1) f1 (fib n1) f2 (fib n2)] (+ f1 f2)))) ; Next, we replace the let by a domonad in a writer monad that uses a ; vector accumulator. We can then place calls to write in between the ; steps, and obtain as a result both the return value of the function ; and the accumulated trace values. (with-monad (writer-m accu/empty-vector) (defn fib-trace [n] (if (< n 2) (m-result n) (domonad [n1 (m-result (dec n)) n2 (m-result (dec n1)) f1 (fib-trace n1) _ (write [n1 f1]) f2 (fib-trace n2) _ (write [n2 f2]) ] (+ f1 f2)))) ) (fib-trace 5) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Sequences with undefined value: the maybe-t monad transformer ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; A monad transformer is a function that takes a monad argument and ; returns a monad as its result. The resulting monad adds some ; specific behaviour aspect to the input monad. ; The simplest monad transformer is maybe-t. It adds the functionality ; of the maybe monad (handling failures or undefined values) to any other ; monad. We illustrate this by applying maybe-t to the sequence monad. ; The result is an enhanced sequence monad in which undefined values ; (represented by nil) are not subjected to any transformation, but ; lead immediately to a nil result in the output. ; First we define the combined monad: (def seq-maybe-m (maybe-t sequence-m)) ; As a first illustration, we create a range of integers and replace ; all even values by nil, using a simple when expression. We use this ; sequence in a monad comprehension that yields (inc x). The result ; is a sequence in which inc has been applied to all non-nil values, ; whereas the nil values appear unmodified in the output: (domonad seq-maybe-m [x (for [n (range 10)] (when (odd? n) n))] (inc x)) ; Next we repeat the definition of the function pairs (see above), but ; using the seq-maybe monad: (with-monad seq-maybe-m (defn pairs-maybe [xs] (m-seq (list xs xs)))) ; Applying this to a sequence containing nils yields the pairs of all ; non-nil values interspersed with nils that result from any combination ; in which one or both of the values is nil: (pairs-maybe (for [n (range 5)] (when (odd? n) n))) ; It is important to realize that undefined values (nil) are not eliminated ; from the iterations. They are simply not passed on to any operations. ; The outcome of any function applied to arguments of which at least one ; is nil is supposed to be nil as well, and the function is never called. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Continuation-passing style in the cont monad ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; A simple computation performed in continuation-passing style. ; (m-result 1) returns a function that, when called with a single ; argument f, calls (f 1). The result of the domonad-computation is ; a function that behaves in the same way, passing 3 to its function ; argument. run-cont executes a continuation by calling it on identity. (run-cont (domonad cont-m [x (m-result 1) y (m-result 2)] (+ x y))) ; Let's capture a continuation using call-cc. We store it in a global ; variable so that we can do with it whatever we want. The computation ; is the same one as in the first example, but it has the side effect ; of storing the continuation at (m-result 2). (def continuation nil) (run-cont (domonad cont-m [x (m-result 1) y (call-cc (fn [c] (def continuation c) (c 2)))] (+ x y))) ; Now we can call the continuation with whatever argument we want. The ; supplied argument takes the place of 2 in the above computation: (run-cont (continuation 5)) (run-cont (continuation 42)) (run-cont (continuation -1)) ; Next, a function that illustrates how a captured continuation can be ; used as an "emergency exit" out of a computation: (defn sqrt-as-str [x] (call-cc (fn [k] (domonad cont-m [_ (m-when (< x 0) (k (str "negative argument " x)))] (str (. Math sqrt x)))))) (run-cont (sqrt-as-str 2)) (run-cont (sqrt-as-str -2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/000077500000000000000000000000001161102570000263145ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/000077500000000000000000000000001161102570000301325ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/hexdump.clj000066400000000000000000000043101161102570000322740ustar00rootroot00000000000000;;; hexdump.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This example is a classic hexdump program written using cl-format. ;; For some local color, it was written in Dulles Airport while waiting for a flight ;; home to San Francisco. (ns clojure.contrib.pprint.examples.hexdump (:use clojure.contrib.pprint clojure.contrib.pprint.utilities) (:gen-class (:main true))) (def *buffer-length* 1024) (defn zip-array [base-offset arr] (let [grouped (partition 16 arr)] (first (map-passing-context (fn [line offset] [[offset (map #(if (neg? %) (+ % 256) %) line) (- 16 (count line)) (map #(if (<= 32 % 126) (char %) \.) line)] (+ 16 offset)]) base-offset grouped)))) (defn hexdump ([in-stream] (hexdump in-stream true 0)) ([in-stream out-stream] (hexdump [in-stream out-stream 0])) ([in-stream out-stream offset] (let [buf (make-array Byte/TYPE *buffer-length*)] (loop [offset offset count (.read in-stream buf)] (if (neg? count) nil (let [bytes (take count buf) zipped (zip-array offset bytes)] (cl-format out-stream "~:{~8,'0X: ~2{~8@{~#[ ~:;~2,'0X ~]~} ~}~v@{ ~}~2{~8@{~A~} ~}~%~}" zipped) (recur (+ offset *buffer-length*) (.read in-stream buf)))))))) (defn hexdump-file ([file-name] (hexdump-file file-name true)) ([file-name stream] (with-open [s (java.io.FileInputStream. file-name)] (hexdump s)))) ;; I don't quite understand how to invoke main funcs w/o AOT yet (defn -main [& args] (hexdump-file (first args))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/json.clj000066400000000000000000000111051161102570000315730ustar00rootroot00000000000000;;; json.clj: A pretty printing version of the JavaScript Object Notation (JSON) generator ;; by Tom Faulhaber, based on the version by Stuart Sierra (clojure.contrib.json.write) ;; May 9, 2009 ;; Copyright (c) Tom Faulhaber/Stuart Sierra, 2009. 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 #^{:author "Tom Faulhaber (based on the version by Stuart Sierra)", :doc "Pretty printing JavaScript Object Notation (JSON) generator. This is an example of using a pretty printer dispatch function to generate JSON output", :see-also [["http://json.org/", "JSON Home Page"]]} clojure.contrib.pprint.examples.json (:use [clojure.test :only (deftest- is)] [clojure.contrib.string :only (as-str)] [clojure.contrib.pprint :only (write formatter-out)])) (defmulti dispatch-json "The dispatch function for printing objects as JSON" {:arglists '[[x]]} (fn [x] (cond (nil? x) nil ;; prevent NullPointerException on next line (.isArray (class x)) ::array :else (type x)))) ;; Primitive types can be printed with Clojure's pr function. (derive java.lang.Boolean ::pr) (derive java.lang.Byte ::pr) (derive java.lang.Short ::pr) (derive java.lang.Integer ::pr) (derive java.lang.Long ::pr) (derive java.lang.Float ::pr) (derive java.lang.Double ::pr) ;; Collection types can be printed as JSON objects or arrays. (derive java.util.Map ::object) (derive java.util.Collection ::array) ;; Symbols and keywords are converted to strings. (derive clojure.lang.Symbol ::symbol) (derive clojure.lang.Keyword ::symbol) (defmethod dispatch-json ::pr [x] (pr x)) (defmethod dispatch-json nil [x] (print "null")) (defmethod dispatch-json ::symbol [x] (pr (name x))) (defmethod dispatch-json ::array [s] ((formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>") s)) (defmethod dispatch-json ::object [m] ((formatter-out "~<{~;~@{~<~w:~_~w~:>~^, ~_~}~;}~:>") (for [[k v] m] [(as-str k) v]))) (defmethod dispatch-json java.lang.CharSequence [s] (print \") (dotimes [i (count s)] (let [cp (Character/codePointAt s i)] (cond ;; Handle printable JSON escapes before ASCII (= cp 34) (print "\\\"") (= cp 92) (print "\\\\") ;; Print simple ASCII characters (< 31 cp 127) (print (.charAt s i)) ;; Handle non-printable JSON escapes (= cp 8) (print "\\b") (= cp 12) (print "\\f") (= cp 10) (print "\\n") (= cp 13) (print "\\r") (= cp 9) (print "\\t") ;; Any other character is printed as Hexadecimal escape :else (printf "\\u%04x" cp)))) (print \")) (defn print-json "Prints x as JSON. Nil becomes JSON null. Keywords become strings, without the leading colon. Maps become JSON objects, all other collection types become JSON arrays. Java arrays become JSON arrays. Unicode characters in strings are escaped as \\uXXXX. Numbers print as with pr." [x] (write x :dispatch dispatch-json)) (defn json-str "Converts x to a JSON-formatted string." [x] (with-out-str (print-json x))) ;;; TESTS ;; Run these tests with ;; (clojure.test/run-tests 'clojure.contrib.print-json) ;; Bind clojure.test/*load-tests* to false to omit these ;; tests from production code. (deftest- can-print-json-strings (is (= "\"Hello, World!\"" (json-str "Hello, World!"))) (is (= "\"\\\"Embedded\\\" Quotes\"" (json-str "\"Embedded\" Quotes")))) (deftest- can-print-unicode (is (= "\"\\u1234\\u4567\"" (json-str "\u1234\u4567")))) (deftest- can-print-json-null (is (= "null" (json-str nil)))) (deftest- can-print-json-arrays (is (= "[1, 2, 3]" (json-str [1 2 3]))) (is (= "[1, 2, 3]" (json-str (list 1 2 3)))) (is (= "[1, 2, 3]" (json-str (sorted-set 1 2 3)))) (is (= "[1, 2, 3]" (json-str (seq [1 2 3]))))) (deftest- can-print-java-arrays (is (= "[1, 2, 3]" (json-str (into-array [1 2 3]))))) (deftest- can-print-empty-arrays (is (= "[]" (json-str []))) (is (= "[]" (json-str (list)))) (is (= "[]" (json-str #{})))) (deftest- can-print-json-objects (is (= "{\"a\":1, \"b\":2}" (json-str (sorted-map :a 1 :b 2))))) (deftest- object-keys-must-be-strings (is (= "{\"1\":1, \"2\":2}" (json-str (sorted-map 1 1 2 2))))) (deftest- can-print-empty-objects (is (= "{}" (json-str {})))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/multiply.clj000066400000000000000000000016121161102570000325030ustar00rootroot00000000000000;;; multiply.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This example prints a multiplication table using cl-format. (ns clojure.contrib.pprint.examples.multiply (:use clojure.contrib.pprint)) (defn multiplication-table [limit] (let [nums (range 1 (inc limit))] (cl-format true "~{~{~4d~}~%~}" (map #(map % nums) (map #(partial * %) nums))))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/props.clj000066400000000000000000000017351161102570000317750ustar00rootroot00000000000000;;; props.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This example displays a nicely formatted table of the java properties using ;; cl-format (ns clojure.contrib.pprint.examples.props (:use clojure.contrib.pprint)) (defn show-props [stream] (let [p (mapcat #(vector (key %) (val %)) (sort-by key (System/getProperties)))] (cl-format true "~30A~A~%~{~20,,,'-A~10A~}~%~{~30A~S~%~}" "Property" "Value" ["" "" "" ""] p))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/show_doc.clj000066400000000000000000000033001161102570000324250ustar00rootroot00000000000000;;; show_doc.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This example uses cl-format as part of a routine to display all the doc ;; strings and function arguments from one or more namespaces. (ns clojure.contrib.pprint.examples.show-doc (:use clojure.contrib.pprint)) (defn ns-list ([] (ns-list nil)) ([pattern] (filter (if pattern (comp (partial re-find pattern) name ns-name) (constantly true)) (sort-by ns-name (all-ns))))) (defn show-doc ([] (show-doc nil)) ([pattern] (cl-format true "~:{~A: ===============================================~ ~%~{~{~a: ~{~a~^, ~}~%~a~%~}~^~%~}~2%~}" (map #(vector (ns-name %) (map (fn [f] (let [f-meta (meta (find-var (symbol (str (ns-name %)) (str f))))] [f (:arglists f-meta) (:doc f-meta)])) (filter (fn [a] (instance? clojure.lang.IFn a)) (sort (map key (ns-publics %)))))) (ns-list pattern))))) (defn create-api-file [pattern out-file] (with-open [f (java.io.FileWriter. out-file)] (binding [*out* f] (show-doc pattern)))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/pprint/examples/xml.clj000066400000000000000000000103241161102570000314240ustar00rootroot00000000000000;;; xml.clj -- a pretty print dispatch version of prxml.clj -- a compact syntax for generating XML ;; by Tom Faulhaber, based on the original by Stuart Sierra, http://stuartsierra.com/ ;; May 13, 2009 ;; Copyright (c) 2009 Tom Faulhaber/Stuart Sierra. 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. ;; See function "prxml" at the bottom of this file for documentation. (ns #^{:author "Tom Faulhaber, based on the original by Stuart Sierra", :doc "A version of prxml that uses a pretty print dispatch function."} clojure.contrib.pprint.examples.xml (:use [clojure.contrib.string :only (as-str escape)] [clojure.contrib.pprint :only (formatter-out write)] [clojure.contrib.pprint.utilities :only (prlabel)])) (def #^{:doc "If true, empty tags will have a space before the closing />"} *html-compatible* false) (def #^{:doc "The number of spaces to indent sub-tags."} *prxml-indent* 2) (defmulti #^{:private true} print-xml-tag (fn [tag attrs content] tag)) (defmethod print-xml-tag :raw! [tag attrs contents] (doseq [c contents] (print c))) (defmethod print-xml-tag :comment! [tag attrs contents] (print "")) (defmethod print-xml-tag :decl! [tag attrs contents] (let [attrs (merge {:version "1.0" :encoding "UTF-8"} attrs)] ;; Must enforce ordering of pseudo-attributes: ((formatter-out "") (:version attrs) (:encoding attrs) (:standalone attrs)))) (defmethod print-xml-tag :cdata! [tag attrs contents] ((formatter-out "<[!CDATA[~{~a~}]]>") contents)) (defmethod print-xml-tag :doctype! [tag attrs contents] ((formatter-out "<[!DOCTYPE [~{~a~}]]>") contents)) (defmethod print-xml-tag :default [tag attrs contents] (let [tag-name (as-str tag) xlated-attrs (map #(vector (as-str (key %)) (as-str (val %))) attrs)] (if (seq contents) ((formatter-out "~<~<<~a~1:i~{ ~:_~{~a=\"~a\"~}~}>~:>~vi~{~_~w~}~0i~_~:>") [[tag-name xlated-attrs] *prxml-indent* contents tag-name]) ((formatter-out "~<<~a~1:i~{~:_ ~{~a=\"~a\"~}~}/>~:>") [tag-name xlated-attrs])))) (defmulti xml-dispatch class) (defmethod xml-dispatch clojure.lang.IPersistentVector [x] (let [[tag & contents] x [attrs content] (if (map? (first contents)) [(first contents) (rest contents)] [{} contents])] (print-xml-tag tag attrs content))) (defmethod xml-dispatch clojure.lang.ISeq [x] ;; Recurse into sequences, so we can use (map ...) inside prxml. (doseq [c x] (xml-dispatch c))) (defmethod xml-dispatch clojure.lang.Keyword [x] (print-xml-tag x {} nil)) (defmethod xml-dispatch String [x] (print (escape {\< "<" \> ">" \& "&" \' "'" \" """} x))) (defmethod xml-dispatch nil [x]) (defmethod xml-dispatch :default [x] (print x)) (defn prxml "Print XML to *out*. Vectors become XML tags: the first item is the tag name; optional second item is a map of attributes. Sequences are processed recursively, so you can use map and other sequence functions inside prxml. (prxml [:p {:class \"greet\"} [:i \"Ladies & gentlemen\"]]) ; =>

Ladies & gentlemen

PSEUDO-TAGS: some keywords have special meaning: :raw! do not XML-escape contents :comment! create an XML comment :decl! create an XML declaration, with attributes :cdata! create a CDATA section :doctype! create a DOCTYPE! (prxml [:p [:raw! \"here & gone\"]]) ; =>

here & gone

(prxml [:decl! {:version \"1.1\"}]) ; => " [& args] (doseq [arg args] (write arg :dispatch xml-dispatch)) (when (pos? (count args)) (newline))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/probabilities/000077500000000000000000000000001161102570000276305ustar00rootroot00000000000000examples_finite_distributions.clj000066400000000000000000000152671161102570000364140ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/probabilities;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Probability distribution application examples ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ns #^{:author "Konrad Hinsen" :skip-wiki true :doc "Examples for finite probability distribution"} clojure.contrib.probabilities.examples-finite-distributions (:use [clojure.contrib.probabilities.finite-distributions :only (uniform prob cond-prob join-with dist-m choose normalize certainly cond-dist-m normalize-cond)]) (:use [clojure.contrib.monads :only (domonad with-monad m-seq m-chain m-lift)]) (:require clojure.contrib.accumulators)) ;; Simple examples using dice ; A single die is represented by a uniform distribution over the ; six possible outcomes. (def die (uniform #{1 2 3 4 5 6})) ; The probability that the result is odd... (prob odd? die) ; ... or greater than four. (prob #(> % 4) die) ; The sum of two dice (def two-dice (join-with + die die)) (prob #(> % 6) two-dice) ; The sum of two dice using a monad comprehension (assert (= two-dice (domonad dist-m [d1 die d2 die] (+ d1 d2)))) ; The two values separately, but as an ordered pair (domonad dist-m [d1 die d2 die] (if (< d1 d2) (list d1 d2) (list d2 d1))) ; The conditional probability for two dice yielding X if X is odd: (cond-prob odd? two-dice) ; A two-step experiment: throw a die, and then add 1 with probability 1/2 (domonad dist-m [d die x (choose (/ 1 2) d :else (inc d))] x) ; The sum of n dice (defn dice [n] (domonad dist-m [ds (m-seq (replicate n die))] (apply + ds))) (assert (= two-dice (dice 2))) (dice 3) ;; Construct an empirical distribution from counters ; Using an ordinary counter: (def dist1 (normalize (clojure.contrib.accumulators/add-items clojure.contrib.accumulators/empty-counter (for [_ (range 1000)] (rand-int 5))))) ; Or, more efficiently, using a counter that already keeps track of its total: (def dist2 (normalize (clojure.contrib.accumulators/add-items clojure.contrib.accumulators/empty-counter-with-total (for [_ (range 1000)] (rand-int 5))))) ;; The Monty Hall game ;; (see http://en.wikipedia.org/wiki/Monty_Hall_problem for a description) ; The set of doors. In the classical variant, there are three doors, ; but the code can also work with more than three doors. (def doors #{:A :B :C}) ; A simulation of the game, step by step: (domonad dist-m [; The prize is hidden behind one of the doors. prize (uniform doors) ; The player make his initial choice. choice (uniform doors) ; The host opens a door which is neither the prize door nor the ; one chosen by the player. opened (uniform (disj doors prize choice)) ; If the player stays with his initial choice, the game ends and the ; following line should be commented out. It describes the switch from ; the initial choice to a door that is neither the opened one nor ; his original choice. choice (uniform (disj doors opened choice)) ] ; If the chosen door has the prize behind it, the player wins. (if (= choice prize) :win :loose)) ;; Tree growth simulation ;; Adapted from the code in: ;; Martin Erwig and Steve Kollmansberger, ;; "Probabilistic Functional Programming in Haskell", ;; Journal of Functional Programming, Vol. 16, No. 1, 21-34, 2006 ;; http://web.engr.oregonstate.edu/~erwig/papers/abstracts.html#JFP06a ; A tree is represented by two attributes: its state (alive, hit, fallen), ; and its height (an integer). A new tree starts out alive and with zero height. (def new-tree {:state :alive, :height 0}) ; An evolution step in the simulation modifies alive trees only. They can ; either grow by one (90% probability), be hit by lightning and then stop ; growing (4% probability), or fall down (6% probability). (defn evolve-1 [tree] (let [{s :state h :height} tree] (if (= s :alive) (choose 0.9 (assoc tree :height (inc (:height tree))) 0.04 (assoc tree :state :hit) :else {:state :fallen, :height 0}) (certainly tree)))) ; Multiple evolution steps can be chained together with m-chain, ; since each step's input is the output of the previous step. (with-monad dist-m (defn evolve [n tree] ((m-chain (replicate n evolve-1)) tree))) ; Try it for zero, one, or two steps. (evolve 0 new-tree) (evolve 1 new-tree) (evolve 2 new-tree) ; We can also get a distribution of the height only: (with-monad dist-m ((m-lift 1 :height) (evolve 2 new-tree))) ;; Bayesian inference ;; ;; Suppose someone has three dice, one with six faces, one with eight, and ;; one with twelve. This person throws one die and gives us the number, ;; but doesn't tell us which die it was. What are the Bayesian probabilities ;; for each of the three dice, given the observation we have? ; A function that returns the distribution of a dice with n faces. (defn die-n [n] (uniform (range 1 (inc n)))) ; The three dice in the game with their distributions. With this map, we ; can easily calculate the probability for an observation under the ; condition that a particular die was used. (def dice {:six (die-n 6) :eight (die-n 8) :twelve (die-n 12)}) ; The only prior knowledge is that one of the three dice is used, so we ; have no better than a uniform distribution to start with. (def prior (uniform (keys dice))) ; Add a single observation to the information contained in the ; distribution. Adding an observation consists of ; 1) Draw a die from the prior distribution. ; 2) Draw an observation from the distribution of that die. ; 3) Eliminate (replace by nil) the trials that do not match the observation. ; 4) Normalize the distribution for the non-nil values. (defn add-observation [prior observation] (normalize-cond (domonad cond-dist-m [die prior number (get dice die) :when (= number observation) ] die))) ; Add one observation. (add-observation prior 1) ; Add three consecutive observations. (-> prior (add-observation 1) (add-observation 3) (add-observation 7)) ; We can also add multiple observations in a single trial, but this ; is slower because more combinations have to be taken into account. ; With Bayesian inference, it is most efficient to eliminate choices ; as early as possible. (defn add-observations [prior observations] (with-monad cond-dist-m (let [n-nums #(m-seq (replicate (count observations) (get dice %)))] (normalize-cond (domonad [die prior nums (n-nums die) :when (= nums observations)] die))))) (add-observations prior [1 3 7]) examples_monte_carlo.clj000066400000000000000000000042771161102570000344550ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/probabilities;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Monte-Carlo application examples ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ns #^{:author "Konrad Hinsen" :skip-wiki true :doc "Examples for monte carlo methods"} clojure.contrib.probabilities.random.examples-monte-carlo (:require [clojure.contrib.generic.collection :as gc]) (:use [clojure.contrib.probabilities.random-numbers :only (lcg rand-stream)]) (:use [clojure.contrib.probabilities.finite-distributions :only (uniform)]) (:use [clojure.contrib.probabilities.monte-carlo :only (random-stream discrete interval normal lognormal exponential n-sphere sample sample-sum sample-mean sample-mean-variance)] :reload) (:use [clojure.contrib.monads :only (domonad state-m)])) ; Create a linear congruential generator (def urng (lcg 259200 7141 54773 1)) ;; Use Clojure's built-in random number generator ;(def urng rand-stream) ; Sample transformed distributions (defn sample-distribution [n rt] (take n (gc/seq (random-stream rt urng)))) ; Interval [-2, 2) (sample-distribution 10 (interval -2 2)) ; Compare with a direct transformation (= (sample-distribution 10 (interval -2 2)) (map (fn [x] (- (* 4 x) 2)) (take 10 (gc/seq urng)))) ; Normal distribution (sample-distribution 10 (normal 0 1)) ; Log-Normal distribution (sample-distribution 10 (lognormal 0 1)) ; Exponential distribution (sample-distribution 10 (exponential 1)) ; n-sphere distribution (sample-distribution 10 (n-sphere 2 1)) ; Discrete distribution (sample-distribution 10 (discrete (uniform (range 1 7)))) ; Compose distributions in the state monad (def sum-two-dists (domonad state-m [r1 (interval -2 2) r2 (normal 0 1)] (+ r1 r2))) (sample-distribution 10 sum-two-dists) ; Distribution transformations (sample-distribution 5 (sample 2 (interval -2 2))) (sample-distribution 10 (sample-sum 10 (interval -2 2))) (sample-distribution 10 (sample-mean 10 (interval -2 2))) (sample-distribution 10 (sample-mean-variance 10 (interval -2 2))) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/stream_utils/000077500000000000000000000000001161102570000275135ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/stream_utils/examples.clj000066400000000000000000000052161161102570000320270ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Stream application examples ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ns #^{:author "Konrad Hinsen" :skip-wiki true :doc "Examples for data streams"} clojure.contrib.stream-utils.examples (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.stream-utils :only (defst stream-next pick pick-all stream-type defstream stream-drop stream-map stream-filter stream-flatten)]) (:use [clojure.contrib.monads :only (domonad)]) (:use [clojure.contrib.types :only (deftype)]) (:require [clojure.contrib.generic.collection :as gc])) ; ; Define a stream of Fibonacci numbers ; (deftype ::fib-stream last-two-fib) (defstream ::fib-stream [fs] (let [[n1 n2] fs] [n1 (last-two-fib [n2 (+ n1 n2)])])) (def fib-stream (last-two-fib [0 1])) (take 10 (gc/seq fib-stream)) ; ; A simple random number generator, implemented as a stream ; (deftype ::random-seed rng-seed vector seq) (defstream ::random-seed [seed] (let [[seed] seed m 259200 value (/ (float seed) (float m)) next (rem (+ 54773 (* 7141 seed)) m)] [value (rng-seed next)])) (take 10 (gc/seq (rng-seed 1))) ; ; Various stream utilities ; (take 10 (gc/seq (stream-drop 10 (rng-seed 1)))) (gc/seq (stream-map inc (range 5))) (gc/seq (stream-filter odd? (range 10))) (gc/seq (stream-flatten (partition 3 (range 9)))) ; ; Stream transformers ; ; Transform a stream of numbers into a stream of sums of two ; consecutive numbers. (defst sum-two [] [xs] (domonad [x1 (pick xs) x2 (pick xs)] (+ x1 x2))) (def s (sum-two '(1 2 3 4 5 6 7 8))) (let [[v1 s] (stream-next s)] (let [[v2 s] (stream-next s)] (let [[v3 s] (stream-next s)] (let [[v4 s] (stream-next s)] (let [[v5 s] (stream-next s)] [v1 v2 v3 v4 v5]))))) (gc/seq s) ; Map (for a single stream) written as a stream transformer (defst my-map-1 [f] [xs] (domonad [x (pick xs)] (f x))) (gc/seq (my-map-1 inc [1 2 3])) ; Map for two stream arguments (defst my-map-2 [f] [xs ys] (domonad [x (pick xs) y (pick ys)] (f x y))) (gc/seq (my-map-2 + '(1 2 3 4) '(10 20 30 40))) ; Map for any number of stream arguments (defst my-map [f] [& streams] (domonad [vs pick-all] (apply f vs))) (gc/seq (my-map inc [1 2 3])) (gc/seq (my-map + '(1 2 3 4) '(10 20 30 40))) ; Filter written as a stream transformer (defst my-filter [p] [xs] (domonad [x (pick xs) :when (p x)] x)) (gc/seq (my-filter odd? [1 2 3])) clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/types/000077500000000000000000000000001161102570000261445ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/examples/clojure/clojure/contrib/types/examples.clj000066400000000000000000000074201161102570000304570ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; 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)) clojure-contrib_1.2.0.orig/src/main/000077500000000000000000000000001161102570000173405ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/assembly/000077500000000000000000000000001161102570000211575ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/assembly/dist.xml000066400000000000000000000017361161102570000226530ustar00rootroot00000000000000 dist zip tar.gz tar.bz2 ${project.basedir} / true README.* epl-v10.* NOTICE.* Revisions pom.xml src/** target/*.jar launchers/** clojurescript/** clojure-contrib_1.2.0.orig/src/main/clojure/000077500000000000000000000000001161102570000210035ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/000077500000000000000000000000001161102570000224465ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/000077500000000000000000000000001161102570000241065ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/accumulators.clj000066400000000000000000000211771161102570000273120ustar00rootroot00000000000000;; Accumulators ;; by Konrad Hinsen ;; last updated May 19, 2009 ;; This module defines various accumulators (list, vector, map, ;; sum, product, counter, and combinations thereof) with a common ;; interface defined by the multimethods add and combine. ;; For each accumulator type, its empty value is defined in this module. ;; Applications typically use this as a starting value and add data ;; using the add multimethod. ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "A generic accumulator interface and implementations of various accumulators."} clojure.contrib.accumulators (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.types :only (deftype)]) (:use [clojure.contrib.def :only (defvar defvar- defmacro-)]) (:require [clojure.contrib.generic.arithmetic :as ga])) (defmulti add "Add item to the accumulator acc. The exact meaning of adding an an item depends on the type of the accumulator." {:arglists '([acc item])} (fn [acc item] (type acc))) (defn add-items "Add all elements of a collection coll to the accumulator acc." [acc items] (reduce add acc items)) (defmulti combine "Combine the values of the accumulators acc1 and acc2 into a single accumulator of the same type." {:arglists '([& accs])} (fn [& accs] (type (first accs)))) ; ; An ::accumulator type tag is attached to tbe built-in types ; when used as accumulators, and new types are derived from it. ; Multimethods add and combine for ::accumulator sub-dispatch on class. ; We also define generic addition as the combine operation. ; (let [meta-map {:type ::accumulator}] (defn- with-acc-tag [x] (with-meta x meta-map))) (defmethod add ::accumulator [a e] ((get-method add (class a)) a e)) (defmethod combine ::accumulator [& as] (apply (get-method combine (class (first as))) as)) (defmethod ga/+ ::accumulator [x y] (combine x y)) ; ; Vector accumulator ; (defvar empty-vector (with-acc-tag []) "An empty vector accumulator. Adding an item appends it at the end.") (defmethod combine clojure.lang.IPersistentVector [& vs] (with-acc-tag (vec (apply concat vs)))) (defmethod add clojure.lang.IPersistentVector [v e] (with-acc-tag (conj v e))) ; ; List accumulator ; (defvar empty-list (with-acc-tag '()) "An empty list accumulator. Adding an item appends it at the beginning.") (defmethod combine clojure.lang.IPersistentList [& vs] (with-acc-tag (apply concat vs))) (defmethod add clojure.lang.IPersistentList [v e] (with-acc-tag (conj v e))) ; ; Queue accumulator ; (defvar empty-queue (with-acc-tag clojure.lang.PersistentQueue/EMPTY) "An empty queue accumulator. Adding an item appends it at the end.") (defmethod combine clojure.lang.PersistentQueue [& vs] (add-items (first vs) (apply concat (rest vs)))) (defmethod add clojure.lang.PersistentQueue [v e] (with-acc-tag (conj v e))) ; ; Set accumulator ; (defvar empty-set (with-acc-tag #{}) "An empty set accumulator.") (defmethod combine (class empty-set) [& vs] (with-acc-tag (apply clojure.set/union vs))) (defmethod add (class empty-set) [v e] (with-acc-tag (conj v e))) ; ; String accumulator ; (defvar empty-string "" "An empty string accumulator. Adding an item (string or character) appends it at the end.") (defmethod combine java.lang.String [& vs] (apply str vs)) (defmethod add java.lang.String [v e] (str v e)) ; ; Map accumulator ; (defvar empty-map (with-acc-tag {}) "An empty map accumulator. Items to be added must be [key value] pairs.") (defmethod combine clojure.lang.IPersistentMap [& vs] (with-acc-tag (apply merge vs))) (defmethod add clojure.lang.IPersistentMap [v e] (with-acc-tag (conj v e))) ; ; Numerical accumulators: sum, product, minimum, maximum ; (defmacro- defacc [name op empty doc-string] (let [type-tag (keyword (str *ns*) (str name)) empty-symbol (symbol (str "empty-" name))] `(let [op# ~op] (deftype ~type-tag ~name (fn [~'x] {:value ~'x}) (fn [~'x] (list (:value ~'x)))) (derive ~type-tag ::accumulator) (defvar ~empty-symbol (~name ~empty) ~doc-string) (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.") (defacc product * 1 "An empty sum accumulator. Only numbers can be added.") ; The empty maximum accumulator should have value -infinity. ; This is represented by nil and taken into account in an ; adapted max function. In the minimum accumulator, nil is ; similarly used to represent +infinity. (defacc maximum (fn [& xs] (when-let [xs (seq (filter identity xs))] (apply max xs))) nil "An empty maximum accumulator. Only numbers can be added.") (defacc minimum (fn [& xs] (when-let [xs (seq (filter identity xs))] (apply min xs))) nil "An empty minimum accumulator. Only numbers can be added.") ; ; Numeric min-max accumulator ; (combination of minimum and maximum) ; (deftype ::min-max min-max (fn [min max] {:min min :max max}) (fn [mm] (list (:min mm) (:max mm)))) (derive ::min-max ::accumulator) (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 [& vs] (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 [v e] (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))) ; ; Mean and variance accumulator ; (deftype ::mean-variance mean-variance) (derive ::mean-variance ::accumulator) (defvar empty-mean-variance (mean-variance {:n 0 :mean 0 :variance 0}) "An empty mean-variance accumulator, combining sample mean and sample variance. Only numbers can be added.") (defmethod combine ::mean-variance ([mv] mv) ([mv1 mv2] (let [{n1 :n mean1 :mean var1 :variance} mv1 {n2 :n mean2 :mean var2 :variance} mv2 n (+ n1 n2) mean (/ (+ (* n1 mean1) (* n2 mean2)) n) sq #(* % %) c (+ (* n1 (sq (- mean mean1))) (* n2 (sq (- mean mean2)))) var (if (< n 2) 0 (/ (+ c (* (dec n1) var1) (* (dec n2) var2)) (dec n)))] (mean-variance {:n n :mean mean :variance var}))) ([mv1 mv2 & mvs] (reduce combine (combine mv1 mv2) mvs))) (defmethod add ::mean-variance [mv x] (let [{n :n mean :mean var :variance} mv n1 (inc n) d (- x mean) new-mean (+ mean (/ d n1)) new-var (if (zero? n) 0 (/ (+ (* (dec n) var) (* d (- x new-mean))) n))] (mean-variance {:n n1 :mean new-mean :variance new-var}))) ; ; Counter accumulator ; (deftype ::counter counter) (derive ::counter ::accumulator) (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 ::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 ::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) (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 ::counter-with-total [v e] (assoc v e (inc (get v e 0)) :total (inc (:total v)))) ; ; Accumulator n-tuple ; (deftype ::tuple acc-tuple) (derive ::tuple ::accumulator) (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)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/agent_utils.clj000066400000000000000000000023471161102570000271240ustar00rootroot00000000000000; Copyright (c) Christophe Grand, November 2008. 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. ;; misc agent utilities ;; note to other contrib members: feel free to add to this lib (ns ^{:author "Christophe Grande", :doc "Miscellaneous agent utilities (note to other contrib members: feel free to add to this lib)", } clojure.contrib.agent-utils) (defmacro capture-and-send "Capture the current value of the specified vars and rebind them on the agent thread before executing the action. Example: (capture-and-send [*out*] a f b c)" [vars agent action & args] (let [locals (map #(gensym (name %)) vars)] `(let [~@(interleave locals vars) action# (fn [& args#] (binding [~@(interleave vars locals)] (apply ~action args#)))] (send ~agent action# ~@args)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/apply_macro.clj000066400000000000000000000030161161102570000271060ustar00rootroot00000000000000;;; apply_macro.clj: make macros behave like functions ;; by Stuart Sierra, http://stuartsierra.com/ ;; January 28, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; Don't use this. I mean it. It's evil. How evil? You can't ;; handle it, that's how evil it is. That's right. I did it so you ;; don't have to, ok? Look but don't touch. Use this lib and you'll ;; go blind. ;; DEPRECATED in 1.2 with no replacement. (ns ^{:deprecated "1.2"} clojure.contrib.apply-macro) ;; Copied from clojure.core/spread, which is private. (defn- spread "Flatten final argument list as in apply." [arglist] (cond (nil? arglist) nil (nil? (rest arglist)) (seq (first arglist)) :else (cons (first arglist) (spread (rest arglist))))) (defmacro apply-macro "This is evil. Don't ever use it. It makes a macro behave like a function. Seriously, how messed up is that? Evaluates all args, then uses them as arguments to the macro as with apply. (def things [true true false]) (apply-macro and things) ;; Expands to: (and true true false)" [macro & args] (cons macro (spread (map eval args)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/base64.clj000066400000000000000000000104611161102570000256660ustar00rootroot00000000000000;;; base64.clj: Experimental Base-64 encoding and (later) decoding ;; by Stuart Sierra, http://stuartsierra.com/ ;; August 19, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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 ^{:doc "Base-64 encoding and (maybe later) decoding. This is mainly here as an example. It is much slower than the Apache Commons Codec implementation or sun.misc.BASE64Encoder." :author "Stuart Sierra"} clojure.contrib.base64 (:import (java.io InputStream Writer ByteArrayInputStream StringWriter))) (def *base64-alphabet* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") (defn encode "Encodes bytes of input, writing Base 64 text on output. alphabet is a 65-character String containing the 64 characters to use in the encoding; the 65th character is the pad character. line-length is the maximum number of characters per line, nil for no line breaks." [^InputStream input ^Writer output ^String alphabet line-length] (let [buffer (make-array Byte/TYPE 3)] (loop [line 0] (let [len (.read input buffer)] (when (pos? len) ;; Pre-boxing the bytes as Integers is more efficient for ;; Clojure's bit operations. (let [b0 (Integer/valueOf (int (aget buffer 0))) b1 (Integer/valueOf (int (aget buffer 1))) b2 (Integer/valueOf (int (aget buffer 2)))] (cond (= len 3) (let [s0 (bit-and 0x3F (bit-shift-right b0 2)) s1 (bit-and 0x3F (bit-or (bit-shift-left b0 4) (bit-shift-right b1 4))) s2 (bit-and 0x3F (bit-or (bit-shift-left b1 2) (bit-shift-right b2 6))) s3 (bit-and 0x3F b2)] (.append output (.charAt alphabet s0)) (.append output (.charAt alphabet s1)) (.append output (.charAt alphabet s2)) (.append output (.charAt alphabet s3))) (= len 2) (let [s0 (bit-and 0x3F (bit-shift-right b0 2)) s1 (bit-and 0x3F (bit-or (bit-shift-left b0 4) (bit-shift-right b1 4))) s2 (bit-and 0x3F (bit-shift-left b1 2))] (.append output (.charAt alphabet s0)) (.append output (.charAt alphabet s1)) (.append output (.charAt alphabet s2)) (.append output (.charAt alphabet 64))) (= len 1) (let [s0 (bit-and 0x3F (bit-shift-right b0 2)) s1 (bit-and 0x3F (bit-shift-left b0 4))] (.append output (.charAt alphabet s0)) (.append output (.charAt alphabet s1)) (.append output (.charAt alphabet 64)) (.append output (.charAt alphabet 64))))) (if (and line-length (> (+ line 4) line-length)) (do (.append output \newline) (recur 0)) (recur (+ line 4)))))))) (defn encode-str "Encodes String in base 64; returns a String. If not specified, encoding is UTF-8 and line-length is nil." ([s] (encode-str s "UTF-8" nil)) ([^String s ^String encoding line-length] (let [output (StringWriter.)] (encode (ByteArrayInputStream. (.getBytes s encoding)) output *base64-alphabet* line-length) (.toString output)))) ;;; tests ;; (deftest t-encode-str ;; (is (= (encode-str "") "")) ;; (is (= (encode-str "f") "Zg==")) ;; (is (= (encode-str "fo") "Zm8=")) ;; (is (= (encode-str "foo") "Zm9v")) ;; (is (= (encode-str "foob") "Zm9vYg==")) ;; (is (= (encode-str "fooba") "Zm9vYmE=")) ;; (is (= (encode-str "foobar") "Zm9vYmFy"))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/classpath.clj000066400000000000000000000025211161102570000265620ustar00rootroot00000000000000;;; classpath.clj: utilities for working with the Java class path ;; by Stuart Sierra, http://stuartsierra.com/ ;; April 19, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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 ^{:author "Stuart Sierra", :doc "Utilities for dealing with the JVM's classpath"} clojure.contrib.classpath (:require [clojure.contrib.jar :as jar]) (:import (java.io File) (java.util.jar JarFile))) (defn classpath "Returns a sequence of File objects of the elements on CLASSPATH." [] (map #(File. %) (.split (System/getProperty "java.class.path") (System/getProperty "path.separator")))) (defn classpath-directories "Returns a sequence of File objects for the directories on classpath." [] (filter #(.isDirectory %) (classpath))) (defn classpath-jarfiles "Returns a sequence of JarFile objects for the JAR files on classpath." [] (map #(JarFile. %) (filter jar/jar-file? (classpath)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/combinatorics.clj000066400000000000000000000151221161102570000274350ustar00rootroot00000000000000;;; combinatorics.clj: efficient, functional algorithms for generating lazy ;;; sequences for common combinatorial functions. ;; by Mark Engelberg (mark.engelberg@gmail.com) ;; January 27, 2009 (comment " (combinations items n) - A lazy sequence of all the unique ways of taking n different elements from items. Example: (combinations [1 2 3] 2) -> ((1 2) (1 3) (2 3)) (subsets items) - A lazy sequence of all the subsets of items (but generalized to all sequences, not just sets). Example: (subsets [1 2 3]) -> (() (1) (2) (3) (1 2) (1 3) (2 3) (1 2 3)) (cartesian-product & seqs) - Takes any number of sequences as arguments, and returns a lazy sequence of all the ways to take one item from each seq. Example: (cartesian-product [1 2] [3 4]) -> ((1 3) (1 4) (2 3) (2 4)) (cartesian-product seq1 seq2 seq3 ...) behaves like but is faster than a nested for loop, such as: (for [i1 seq1 i2 seq2 i3 seq3 ...] (list i1 i2 i3 ...)) (selections items n) - A lazy sequence of all the ways to take n (possibly the same) items from the sequence of items. Example: (selections [1 2] 3) -> ((1 1 1) (1 1 2) (1 2 1) (1 2 2) (2 1 1) (2 1 2) (2 2 1) (2 2 2)) (permutations items) - A lazy sequence of all the permutations of items. Example: (permutations [1 2 3]) -> ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)) (lex-permutations items) - A lazy sequence of all distinct permutations in lexicographic order (this function returns the permutations as vectors). Only works on sequences of comparable items. (Note that the result will be quite different from permutations when the sequence contains duplicate items.) Example: (lex-permutations [1 1 2]) -> ([1 1 2] [1 2 1] [2 1 1]) About permutations vs. lex-permutations: lex-permutations is faster than permutations, but only works on sequences of numbers. They operate differently on sequences with duplicate items (lex-permutations will only give you back distinct permutations). lex-permutations always returns the permutations sorted lexicographically whereas permutations will be in an order where the input sequence comes first. In general, I recommend using the regular permutations function unless you have a specific need for lex-permutations. About this code: These combinatorial functions can be written in an elegant way using recursion. However, when dealing with combinations and permutations, you're usually generating large numbers of things, and speed counts. My objective was to write the fastest possible code I could, restricting myself to Clojure's functional, persistent data structures (rather than using Java's arrays) so that this code could be safely leveraged within Clojure's transactional concurrency system. I also restricted myself to algorithms that return results in a standard order. For example, there are faster ways to generate cartesian-product, but I don't know of a faster way to generate the results in the standard nested-for-loop order. Most of these algorithms are derived from algorithms found in Knuth's wonderful Art of Computer Programming books (specifically, the volume 4 fascicles), which present fast, iterative solutions to these common combinatorial problems. Unfortunately, these iterative versions are somewhat inscrutable. If you want to better understand these algorithms, the Knuth books are the place to start. On my own computer, I use versions of all these algorithms that return sequences built with an uncached variation of lazy-seq. Not only does this boost performance, but it's easier to use these rather large sequences more safely (from a memory consumption standpoint). If some form of uncached sequences makes it into Clojure, I will update this accordingly. " ) (ns ^{:author "Mark Engelberg", :doc "Efficient, functional algorithms for generating lazy sequences for common combinatorial functions. (See the source code for a longer description.)"} clojure.contrib.combinatorics) (defn- index-combinations [n cnt] (lazy-seq (let [c (vec (cons nil (for [j (range 1 (inc n))] (+ j cnt (- (inc n)))))), iter-comb (fn iter-comb [c j] (if (> j n) nil (let [c (assoc c j (dec (c j)))] (if (< (c j) j) [c (inc j)] (loop [c c, j j] (if (= j 1) [c j] (recur (assoc c (dec j) (dec (c j))) (dec j)))))))), step (fn step [c j] (cons (rseq (subvec c 1 (inc n))) (lazy-seq (let [next-step (iter-comb c j)] (when next-step (step (next-step 0) (next-step 1)))))))] (step c 1)))) (defn combinations "All the unique ways of taking n different elements from items" [items n] (let [v-items (vec (reverse items))] (if (zero? n) (list ()) (let [cnt (count items)] (cond (> n cnt) nil (= n cnt) (list (seq items)) :else (map #(map v-items %) (index-combinations n cnt))))))) (defn subsets "All the subsets of items" [items] (mapcat (fn [n] (combinations items n)) (range (inc (count items))))) (defn cartesian-product "All the ways to take one item from each sequence" [& seqs] (let [v-original-seqs (vec seqs) step (fn step [v-seqs] (let [increment (fn [v-seqs] (loop [i (dec (count v-seqs)), v-seqs v-seqs] (if (= i -1) nil (if-let [rst (next (v-seqs i))] (assoc v-seqs i rst) (recur (dec i) (assoc v-seqs i (v-original-seqs i)))))))] (when v-seqs (cons (map first v-seqs) (lazy-seq (step (increment v-seqs)))))))] (when (every? first seqs) (lazy-seq (step v-original-seqs))))) (defn selections "All the ways of taking n (possibly the same) elements from the sequence of items" [items n] (apply cartesian-product (take n (repeat items)))) (defn- iter-perm [v] (let [len (count v), j (loop [i (- len 2)] (cond (= i -1) nil (< (v i) (v (inc i))) i :else (recur (dec i))))] (when j (let [vj (v j), l (loop [i (dec len)] (if (< vj (v i)) i (recur (dec i))))] (loop [v (assoc v j (v l) l vj), k (inc j), l (dec len)] (if (< k l) (recur (assoc v k (v l) l (v k)) (inc k) (dec l)) v)))))) (defn- vec-lex-permutations [v] (when v (cons v (lazy-seq (vec-lex-permutations (iter-perm v)))))) (defn lex-permutations "Fast lexicographic permutation generator for a sequence of numbers" [c] (lazy-seq (let [vec-sorted (vec (sort c))] (if (zero? (count vec-sorted)) (list []) (vec-lex-permutations vec-sorted))))) (defn permutations "All the permutations of items, lexicographic by index" [items] (let [v (vec items)] (map #(map v %) (lex-permutations (range (count v)))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/command_line.clj000066400000000000000000000114371161102570000272330ustar00rootroot00000000000000; Copyright (c) Chris Houser, Nov-Dec 2008. 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. ; Process command-line arguments according to a given cmdspec (ns ^{:author "Chris Houser", :doc "Process command-line arguments according to a given cmdspec"} clojure.contrib.command-line (:use (clojure.contrib [string :only (join)]))) (defn make-map [args cmdspec] (let [{spec true [rest-sym] false} (group-by vector? cmdspec) rest-str (str rest-sym) key-data (into {} (for [[syms [_ default]] (map #(split-with symbol? %) (conj spec '[help? h?])) sym syms] [(re-find #"^.*[^?]" (str sym)) {:sym (str (first syms)) :default default}])) defaults (into {} (for [[_ {:keys [default sym]}] key-data :when default] [sym default]))] (loop [[argkey & [argval :as r]] args cmdmap (assoc defaults :cmdspec cmdspec rest-str [])] (if argkey (let [[_ & [keybase]] (re-find #"^--?(.*)" argkey)] (cond (= keybase nil) (recur r (update-in cmdmap [rest-str] conj argkey)) (= keybase "") (update-in cmdmap [rest-str] #(apply conj % r)) :else (if-let [found (key-data keybase)] (if (= \? (last (:sym found))) (recur r (assoc cmdmap (:sym found) true)) (recur (next r) (assoc cmdmap (:sym found) (if (or (nil? r) (= \- (ffirst r))) (:default found) (first r))))) (throw (Exception. (str "Unknown option " argkey)))))) cmdmap)))) (defn- align "Align strings given as vectors of columns, with first vector specifying right or left alignment (:r or :l) for each column." [spec & rows] (let [maxes (vec (for [n (range (count (first rows)))] (apply max (map (comp count #(nth % n)) rows)))) fmt (join " " (for [n (range (count maxes))] (str "%" (when-not (zero? (maxes n)) (str (when (= (spec n) :l) "-") (maxes n))) "s")))] (join "\n" (for [row rows] (apply format fmt row))))) (defn- rmv-q "Remove ?" [^String s] (if (.endsWith s "?") (.substring s 0 (dec (count s))) s)) (defn print-help [desc cmdmap] (println desc) (println "Options") (println (apply align [:l :l :l] (for [spec (:cmdspec cmdmap) :when (vector? spec)] (let [[argnames [text default]] (split-with symbol? spec) [_ opt q] (re-find #"^(.*[^?])(\??)$" (str (first argnames))) argnames (map (comp rmv-q str) argnames) argnames (join ", " (for [arg argnames] (if (= 1 (count arg)) (str "-" arg) (str "--" arg))))] [(str " " argnames (when (= "" q) " ") " ") text (if-not default "" (str " [default " default "]"))]))))) (defmacro with-command-line "Bind locals to command-line args." [args desc cmdspec & body] (let [locals (vec (for [spec cmdspec] (if (vector? spec) (first spec) spec)))] `(let [{:strs ~locals :as cmdmap#} (make-map ~args '~cmdspec)] (if (cmdmap# "help?") (print-help ~desc cmdmap#) (do ~@body))))) (comment ; example of usage: (with-command-line *command-line-args* "tojs -- Compile ClojureScript to JavaScript" [[simple? s? "Runs some simple built-in tests"] [serve "Starts a repl server on the given port" 8081] [mkboot? "Generates a boot.js file"] [verbose? v? "Includes extra fn names and comments in js"] filenames] (binding [*debug-fn-names* verbose? *debug-comments* verbose?] (cond simple? (simple-tests) serve (start-server (Integer/parseInt serve)) mkboot? (mkboot) :else (doseq [filename filenames] (filetojs filename))))) ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/complex_numbers.clj000066400000000000000000000152631161102570000300110ustar00rootroot00000000000000;; Complex numbers ;; by Konrad Hinsen ;; last updated May 4, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Complex numbers NOTE: This library is in evolution. Most math functions are not implemented yet."} clojure.contrib.complex-numbers (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.types :only (deftype)] [clojure.contrib.generic :only (root-type)]) (:require [clojure.contrib.generic.arithmetic :as ga] [clojure.contrib.generic.comparison :as gc] [clojure.contrib.generic.math-functions :as gm])) ; ; Complex numbers are represented as struct maps. The real and imaginary ; parts can be of any type for which arithmetic and maths functions ; are defined. ; (defstruct complex-struct :real :imag) ; ; The general complex number type ; (deftype ::complex complex (fn [real imag] (struct complex-struct real imag)) (fn [c] (vals c))) (derive ::complex root-type) ; ; A specialized subtype for pure imaginary numbers. Introducing this type ; reduces the number of operations by eliminating additions with and ; multiplications by zero. ; (deftype ::pure-imaginary imaginary (fn [imag] (struct complex-struct 0 imag)) (fn [c] (list (:imag c)))) (derive ::pure-imaginary ::complex) ; ; Extraction of real and imaginary parts ; (def real (accessor complex-struct :real)) (def imag (accessor complex-struct :imag)) ; ; Equality and zero test ; (defmethod gc/zero? ::complex [x] (let [[rx ix] (vals x)] (and (zero? rx) (zero? ix)))) (defmethod gc/= [::complex ::complex] [x y] (let [[rx ix] (vals x) [ry iy] (vals y)] (and (gc/= rx ry) (gc/= ix iy)))) (defmethod gc/= [::pure-imaginary ::pure-imaginary] [x y] (gc/= (imag x) (imag y))) (defmethod gc/= [::complex ::pure-imaginary] [x y] (let [[rx ix] (vals x)] (and (gc/zero? rx) (gc/= ix (imag y))))) (defmethod gc/= [::pure-imaginary ::complex] [x y] (let [[ry iy] (vals y)] (and (gc/zero? ry) (gc/= (imag x) iy)))) (defmethod gc/= [::complex root-type] [x y] (let [[rx ix] (vals x)] (and (gc/zero? ix) (gc/= rx y)))) (defmethod gc/= [root-type ::complex] [x y] (let [[ry iy] (vals y)] (and (gc/zero? iy) (gc/= x ry)))) (defmethod gc/= [::pure-imaginary root-type] [x y] (and (gc/zero? (imag x)) (gc/zero? y))) (defmethod gc/= [root-type ::pure-imaginary] [x y] (and (gc/zero? x) (gc/zero? (imag y)))) ; ; Addition ; (defmethod ga/+ [::complex ::complex] [x y] (let [[rx ix] (vals x) [ry iy] (vals y)] (complex (ga/+ rx ry) (ga/+ ix iy)))) (defmethod ga/+ [::pure-imaginary ::pure-imaginary] [x y] (imaginary (ga/+ (imag x) (imag y)))) (defmethod ga/+ [::complex ::pure-imaginary] [x y] (let [[rx ix] (vals x)] (complex rx (ga/+ ix (imag y))))) (defmethod ga/+ [::pure-imaginary ::complex] [x y] (let [[ry iy] (vals y)] (complex ry (ga/+ (imag x) iy)))) (defmethod ga/+ [::complex root-type] [x y] (let [[rx ix] (vals x)] (complex (ga/+ rx y) ix))) (defmethod ga/+ [root-type ::complex] [x y] (let [[ry iy] (vals y)] (complex (ga/+ x ry) iy))) (defmethod ga/+ [::pure-imaginary root-type] [x y] (complex y (imag x))) (defmethod ga/+ [root-type ::pure-imaginary] [x y] (complex x (imag y))) ; ; Negation ; (defmethod ga/- ::complex [x] (let [[rx ix] (vals x)] (complex (ga/- rx) (ga/- ix)))) (defmethod ga/- ::pure-imaginary [x] (imaginary (ga/- (imag x)))) ; ; Subtraction is automatically supplied by ga/-, optimized implementations ; can be added later... ; ; ; Multiplication ; (defmethod ga/* [::complex ::complex] [x y] (let [[rx ix] (vals x) [ry iy] (vals y)] (complex (ga/- (ga/* rx ry) (ga/* ix iy)) (ga/+ (ga/* rx iy) (ga/* ix ry))))) (defmethod ga/* [::pure-imaginary ::pure-imaginary] [x y] (ga/- (ga/* (imag x) (imag y)))) (defmethod ga/* [::complex ::pure-imaginary] [x y] (let [[rx ix] (vals x) iy (imag y)] (complex (ga/- (ga/* ix iy)) (ga/* rx iy)))) (defmethod ga/* [::pure-imaginary ::complex] [x y] (let [ix (imag x) [ry iy] (vals y)] (complex (ga/- (ga/* ix iy)) (ga/* ix ry)))) (defmethod ga/* [::complex root-type] [x y] (let [[rx ix] (vals x)] (complex (ga/* rx y) (ga/* ix y)))) (defmethod ga/* [root-type ::complex] [x y] (let [[ry iy] (vals y)] (complex (ga/* x ry) (ga/* x iy)))) (defmethod ga/* [::pure-imaginary root-type] [x y] (imaginary (ga/* (imag x) y))) (defmethod ga/* [root-type ::pure-imaginary] [x y] (imaginary (ga/* x (imag y)))) ; ; Inversion ; (ga/defmethod* ga / ::complex [x] (let [[rx ix] (vals x) den ((ga/qsym ga /) (ga/+ (ga/* rx rx) (ga/* ix ix)))] (complex (ga/* rx den) (ga/- (ga/* ix den))))) (ga/defmethod* ga / ::pure-imaginary [x] (imaginary (ga/- ((ga/qsym ga /) (imag x))))) ; ; Division is automatically supplied by ga//, optimized implementations ; can be added later... ; ; ; Conjugation ; (defmethod gm/conjugate ::complex [x] (let [[r i] (vals x)] (complex r (ga/- i)))) (defmethod gm/conjugate ::pure-imaginary [x] (imaginary (ga/- (imag x)))) ; ; Absolute value ; (defmethod gm/abs ::complex [x] (let [[r i] (vals x)] (gm/sqrt (ga/+ (ga/* r r) (ga/* i i))))) (defmethod gm/abs ::pure-imaginary [x] (gm/abs (imag x))) ; ; Square root ; (let [one-half (/ 1 2) one-eighth (/ 1 8)] (defmethod gm/sqrt ::complex [x] (let [[r i] (vals x)] (if (and (gc/zero? r) (gc/zero? i)) 0 (let [; The basic formula would say ; abs (gm/sqrt (ga/+ (ga/* r r) (ga/* i i))) ; p (gm/sqrt (ga/* one-half (ga/+ abs r))) ; but the slightly more complicated one below ; avoids overflow for large r or i. ar (gm/abs r) ai (gm/abs i) r8 (ga/* one-eighth ar) i8 (ga/* one-eighth ai) abs (gm/sqrt (ga/+ (ga/* r8 r8) (ga/* i8 i8))) p (ga/* 2 (gm/sqrt (ga/+ abs r8))) q ((ga/qsym ga /) ai (ga/* 2 p)) s (gm/sgn i)] (if (gc/< r 0) (complex q (ga/* s p)) (complex p (ga/* s q)))))))) ; ; Exponential function ; (defmethod gm/exp ::complex [x] (let [[r i] (vals x) exp-r (gm/exp r) cos-i (gm/cos i) sin-i (gm/sin i)] (complex (ga/* exp-r cos-i) (ga/* exp-r sin-i)))) (defmethod gm/exp ::pure-imaginary [x] (let [i (imag x)] (complex (gm/cos i) (gm/sin i)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/cond.clj000066400000000000000000000026221161102570000255250ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; File: cond.clj ;; ;; scgilardi (gmail) ;; 2 October 2008 (ns ^{:author "Stephen C. Gilardi" :doc "Extensions to the basic cond function."} 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." [bindings & clauses] (let [binding (first bindings)] (when-let [[test expr & more] clauses] (if (= test :else) expr `(if-let [~binding ~test] ~expr (cond-let ~bindings ~@more)))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/condition.clj000066400000000000000000000114321161102570000265670ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; condition.clj ;; ;; scgilardi (gmail) ;; Created 09 June 2009 (ns ^{:author "Stephen C. Gilardi" :doc "Flexible raising and handling of conditions: Functions: raise: raises a condition handler-case: dispatches raised conditions to appropriate handlers print-stack-trace: prints abbreviated or full condition stack traces Data: A condition is a map containing values for these keys: - :type, a condition type specifier, typically a keyword - :stack-trace, a stack trace to the site of the raise - :message, a human-readable message (optional) - :cause, a wrapped exception or condition (optional) - other keys given as arguments to raise (optional) Note: requires AOT compilation. Based on an idea from Chouser: http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"} clojure.contrib.condition (:require clojure.contrib.condition.Condition) (:import clojure.contrib.condition.Condition clojure.lang.IPersistentMap) (:use (clojure.contrib [def :only (defvar)] [seq :only (separate)]))) (defvar *condition* "While a handler is running, bound to the condition being handled") (defvar *selector* "While a handler is running, bound to the selector returned by the handler-case dispatch-fn for *condition*") (defvar *condition-object* "While a handler is running, bound to the Condition object whose metadata is the condition") (defvar *full-stack-traces* false "Bind to true to include clojure.{core,lang,main} frames in stack traces") (defmacro raise "Raises a condition. With no arguments, re-raises the current condition. With one argument (a map), raises the argument. With two or more arguments, raises a map with keys and values from the arguments." ([] `(throw *condition-object*)) ([m] `(throw (Condition. ~m))) ([key val & keyvals] `(raise (hash-map ~key ~val ~@keyvals)))) (defmacro handler-case "Executes body in a context where raised conditions can be handled. dispatch-fn accepts a raised condition (a map) and returns a selector used to choose a handler. Commonly, dispatch-fn will be :type to dispatch on the condition's :type value. Handlers are forms within body: (handle key ...) If a condition is raised, executes the body of the first handler whose key satisfies (isa? selector key). If no handlers match, re-raises the condition. While a handler is running, *condition* is bound to the condition being handled and *selector* is bound to to the value returned by dispatch-fn that matched the handler's key." [dispatch-fn & body] (let [[handlers code] (separate #(and (list? %) (= 'handle (first %))) body)] `(try ~@code (catch Condition c# (binding [*condition-object* c# *condition* (meta c#) *selector* (~dispatch-fn (meta c#))] (cond ~@(mapcat (fn [[_ key & body]] `[(isa? *selector* ~key) (do ~@body)]) handlers) :else (raise))))))) (defmulti stack-trace-info "Returns header, stack-trace, and cause info from conditions and Throwables" class) (defmethod stack-trace-info IPersistentMap [condition] [(format "condition: %s, %s" (:type condition) (dissoc condition :type :stack-trace :cause)) (:stack-trace condition) (:cause condition)]) (defmethod stack-trace-info Condition [condition] (stack-trace-info (meta condition))) (defmethod stack-trace-info Throwable [throwable] [(str throwable) (.getStackTrace throwable) (.getCause throwable)]) (defn print-stack-trace "Prints a stack trace for a condition or Throwable. Skips frames for classes in clojure.{core,lang,main} unless the *full-stack-traces* is bound to logical true" [x] (let [[header frames cause] (stack-trace-info x)] (printf "%s\n" header) (doseq [frame frames] (let [classname (.getClassName frame)] (if (or *full-stack-traces* (not (re-matches #"clojure.(?:core|lang|main).*" classname))) (printf " at %s/%s(%s:%s)\n" classname (.getMethodName frame) (.getFileName frame) (.getLineNumber frame))))) (when cause (printf "caused by: ") (recur cause)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/condition/000077500000000000000000000000001161102570000260745ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/condition/Condition.clj000066400000000000000000000031201161102570000305100ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; Condition.clj ;; ;; Used by clojure.contrib.condition to implement a "Throwable map" ;; ;; scgilardi (gmail) ;; Created 09 June 2009 (ns clojure.contrib.condition.Condition (:gen-class :extends Throwable :implements [clojure.lang.IMeta] :state state :init init :post-init post-init :constructors {[clojure.lang.IPersistentMap] [String Throwable]})) (defn -init "Constructs a Condition object with condition (a map) as its metadata. Also initializes the superclass with the values at :message and :cause, if any, so they are also available via .getMessage and .getCause." [condition] [[(:message condition) (:cause condition)] (atom condition)]) (defn -post-init "Adds :stack-trace to the condition. Drops the bottom 3 frames because they are always the same: implementation details of Condition and raise." [this condition] (swap! (.state this) assoc :stack-trace (into-array (drop 3 (.getStackTrace this))))) (defn -meta "Returns this object's metadata, the condition" [this] @(.state this)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/core.clj000066400000000000000000000061651161102570000255400ustar00rootroot00000000000000; Copyright (c) Laurent Petit and others, March 2009. 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. ;; functions/macros variants of the ones that can be found in clojure.core ;; note to other contrib members: feel free to add to this lib (ns ^{:author "Laurent Petit (and others)" :doc "Functions/macros variants of the ones that can be found in clojure.core (note to other contrib members: feel free to add to this lib)"} clojure.contrib.core (:use clojure.contrib.def)) (defmacro- defnilsafe [docstring non-safe-name nil-safe-name] `(defmacro ~nil-safe-name ~docstring {:arglists '([~'x ~'form] [~'x ~'form ~'& ~'forms])} ([x# form#] `(let [~'i# ~x#] (when-not (nil? ~'i#) (~'~non-safe-name ~'i# ~form#)))) ([x# form# & more#] `(~'~nil-safe-name (~'~nil-safe-name ~x# ~form#) ~@more#)))) (defnilsafe "Same as clojure.core/-> but returns nil as soon as the threaded value is nil itself (thus short-circuiting any pending computation). Examples : (-?> \"foo\" .toUpperCase (.substring 1)) returns \"OO\" (-?> nil .toUpperCase (.substring 1)) returns nil " -> -?>) (defnilsafe "Same as clojure.core/.. but returns nil as soon as the threaded value is nil itself (thus short-circuiting any pending computation). Examples : (.?. \"foo\" .toUpperCase (.substring 1)) returns \"OO\" (.?. nil .toUpperCase (.substring 1)) returns nil " .. .?.) (defnilsafe "Same as clojure.core/->> but returns nil as soon as the threaded value is nil itself (thus short-circuiting any pending computation). Examples : (-?>> (range 5) (map inc)) returns (1 2 3 4 5) (-?>> [] seq (map inc)) returns nil " ->> -?>>) ;; ---------------------------------------------------------------------- ;; scgilardi at gmail (defn dissoc-in "Dissociates an entry from a nested associative structure returning a new nested structure. keys is a sequence of keys. Any empty maps that result will not be present in the new structure." [m [k & ks :as keys]] (if ks (if-let [nextmap (get m k)] (let [newmap (dissoc-in nextmap ks)] (if (seq newmap) (assoc m k newmap) (dissoc m k))) m) (dissoc m k))) (defn new-by-name "Constructs a Java object whose class is specified by a String." [class-name & args] (clojure.lang.Reflector/invokeConstructor (clojure.lang.RT/classForName class-name) (into-array Object args))) (defn seqable? "Returns true if (seq x) will succeed, false otherwise." [x] (or (seq? x) (instance? clojure.lang.Seqable x) (nil? x) (instance? Iterable x) (-> x .getClass .isArray) (string? x) (instance? java.util.Map x))) ;; ---------------------------------------------------------------------- clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/dataflow.clj000066400000000000000000000341751161102570000264130ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; dataflow.clj ;; ;; A Library to Support a Dataflow Model of State ;; ;; straszheimjeffrey (gmail) ;; Created 10 March 2009 (ns ^{:author "Jeffrey Straszheim", :doc "A library to support a dataflow model of state"} clojure.contrib.dataflow (:use [clojure.set :only (union intersection difference)]) (:use [clojure.contrib.graph :only (directed-graph reverse-graph dependency-list get-neighbors)]) (:use [clojure.walk :only (postwalk)]) (:use [clojure.contrib.except :only (throwf)]) (:import java.io.Writer)) ;;; Chief Data Structures ;; Source Cell ; The data of a source cell is directly set by a calling function. It ; never depends on other cells. (defstruct source-cell :name ; The name, a symbol :value ; Its value, a Ref :cell-type) ; Should be ::source-cell ;; Cell ; A standard cell that computes its value from other cells. (defstruct standard-cell :name ; The name, a symbol :value ; Its value, a Ref :dependents ; The names of cells on which this depends, a collection :fun ; A closure that computes the value, given an environment :display ; The original expression for display :cell-type) ; Should be ::cell (derive ::cell ::dependent-cell) ; A cell that has a dependents field ;; Validator ; A cell that has no value, but can throw an exception when run (defstruct validator-cell :name ; Always ::validator :dependents ; The names of cells on which this depends, a collection :fun ; A clojure that can throw an exception :display ; The original exprssion for display :cell-type) ; Should be ::validator-cell (derive ::validator-cell ::dependent-cell) ;; A sentinal value (def *empty-value* (java.lang.Object.)) ;; Dataflow ; A collection of cells and dependency information (defstruct dataflow :cells ; A set of all cells :cells-map ; A map of cell names (symbols) to collections of cells :fore-graph ; The inverse of the dependency graph, nodes are cells :topological) ; A vector of sets of independent nodes -- orders the computation ;;; Environment Access (defn get-cells "Get all the cells named by name" [df name] ((:cells-map @df) name)) (defn get-cell "Get the single cell named by name" [df name] (let [cells (get-cells df name)] (cond (= (count cells) 1) (first cells) (> (count cells) 1) (throwf Exception "Cell %s has multiple instances" name) :otherwise (throwf Exception "Cell %s is undefined" name)))) (defn source-cell? "Is this cell a source cell?" [cell] (isa? (:cell-type cell) ::source-cell)) (defn get-source-cells "Returns a collection of source cells from the dataflow" [df] (for [cell (:cells @df) :when (source-cell? cell)] cell)) (defn get-value "Gets a value from the df matching the passed symbol. Signals an error if the name is not present, or if it not a single value." [df name] (let [cell (get-cell df name) result @(:value cell)] (do (when (= *empty-value* result) (throwf Exception "Cell named %s empty" name)) result))) (defn get-values "Gets a collection of values from the df by name" [df name] (let [cells (get-cells df name) results (map #(-> % :value deref) cells)] (do (when (some #(= % *empty-value*) results) (throwf Exception "At least one empty cell named %s found" name)) results))) (defn get-old-value "Looks up an old value" [df env name] (if (contains? env name) (env name) (get-value df name))) (defn get-value-from-cell "Given a cell, get its value" [cell] (-> cell :value deref)) ;;; Build Dataflow Structure (defn- build-cells-map "Given a collection of cells, build a name->cells-collection map from it." [cs] (let [step (fn [m c] (let [n (:name c) o (get m n #{}) s (conj o c)] (assoc m n s)))] (reduce step {} cs))) (defn- build-back-graph "Builds the backward dependency graph from the cells map. Each node of the graph is a cell." [cells cells-map] (let [step (fn [n] (apply union (for [dep-name (:dependents n)] (cells-map dep-name)))) neighbors (zipmap cells (map step cells))] (struct-map directed-graph :nodes cells :neighbors neighbors))) (defn- build-dataflow* "Builds the dataflow structure" [cs] (let [cells (set cs) cells-map (build-cells-map cs) back-graph (build-back-graph cells cells-map) fore-graph (reverse-graph back-graph)] (struct-map dataflow :cells cells :cells-map cells-map :fore-graph fore-graph :topological (dependency-list back-graph)))) (def initialize) (defn build-dataflow "Given a collection of cells, build and return a dataflow object" [cs] (dosync (let [df (ref (build-dataflow* cs))] (initialize df) df))) ;;; Displaying a dataflow (defn print-dataflow "Prints a dataflow, one cell per line" [df] (println) (let [f (fn [cell] (-> cell :name str))] (doseq [cell (sort-by f (:cells @df))] (prn cell)))) ;;; Modifying a Dataflow (defn add-cells "Given a collection of cells, add them to the dataflow." [df cells] (dosync (let [new-cells (union (set cells) (:cells @df))] (ref-set df (build-dataflow* new-cells)) (initialize df)))) (defn remove-cells "Given a collection of cells, remove them from the dataflow." [df cells] (dosync (let [new-cells (difference (:cells @df) (set cells))] (ref-set df (build-dataflow* new-cells)) (initialize df)))) ;;; Cell building (def *meta* {:type ::dataflow-cell}) (defn build-source-cell "Builds a source cell" [name init] (with-meta (struct source-cell name (ref init) ::source-cell) *meta*)) (defn- is-col-var? [symb] (let [name (name symb)] (and (= \? (first name)) (= \* (second name))))) (defn- is-old-var? [symb] (let [name (name symb)] (and (= \? (first name)) (= \- (second name))))) (defn- is-var? [symb] (let [name (name symb)] (and (= \? (first name)) (-> symb is-col-var? not) (-> symb is-old-var? not)))) (defn- cell-name [symb] `(quote ~(cond (is-var? symb) (-> symb name (.substring 1) symbol) (or (is-col-var? symb) (is-old-var? symb)) (-> symb name (.substring 2) symbol)))) (defn- replace-symbol "Walk the from replacing the ?X forms with the needed calls" [dfs ov form] (cond (-> form symbol? not) form (is-var? form) `(get-value ~dfs ~(cell-name form)) (is-col-var? form) `(get-values ~dfs ~(cell-name form)) (is-old-var? form) `(get-old-value ~dfs ~ov ~(cell-name form)) :otherwise form)) (defn- build-fun "Build the closure needed to compute a cell" [form] (let [dfs (gensym "df_") ov (gensym "old_")] `(fn [~dfs ~ov] ~(postwalk (partial replace-symbol dfs ov) form)))) (defn- get-deps "Get the names of the dependent cells" [form] (let [step (fn [f] (cond (coll? f) (apply union f) (-> f symbol? not) nil (is-var? f) #{(cell-name f)} (is-col-var? f) #{(cell-name f)} (is-old-var? f) #{(cell-name f)} :otherwise nil))] (postwalk step form))) (defn build-standard-cell "Builds a standard cell" [name deps fun expr] (with-meta (struct standard-cell name (ref *empty-value*) deps fun expr ::cell) *meta*)) (defn build-validator-cell "Builds a validator cell" [deps fun expr] (with-meta (struct validator-cell ::validator deps fun expr ::validator-cell) *meta*)) (defmacro cell "Build a standard cell, like this: (cell fred (* ?mary ?joe)) Which creates a cell named fred that is the product of a cell mary and cell joe Or: (cell joe (apply * ?*sally)) Which creates a cell that applies * to the collection of all cells named sally Or: (cell :source fred 0) Which builds a source cell fred with initial value 0 Or: (cell :validator (when (< ?fred ?sally) (throwf \"%s must be greater than %s\" ?fred ?sally)) Which will perform the validation" [type & data] (cond (symbol? type) (let [name type ; No type for standard cell expr (first data) ; we ignore extra data! deps (get-deps expr) fun (build-fun expr)] `(build-standard-cell '~name ~deps ~fun '~expr)) (= type :source) (let [[name init] data] `(build-source-cell '~name ~init)) (= type :validator) (let [[expr] data deps (get-deps expr) fun (build-fun expr)] `(build-validator-cell ~deps ~fun '~expr)))) ;;; Cell Display (defmulti display-cell "A 'readable' form of the cell" :cell-type) (defmethod display-cell ::source-cell [cell] (list 'cell :source (:name cell) (-> cell :value deref))) (defmethod display-cell ::cell [cell] (list 'cell (:name cell) (:display cell) (-> cell :value deref))) (defmethod display-cell ::validator-cell [cell] (list 'cell :validator (:display cell))) (defmethod print-method ::dataflow-cell [f ^Writer w] (binding [*out* w] (pr (display-cell f)))) ;;; Evaluation (defmulti eval-cell "Evaluate a dataflow cell. Return [changed, old val]" (fn [df data old cell] (:cell-type cell))) (defmethod eval-cell ::source-cell [df data old cell] (let [name (:name cell) val (:value cell) ov @val] (if (contains? data name) (let [new-val (data name)] (if (not= ov new-val) (do (ref-set val new-val) [true ov]) [false ov])) [false ov]))) (defmethod eval-cell ::cell [df data old cell] (let [val (:value cell) old-val @val new-val ((:fun cell) df old)] (if (not= old-val new-val) (do (ref-set val new-val) [true old-val]) [false old-val]))) (defmethod eval-cell ::validator-cell [df data old cell] (do ((:fun cell) df old) [false nil])) (defn- perform-flow "Evaluate the needed cells (a set) from the given dataflow. Data is a name-value mapping of new values for the source cells" [df data needed] (loop [needed needed tops (:topological @df) old {}] (let [now (first tops) ; Now is a set of nodes new-tops (next tops)] (when (and (-> needed empty? not) (-> now empty? not)) (let [step (fn [[needed old] cell] (let [[changed ov] (try (eval-cell df data old cell) (catch Exception e (throw (Exception. (str cell) e)))) nn (disj needed cell)] (if changed [(union nn (get-neighbors (:fore-graph @df) cell)) (assoc old (:name cell) ov)] [nn old]))) [new-needed new-old] (reduce step [needed old] (intersection now needed))] (recur new-needed new-tops new-old)))))) (defn- validate-update "Ensure that all the updated cells are source cells" [df names] (let [scns (set (map :name (get-source-cells df)))] (doseq [name names] (when (-> name scns not) (throwf Exception "Cell %n is not a source cell" name))))) (defn update-values "Given a dataflow, and a map of name-value pairs, update the dataflow by binding the new values. Each name must be of a source cell" [df data] (dosync (validate-update df (keys data)) (let [needed (apply union (for [name (keys data)] (set ((:cells-map @df) name))))] (perform-flow df data needed)))) (defn- initialize "Apply all the current source cell values. Useful for a new dataflow, or one that has been updated with new cells" [df] (let [needed (:cells @df) fg (:fore-graph @df)] (perform-flow df {} needed))) ;;; Watchers (defn add-cell-watcher "Adds a watcher to a cell to respond to changes of value. The is a function of 4 values: a key, the cell, its old value, its new value. This is implemented using Clojure's add-watch to the underlying ref, and shared its sematics" [cell key fun] (let [val (:value cell)] (add-watch val key (fn [key _ old-v new-v] (fun key cell old-v new-v))))) (comment (def df (build-dataflow [(cell :source fred 1) (cell :source mary 0) (cell greg (+ ?fred ?mary)) (cell joan (+ ?fred ?mary)) (cell joan (* ?fred ?mary)) (cell sally (apply + ?*joan)) (cell :validator (when (number? ?-greg) (when (<= ?greg ?-greg) (throwf Exception "Non monotonic"))))])) (do (println) (print-dataflow df)) (add-cell-watcher (get-cell df 'sally) nil (fn [key cell o n] (printf "sally changed from %s to %s\n" o n))) (update-values df {'fred 1 'mary 1}) (update-values df {'fred 5 'mary 1}) (update-values df {'fred 0 'mary 0}) (get-value df 'fred) (get-values df 'joan) (get-value df 'sally) (get-value df 'greg) (use :reload 'clojure.contrib.dataflow) (use 'clojure.stacktrace) (e) (use 'clojure.contrib.trace) ) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog.clj000066400000000000000000000041311161102570000262120ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; datalog.clj ;; ;; A Clojure implementation of Datalog ;; ;; straszheimjeffrey (gmail) ;; Created 2 March 2009 ;;; Please see the example.clj file in the datalog folder (ns ^{:author "Jeffrey Straszheim", :doc "A Clojure implementation of Datalog"} clojure.contrib.datalog (:use clojure.contrib.datalog.rules clojure.contrib.datalog.softstrat clojure.contrib.datalog.database) (:use [clojure.set :only (intersection)] [clojure.contrib.except :only (throwf)])) (defstruct work-plan :work-plan ; The underlying structure :rules ; The original rules :query ; The original query :work-plan-type) ; The type of plan (defn- validate-work-plan "Ensure any top level semantics are not violated" [work-plan database] (let [common-relations (-> work-plan :rules (intersection (-> database keys set)))] (when (-> common-relations empty? not) (throwf "The rules and database define the same relation(s): %s" common-relations)))) ; More will follow (defn build-work-plan "Given a list of rules and a query, build a work plan that can be used to execute the query." [rules query] (struct-map work-plan :work-plan (build-soft-strat-work-plan rules query) :rules rules :query query :work-plan-type ::soft-stratified)) (defn run-work-plan "Given a work plan, a database, and some query bindings, run the work plan and return the results." [work-plan database query-bindings] (validate-work-plan work-plan database) (evaluate-soft-work-set (:work-plan work-plan) database query-bindings)) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/000077500000000000000000000000001161102570000255215ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/database.clj000066400000000000000000000205411161102570000277610ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; database.clj ;; ;; A Clojure implementation of Datalog -- Support for in-memory database ;; ;; straszheimjeffrey (gmail) ;; Created 21 Feburary 2009 (ns clojure.contrib.datalog.database (:use clojure.contrib.datalog.util) (:use clojure.contrib.def) (:use [clojure.set :only (union intersection difference)]) (:use [clojure.contrib.except :only (throwf)]) (:import java.io.Writer)) (defstruct relation :schema ; A set of key names :data ; A set of tuples :indexes) ; A map key names to indexes (in turn a map of value to tuples) ;;; DDL (defmethod print-method ::datalog-database [db ^Writer writer] (binding [*out* writer] (do (println "(datalog-database") (println "{") (doseq [key (keys db)] (println) (println key) (print-method (db key) writer)) (println "})")))) (defn datalog-database [rels] (with-meta rels {:type ::datalog-database})) (def empty-database (datalog-database {})) (defmethod print-method ::datalog-relation [rel ^Writer writer] (binding [*out* writer] (do (println "(datalog-relation") (println " ;; Schema") (println " " (:schema rel)) (println) (println " ;; Data") (println " #{") (doseq [tuple (:data rel)] (println " " tuple)) (println " }") (println) (println " ;; Indexes") (println " {") (doseq [key (-> rel :indexes keys)] (println " " key) (println " {") (doseq [val (keys ((:indexes rel) key))] (println " " val) (println " " (get-in rel [:indexes key val]))) (println " }")) (println " })")))) (defn datalog-relation "Creates a relation" [schema data indexes] (with-meta (struct relation schema data indexes) {:type ::datalog-relation})) (defn add-relation "Adds a relation to the database" [db name keys] (assoc db name (datalog-relation (set keys) #{} {}))) (defn add-index "Adds an index to an empty relation named name" [db name key] (assert (empty? (:data (db name)))) (let [rel (db name) inx (assoc (:indexes rel) key {})] (assoc db name (datalog-relation (:schema rel) (:data rel) inx)))) (defn ensure-relation "If the database lacks the named relation, add it" [db name keys indexes] (if-let [rel (db name)] (do (assert (= (:schema rel) (set keys))) db) (let [db1 (add-relation db name keys)] (reduce (fn [db key] (add-index db name key)) db1 indexes)))) (defmacro make-database "Makes a database, like this (make-database (relation :fred [:mary :sue]) (index :fred :mary) (relation :sally [:jen :becky]) (index :sally :jen) (index :sally :becky))" [& commands] (let [wrapper (fn [cur new] (let [cmd (first new) body (next new)] (assert (= 2 (count body))) (cond (= cmd 'relation) `(add-relation ~cur ~(first body) ~(fnext body)) (= cmd 'index) `(add-index ~cur ~(first body) ~(fnext body)) :otherwise (throwf "%s not recognized" new))))] (reduce wrapper `empty-database commands))) (defn get-relation "Get a relation object by name" [db rel-name] (db rel-name)) (defn replace-relation "Add or replace a fully constructed relation object to the database." [db rel-name rel] (assoc db rel-name rel)) ;;; DML (defn database-counts "Returns a map with the count of elements in each relation." [db] (map-values #(-> % :data count) db)) (defn- modify-indexes "Perform f on the indexed tuple-set. f should take a set and tuple, and return the new set." [idxs tuple f] (into {} (for [ik (keys idxs)] (let [im (idxs ik) iv (tuple ik) os (get im iv #{}) ns (f os tuple)] [ik (if (empty? ns) (dissoc im iv) (assoc im iv (f os tuple)))])))) (defn- add-to-indexes "Adds the tuple to the appropriate keys in the index map" [idxs tuple] (modify-indexes idxs tuple conj)) (defn- remove-from-indexes "Removes the tuple from the appropriate keys in the index map" [idxs tuple] (modify-indexes idxs tuple disj)) (defn add-tuple "Two forms: [db relation-name tuple] adds tuple to the named relation. Returns the new database. [rel tuple] adds to the relation object. Returns the new relation." ([db rel-name tuple] (assert (= (-> tuple keys set) (-> rel-name db :schema))) (assoc db rel-name (add-tuple (db rel-name) tuple))) ([rel tuple] (let [data (:data rel) new-data (conj data tuple)] (if (identical? data new-data) ; optimization hack! rel (let [idxs (add-to-indexes (:indexes rel) tuple)] (assoc rel :data new-data :indexes idxs)))))) (defn remove-tuple "Two forms: [db relation-name tuple] removes the tuple from the named relation, returns a new database. [rel tuple] removes the tuple from the relation. Returns the new relation." ([db rel-name tuple] (assoc db rel-name (remove-tuple (db rel-name) tuple))) ([rel tuple] (let [data (:data rel) new-data (disj data tuple)] (if (identical? data new-data) rel (let [idxs (remove-from-indexes (:indexes rel) tuple)] (assoc rel :data new-data :indexes idxs)))))) (defn add-tuples "Adds a collection of tuples to the db, as (add-tuples db [:rel-name :key-1 1 :key-2 2] [:rel-name :key-1 2 :key-2 3])" [db & tupls] (reduce #(add-tuple %1 (first %2) (apply hash-map (next %2))) db tupls)) (defn- find-indexes "Given a map of indexes and a partial tuple, return the sets of full tuples" [idxs pt] (if (empty? idxs) nil (filter identity (for [key (keys pt)] (if-let [idx-map (idxs key)] (get idx-map (pt key) #{}) nil))))) (defn- match? "Is m2 contained in m1?" [m1 m2] (let [compare (fn [key] (and (contains? m1 key) (= (m1 key) (m2 key))))] (every? compare (keys m2)))) (defn- scan-space "Computes a stream of tuples from relation rn matching partial tuple (pt) and applies fun to each" [fun db rn pt] (let [rel (db rn) idxs (find-indexes (:indexes rel) pt) space (if (empty? idxs) (:data rel) ; table scan :( (reduce intersection idxs))] (trace-datalog (when (empty? idxs) (println (format "Table scan of %s: %s rows!!!!!" rn (count space))))) (fun #(match? % pt) space))) (defn select "finds all matching tuples to the partial tuple (pt) in the relation named (rn)" [db rn pt] (scan-space filter db rn pt)) (defn any-match? "Finds if there are any matching records for the partial tuple" [db rn pt] (if (= (-> pt keys set) (:schema (db rn))) (contains? (:data (db rn)) pt) (scan-space some db rn pt))) ;;; Merge (defn merge-indexes [idx1 idx2] (merge-with (fn [h1 h2] (merge-with union h1 h2)) idx1 idx2)) (defn merge-relations "Merges two relations" [r1 r2] (assert (= (:schema r1) (:schema r2))) (let [merged-indexes (merge-indexes (:indexes r1) (:indexes r2)) merged-data (union (:data r1) (:data r2))] (assoc r1 :data merged-data :indexes merged-indexes))) (defn database-merge "Merges databases together" [dbs] (apply merge-with merge-relations dbs)) (defn database-merge-parallel "Merges databases together in parallel" [dbs] (preduce merge-relations dbs)) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/literals.clj000066400000000000000000000245251161102570000300420ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; literals.clj ;; ;; A Clojure implementation of Datalog -- Literals ;; ;; straszheimjeffrey (gmail) ;; Created 25 Feburary 2009 (ns clojure.contrib.datalog.literals (:use clojure.contrib.datalog.util) (:use clojure.contrib.datalog.database) (:use [clojure.set :only (intersection)]) (:use [clojure.contrib.set :only (subset?)])) ;;; Type Definitions (defstruct atomic-literal :predicate ; The predicate name :term-bindings ; A map of column names to bindings :literal-type) ; ::literal or ::negated (derive ::negated ::literal) (defstruct conditional-literal :fun ; The fun to call :symbol ; The fun symbol (for display) :terms ; The formal arguments :literal-type) ; ::conditional ;;; Basics (defmulti literal-predicate "Return the predicate/relation this conditional operates over" :literal-type) (defmulti literal-columns "Return the column names this applies to" :literal-type) (defmulti literal-vars "Returns the logic vars used by this literal" :literal-type) (defmulti positive-vars "Returns the logic vars used in a positive position" :literal-type) (defmulti negative-vars "Returns the logic vars used in a negative position" :literal-type) (defmethod literal-predicate ::literal [l] (:predicate l)) (defmethod literal-predicate ::conditional [l] nil) (defmethod literal-columns ::literal [l] (-> l :term-bindings keys set)) (defmethod literal-columns ::conditional [l] nil) (defmethod literal-vars ::literal [l] (set (filter is-var? (-> l :term-bindings vals)))) (defmethod literal-vars ::conditional [l] (set (filter is-var? (:terms l)))) (defmethod positive-vars ::literal [l] (literal-vars l)) (defmethod positive-vars ::negated [l] nil) (defmethod positive-vars ::conditional [l] nil) (defmethod negative-vars ::literal [l] nil) (defmethod negative-vars ::negated [l] (literal-vars l)) (defmethod negative-vars ::conditional [l] (literal-vars l)) (defn negated? "Is this literal a negated literal?" [l] (= (:literal-type l) ::negated)) (defn positive? "Is this a positive literal?" [l] (= (:literal-type l) ::literal)) ;;; Building Literals (def negation-symbol 'not!) (def conditional-symbol 'if) (defmulti build-literal "(Returns an unevaluated expression (to be used in macros) of a literal." first) (defn build-atom "Returns an unevaluated expression (to be used in a macro) of an atom." [f type] (let [p (first f) ts (map #(if (is-var? %) `(quote ~%) %) (next f)) b (if (seq ts) (apply assoc {} ts) nil)] `(struct atomic-literal ~p ~b ~type))) (defmethod build-literal :default [f] (build-atom f ::literal)) (defmethod build-literal negation-symbol [f] (build-atom (rest f) ::negated)) (defmethod build-literal conditional-symbol [f] (let [symbol (fnext f) terms (nnext f) fun `(fn [binds#] (apply ~symbol binds#))] `(struct conditional-literal ~fun '~symbol '~terms ::conditional))) ;;; Display (defmulti display-literal "Converts a struct representing a literal to a normal list" :literal-type) (defn- display [l] (conj (-> l :term-bindings list* flatten) (literal-predicate l))) (defmethod display-literal ::literal [l] (display l)) (defmethod display-literal ::negated [l] (conj (display l) negation-symbol)) (defmethod display-literal ::conditional [l] (list* conditional-symbol (:symbol l) (:terms l))) ;;; Sip computation (defmulti get-vs-from-cs "From a set of columns, return the vars" :literal-type) (defmethod get-vs-from-cs ::literal [l bound] (set (filter is-var? (vals (select-keys (:term-bindings l) bound))))) (defmethod get-vs-from-cs ::conditional [l bound] nil) (defmulti get-cs-from-vs "From a set of vars, get the columns" :literal-type) (defmethod get-cs-from-vs ::literal [l bound] (reduce conj #{} (remove nil? (map (fn [[k v]] (if (bound v) k nil)) (:term-bindings l))))) (defmethod get-cs-from-vs ::conditional [l bound] nil) (defmulti get-self-bound-cs "Get the columns that are bound withing the literal." :literal-type) (defmethod get-self-bound-cs ::literal [l] (reduce conj #{} (remove nil? (map (fn [[k v]] (if (not (is-var? v)) k nil)) (:term-bindings l))))) (defmethod get-self-bound-cs ::conditional [l] nil) (defmulti literal-appropriate? "When passed a set of bound vars, determines if this literal can be used during this point of a SIP computation." (fn [b l] (:literal-type l))) (defmethod literal-appropriate? ::literal [bound l] (not (empty? (intersection (literal-vars l) bound)))) (defmethod literal-appropriate? ::negated [bound l] (subset? (literal-vars l) bound)) (defmethod literal-appropriate? ::conditional [bound l] (subset? (literal-vars l) bound)) (defmulti adorned-literal "When passed a set of bound columns, returns the adorned literal" (fn [l b] (:literal-type l))) (defmethod adorned-literal ::literal [l bound] (let [pred (literal-predicate l) bnds (intersection (literal-columns l) bound)] (if (empty? bound) l (assoc l :predicate {:pred pred :bound bnds})))) (defmethod adorned-literal ::conditional [l bound] l) (defn get-adorned-bindings "Get the bindings from this adorned literal." [pred] (:bound pred)) (defn get-base-predicate "Get the base predicate from this predicate." [pred] (if (map? pred) (:pred pred) pred)) ;;; Magic Stuff (defn magic-literal "Create a magic version of this adorned predicate." [l] (assert (-> l :literal-type (isa? ::literal))) (let [pred (literal-predicate l) pred-map (if (map? pred) pred {:pred pred}) bound (get-adorned-bindings pred) ntb (select-keys (:term-bindings l) bound)] (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal))) (defn literal-magic? "Is this literal magic?" [lit] (let [pred (literal-predicate lit)] (when (map? pred) (:magic pred)))) (defn build-seed-bindings "Given a seed literal, already adorned and in magic form, convert its bound constants to new variables." [s] (assert (-> s :literal-type (isa? ::literal))) (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))] (assoc s :term-bindings ntbs))) ;;; Semi-naive support (defn negated-literal "Given a literal l, return a negated version" [l] (assert (-> l :literal-type (= ::literal))) (assoc l :literal-type ::negated)) (defn delta-literal "Given a literal l, return a delta version" [l] (let [pred* (:predicate l) pred (if (map? pred*) pred* {:pred pred*})] (assoc l :predicate (assoc pred :delta true)))) ;;; Database operations (defn- build-partial-tuple [lit binds] (let [tbs (:term-bindings lit) each (fn [[key val :as pair]] (if (is-var? val) (if-let [n (binds val)] [key n] nil) pair))] (into {} (remove nil? (map each tbs))))) (defn- project-onto-literal "Given a literal, and a materialized tuple, return a set of variable bindings." [lit tuple] (let [step (fn [binds [key val]] (if (and (is-var? val) (contains? tuple key)) (assoc binds val (tuple key)) binds))] (reduce step {} (:term-bindings lit)))) (defn- join-literal* [db lit bs fun] (let [each (fn [binds] (let [pt (build-partial-tuple lit binds)] (fun binds pt)))] (when (contains? db (literal-predicate lit)) (apply concat (map each bs))))) (defmulti join-literal "Given a database (db), a literal (lit) and a seq of bindings (bs), return a new seq of bindings by joining this literal." (fn [db lit bs] (:literal-type lit))) (defmethod join-literal ::literal [db lit bs] (join-literal* db lit bs (fn [binds pt] (map #(merge binds %) (map (partial project-onto-literal lit) (select db (literal-predicate lit) pt)))))) (defmethod join-literal ::negated [db lit bs] (join-literal* db lit bs (fn [binds pt] (if (any-match? db (literal-predicate lit) pt) nil [binds])))) (defmethod join-literal ::conditional [db lit bs] (let [each (fn [binds] (let [resolve (fn [term] (if (is-var? term) (binds term) term)) args (map resolve (:terms lit))] (if ((:fun lit) args) binds nil)))] (remove nil? (map each bs)))) (defn project-literal "Project a stream of bindings onto a literal/relation. Returns a new db." ([db lit bs] (project-literal db lit bs is-var?)) ([db lit bs var?] (assert (= (:literal-type lit) ::literal)) (let [rel-name (literal-predicate lit) columns (-> lit :term-bindings keys) idxs (vec (get-adorned-bindings (literal-predicate lit))) db1 (ensure-relation db rel-name columns idxs) rel (get-relation db1 rel-name) step (fn [rel bindings] (let [step (fn [t [k v]] (if (var? v) (assoc t k (bindings v)) (assoc t k v))) tuple (reduce step {} (:term-bindings lit))] (add-tuple rel tuple)))] (replace-relation db rel-name (reduce step rel bs))))) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/magic.clj000066400000000000000000000115221161102570000272740ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; magic.clj ;; ;; A Clojure implementation of Datalog -- Magic Sets ;; ;; straszheimjeffrey (gmail) ;; Created 18 Feburary 2009 (ns clojure.contrib.datalog.magic (:use clojure.contrib.datalog.util clojure.contrib.datalog.literals clojure.contrib.datalog.rules) (:use [clojure.set :only (union intersection difference)])) ;;; Adornment (defn adorn-query "Adorn a query" [q] (adorned-literal q (get-self-bound-cs q))) (defn adorn-rules-set "Adorns the given rules-set for the given query. (rs) is a rules-set, (q) is an adorned query." [rs q] (let [i-preds (all-predicates rs) p-map (predicate-map rs)] (loop [nrs empty-rules-set ; The rules set being built needed #{(literal-predicate q)}] (if (empty? needed) nrs (let [pred (first needed) remaining (disj needed pred) base-pred (get-base-predicate pred) bindings (get-adorned-bindings pred) new-rules (p-map base-pred) new-adorned-rules (map (partial compute-sip bindings i-preds) new-rules) new-nrs (reduce conj nrs new-adorned-rules) current-preds (all-predicates new-nrs) not-needed? (fn [pred] (or (current-preds pred) (-> pred get-base-predicate i-preds not))) add-pred (fn [np pred] (if (not-needed? pred) np (conj np pred))) add-preds (fn [np rule] (reduce add-pred np (map literal-predicate (:body rule)))) new-needed (reduce add-preds remaining new-adorned-rules)] (recur new-nrs new-needed)))))) ;;; Magic ! (defn seed-relation "Given a magic form of a query, give back the literal form of its seed relation" [q] (let [pred (-> q literal-predicate get-base-predicate) bnds (-> q literal-predicate get-adorned-bindings)] (with-meta (assoc q :predicate [pred :magic-seed bnds]) {}))) (defn seed-rule "Given an adorned query, give back its seed rule" [q] (let [mq (build-seed-bindings (magic-literal q)) sr (seed-relation mq)] (build-rule mq [sr]))) (defn build-partial-tuple "Given a query and a set of bindings, build a partial tuple needed to extract the relation from the database." [q bindings] (into {} (remove nil? (map (fn [[k v :as pair]] (if (is-var? v) nil (if (is-query-var? v) [k (bindings v)] pair))) (:term-bindings q))))) (defn seed-predicate-for-insertion "Given a query, return the predicate to use for database insertion." [q] (let [seed (-> q seed-rule :body first) columns (-> seed :term-bindings keys) new-term-bindings (-> q :term-bindings (select-keys columns))] (assoc seed :term-bindings new-term-bindings))) (defn magic-transform "Return a magic transformation of an adorned rules-set (rs). The (i-preds) are the predicates of the intension database. These default to the predicates within the rules-set." ([rs] (magic-transform rs (all-predicates rs))) ([rs i-preds] (let [not-duplicate? (fn [l mh bd] (or (not (empty? bd)) (not (= (magic-literal l) mh)))) xr (fn [rs rule] (let [head (:head rule) body (:body rule) mh (magic-literal head) answer-rule (build-rule head (concat [mh] body)) step (fn [[rs bd] l] (if (and (i-preds (literal-predicate l)) (not-duplicate? l mh bd)) (let [nr (build-rule (magic-literal l) (concat [mh] bd))] [(conj rs nr) (conj bd l)]) [rs (conj bd l)])) [nrs _] (reduce step [rs []] body)] (conj nrs answer-rule)))] (reduce xr empty-rules-set rs)))) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/rules.clj000066400000000000000000000141561161102570000273540ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; rules.clj ;; ;; A Clojure implementation of Datalog -- Rules Engine ;; ;; straszheimjeffrey (gmail) ;; Created 2 Feburary 2009 (ns clojure.contrib.datalog.rules (:use clojure.contrib.datalog.util) (:use clojure.contrib.datalog.literals clojure.contrib.datalog.database) (:use [clojure.set :only (union intersection difference)]) (:use [clojure.contrib.set :only (subset?)]) (:use [clojure.contrib.except :only (throwf)]) (:import java.io.Writer)) (defstruct datalog-rule :head :body) (defn display-rule "Return the rule in a readable format." [rule] (list* '<- (-> rule :head display-literal) (map display-literal (:body rule)))) (defn display-query "Return a query in a readable format." [query] (list* '?- (display-literal query))) ;;; Check rule safety (defn is-safe? "Is the rule safe according to the datalog protocol?" [rule] (let [hv (literal-vars (:head rule)) bpv (apply union (map positive-vars (:body rule))) bnv (apply union (map negative-vars (:body rule))) ehv (difference hv bpv) env (difference bnv bpv)] (when-not (empty? ehv) (throwf "Head vars %s not bound in body in rule %s" ehv rule)) (when-not (empty? env) (throwf "Body vars %s not bound in negative positions in rule %s" env rule)) rule)) ;;; Rule creation and printing (defn build-rule [hd bd] (with-meta (struct datalog-rule hd bd) {:type ::datalog-rule})) (defmacro <- "Build a datalog rule. Like this: (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))" [hd & body] (let [head (build-atom hd :clojure.contrib.datalog.literals/literal) body (map build-literal body)] `(is-safe? (build-rule ~head [~@body])))) (defmethod print-method ::datalog-rule [rule ^Writer writer] (print-method (display-rule rule) writer)) (defn return-rule-data "Returns an untypted rule that will be fully printed" [rule] (with-meta rule {})) (defmacro ?- "Define a datalog query" [& q] (let [qq (build-atom q :clojure.contrib.datalog.literals/literal)] `(with-meta ~qq {:type ::datalog-query}))) (defmethod print-method ::datalog-query [query ^Writer writer] (print-method (display-query query) writer)) ;;; SIP (defn compute-sip "Given a set of bound column names, return an adorned sip for this rule. A set of intensional predicates should be provided to determine what should be adorned." [bindings i-preds rule] (let [next-lit (fn [bv body] (or (first (drop-while #(not (literal-appropriate? bv %)) body)) (first (drop-while (complement positive?) body)))) adorn (fn [lit bvs] (if (i-preds (literal-predicate lit)) (let [bnds (union (get-cs-from-vs lit bvs) (get-self-bound-cs lit))] (adorned-literal lit bnds)) lit)) new-h (adorned-literal (:head rule) bindings)] (loop [bound-vars (get-vs-from-cs (:head rule) bindings) body (:body rule) sip []] (if-let [next (next-lit bound-vars body)] (recur (union bound-vars (literal-vars next)) (remove #(= % next) body) (conj sip (adorn next bound-vars))) (build-rule new-h (concat sip body)))))) ;;; Rule sets (defn make-rules-set "Given an existing set of rules, make it a 'rules-set' for printing." [rs] (with-meta rs {:type ::datalog-rules-set})) (def empty-rules-set (make-rules-set #{})) (defn rules-set "Given a collection of rules return a rules set" [& rules] (reduce conj empty-rules-set rules)) (defmethod print-method ::datalog-rules-set [rules ^Writer writer] (binding [*out* writer] (do (print "(rules-set") (doseq [rule rules] (println) (print " ") (print rule)) (println ")")))) (defn predicate-map "Given a rules-set, return a map of rules keyed by their predicates. Each value will be a set of rules." [rs] (let [add-rule (fn [m r] (let [pred (-> r :head literal-predicate) os (get m pred #{})] (assoc m pred (conj os r))))] (reduce add-rule {} rs))) (defn all-predicates "Given a rules-set, return all defined predicates" [rs] (set (map literal-predicate (map :head rs)))) (defn non-base-rules "Return a collection of rules that depend, somehow, on other rules" [rs] (let [pred (all-predicates rs) non-base (fn [r] (if (some #(pred %) (map literal-predicate (:body r))) r nil))] (remove nil? (map non-base rs)))) ;;; Database operations (def empty-bindings [{}]) (defn apply-rule "Apply the rule against db-1, adding the results to the appropriate relation in db-2. The relation will be created if needed." ([db rule] (apply-rule db db rule)) ([db-1 db-2 rule] (trace-datalog (println) (println) (println "--------------- Begin Rule ---------------") (println rule)) (let [head (:head rule) body (:body rule) step (fn [bs lit] (trace-datalog (println bs) (println lit)) (join-literal db-1 lit bs)) bs (reduce step empty-bindings body)] (do (trace-datalog (println bs)) (project-literal db-2 head bs))))) (defn apply-rules-set [db rs] (reduce (fn [rdb rule] (apply-rule db rdb rule)) db rs)) ;; End of fileclojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/softstrat.clj000066400000000000000000000125431161102570000302510ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; softstrat.clj ;; ;; A Clojure implementation of Datalog -- Soft Stratification ;; ;; straszheimjeffrey (gmail) ;; Created 28 Feburary 2009 (ns clojure.contrib.datalog.softstrat (:use clojure.contrib.datalog.util clojure.contrib.datalog.database clojure.contrib.datalog.literals clojure.contrib.datalog.rules clojure.contrib.datalog.magic) (:use [clojure.set :only (union intersection difference)]) (:use [clojure.contrib.seq :only (indexed)]) (:require [clojure.contrib.graph :as graph])) ;;; Dependency graph (defn- build-rules-graph "Given a rules-set (rs), build a graph where each predicate symbol in rs, there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges from the (literal-predicate h) -> (literal-predicate b-*), one for each b-*." [rs] (let [preds (all-predicates rs) pred-map (predicate-map rs) step (fn [nbs pred] (let [rules (pred-map pred) preds (reduce (fn [pds lits] (reduce (fn [pds lit] (if-let [pred (literal-predicate lit)] (conj pds pred) pds)) pds lits)) #{} (map :body rules))] (assoc nbs pred preds))) neighbors (reduce step {} preds)] (struct graph/directed-graph preds neighbors))) (defn- build-def "Given a rules-set, build its def function" [rs] (let [pred-map (predicate-map rs) graph (-> rs build-rules-graph graph/transitive-closure graph/add-loops)] (fn [pred] (apply union (map set (map pred-map (graph/get-neighbors graph pred))))))) ;;; Soft Stratificattion REQ Graph (defn- req "Returns a rules-set that is a superset of req(lit) for the lit at index lit-index" [rs soft-def rule lit-index] (let [head (:head rule) body (:body rule) lit (nth body lit-index) pre (subvec (vec body) 0 lit-index)] (conj (-> lit literal-predicate soft-def (magic-transform (all-predicates rs))) (build-rule (magic-literal lit) pre)))) (defn- rule-dep "Given a rule, return the set of rules it depends on." [rs mrs soft-def rule] (let [step (fn [nrs [idx lit]] (if (negated? lit) (union nrs (req rs soft-def rule idx)) nrs))] (intersection mrs (reduce step empty-rules-set (-> rule :body indexed))))) (defn- soft-strat-graph "The dependency graph for soft stratification." [rs mrs] (let [soft-def (build-def rs) step (fn [nbrs rule] (assoc nbrs rule (rule-dep rs mrs soft-def rule))) nbrs (reduce step {} mrs)] (struct graph/directed-graph mrs nbrs))) (defn- build-soft-strat "Given a rules-set (unadorned) and an adorned query, return the soft stratified list. The rules will be magic transformed, and the magic seed will be appended." [rs q] (let [ars (adorn-rules-set rs q) mrs (conj (magic-transform ars) (seed-rule q)) gr (soft-strat-graph ars mrs)] (map make-rules-set (graph/dependency-list gr)))) ;;; Work plan (defstruct soft-strat-work-plan :query :stratification) (defn build-soft-strat-work-plan "Return a work plan for the given rules-set and query" [rs q] (let [aq (adorn-query q)] (struct soft-strat-work-plan aq (build-soft-strat rs aq)))) (defn get-all-relations "Return a set of all relation names defined in this workplan" [ws] (apply union (map all-predicates (:stratification ws)))) ;;; Evaluate (defn- weak-consq-operator [db strat] (trace-datalog (println) (println) (println "=============== Begin iteration ===============")) (let [counts (database-counts db)] (loop [strat strat] (let [rs (first strat)] (if rs (let [new-db (apply-rules-set db rs)] (if (= counts (database-counts new-db)) (recur (next strat)) new-db)) db))))) (defn evaluate-soft-work-set ([ws db] (evaluate-soft-work-set ws db {})) ([ws db bindings] (let [query (:query ws) strat (:stratification ws) seed (seed-predicate-for-insertion query) seeded-db (project-literal db seed [bindings] is-query-var?) fun (fn [data] (weak-consq-operator data strat)) equal (fn [db1 db2] (= (database-counts db1) (database-counts db2))) new-db (graph/fixed-point seeded-db fun nil equal) pt (build-partial-tuple query bindings)] (select new-db (literal-predicate query) pt)))) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/datalog/util.clj000066400000000000000000000050421161102570000271710ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; util.clj ;; ;; A Clojure implementation of Datalog -- Utilities ;; ;; straszheimjeffrey (gmail) ;; Created 3 Feburary 2009 (ns clojure.contrib.datalog.util (:use [clojure.contrib.seq :only (separate)])) ;;; Bindings and logic vars. A binding in a hash of logic vars to ;;; bound values. Logic vars are any symbol prefixed with a \?. (defn is-var? "Is this a logic variable: e.g. a symbol prefixed with a ?" [sym] (when (symbol? sym) (let [name (name sym)] (and (= \? (first name)) (not= \? (fnext name)))))) (defn is-query-var? "Is this a query variable: e.g. a symbol prefixed with ??" [sym] (when (symbol? sym) (let [name (name sym)] (and (= \? (first name)) (= \? (fnext name)))))) (defn map-values "Like map, but works over the values of a hash map" [f hash] (let [key-vals (map (fn [[key val]] [key (f val)]) hash)] (if (seq key-vals) (apply conj (empty hash) key-vals) hash))) (defn keys-to-vals "Given a map and a collection of keys, return the collection of vals" [m ks] (vals (select-keys m ks))) (defn reverse-map "Reverse the keys/values of a map" [m] (into {} (map (fn [[k v]] [v k]) m))) ;;; Preduce -- A parallel reduce over hashes (defn preduce "Similar to merge-with, but the contents of each key are merged in parallel using f. f - a function of 2 arguments. data - a collection of hashes." [f data] (let [data-1 (map (fn [h] (map-values #(list %) h)) data) merged (doall (apply merge-with concat data-1)) ; Groups w/ multiple elements are identified for parallel processing [complex simple] (separate (fn [[key vals]] (> (count vals) 1)) merged) fold-group (fn [[key vals]] {key (reduce f vals)}) fix-single (fn [[key [val]]] [key val])] (apply merge (concat (pmap fold-group merged) (map fix-single simple))))) ;;; Debuging and Tracing (def *trace-datalog* nil) (defmacro trace-datalog "If *test-datalog* is set to true, run the enclosed commands" [& body] `(when *trace-datalog* ~@body)) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/def.clj000066400000000000000000000135601161102570000253430ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; 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 ^{:author "Stephen C. Gilardi", :doc "def.clj provides variants of def that make including doc strings and making private definitions more succinct."} clojure.contrib.def) (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 defonce- "Same as defonce but yields a private definition" ([name expr] (list `defonce (with-meta name (assoc (meta name) :private true)) expr)) ([name expr doc] (list `defonce (with-meta name (assoc (meta name) :private true :doc doc)) expr))) (defmacro defalias "Defines an alias for a var: a new var with the same root binding (if any) and similar metadata. The metadata of the alias is its initial metadata (as provided by def) merged into the metadata of the original." ([name orig] `(do (alter-meta! (if (.hasRoot (var ~orig)) (def ~name (.getRoot (var ~orig))) (def ~name)) ;; When copying metadata, disregard {:macro false}. ;; Workaround for http://www.assembla.com/spaces/clojure/tickets/273 #(conj (dissoc % :macro) (apply dissoc (meta (var ~orig)) (remove #{:macro} (keys %))))) (var ~name))) ([name orig doc] (list `defalias (with-meta name (assoc (meta name) :doc doc)) orig))) ; defhinted by Chouser: (defmacro defhinted "Defines a var with a type hint matching the class of the given init. Be careful about using any form of 'def' or 'binding' to a value of a different type. See http://paste.lisp.org/display/73344" [sym init] `(do (def ~sym ~init) (alter-meta! (var ~sym) assoc :tag (class ~sym)) (var ~sym))) ; name-with-attributes by Konrad Hinsen: (defn name-with-attributes "To be used in macro definitions. Handles optional docstrings and attribute maps for a name to be defined in a list of macro arguments. If the first macro argument is a string, it is added as a docstring to name and removed from the macro argument list. If afterwards the first macro argument is a map, its entries are added to the name's metadata map and the map is removed from the macro argument list. The return value is a vector containing the name with its extended metadata map and the list of unprocessed macro arguments." [name macro-args] (let [[docstring macro-args] (if (string? (first macro-args)) [(first macro-args) (next macro-args)] [nil macro-args]) [attr macro-args] (if (map? (first macro-args)) [(first macro-args) (next macro-args)] [{} macro-args]) attr (if docstring (assoc attr :doc docstring) attr) attr (if (meta name) (conj (meta name) attr) attr)] [(with-meta name attr) macro-args])) ; defnk by Meikel Brandmeyer: (defmacro defnk "Define a function accepting keyword arguments. Symbols up to the first keyword in the parameter list are taken as positional arguments. Then an alternating sequence of keywords and defaults values is expected. The values of the keyword arguments are available in the function body by virtue of the symbol corresponding to the keyword (cf. :keys destructuring). defnk accepts an optional docstring as well as an optional metadata map." [fn-name & fn-tail] (let [[fn-name [args & body]] (name-with-attributes fn-name fn-tail) [pos kw-vals] (split-with symbol? args) syms (map #(-> % name symbol) (take-nth 2 kw-vals)) values (take-nth 2 (rest kw-vals)) sym-vals (apply hash-map (interleave syms values)) de-map {:keys (vec syms) :or sym-vals}] `(defn ~fn-name [~@pos & options#] (let [~de-map (apply hash-map options#)] ~@body)))) ; defn-memo by Chouser: (defmacro defn-memo "Just like defn, but memoizes the function using clojure.core/memoize" [fn-name & defn-stuff] `(do (defn ~fn-name ~@defn-stuff) (alter-var-root (var ~fn-name) memoize) (var ~fn-name))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/duck_streams.clj000066400000000000000000000322301161102570000272640ustar00rootroot00000000000000;;; duck_streams.clj -- duck-typed I/O streams for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; May 13, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; This file defines "duck-typed" I/O utility functions for Clojure. ;; The 'reader' and 'writer' functions will open and return an ;; instance of java.io.BufferedReader and java.io.PrintWriter, ;; respectively, for a variety of argument types -- filenames as ;; strings, URLs, java.io.File's, etc. 'reader' even works on http ;; URLs. ;; ;; Note: this is not really "duck typing" as implemented in languages ;; like Ruby. A better name would have been "do-what-I-mean-streams" ;; or "just-give-me-a-stream", but ducks are funnier. ;; CHANGE LOG ;; ;; July 23, 2010: DEPRECATED in 1.2. Use clojure.java.io instead. ;; ;; May 13, 2009: added functions to open writers for appending ;; ;; May 3, 2009: renamed file to file-str, for compatibility with ;; clojure.contrib.java-utils. reader/writer no longer use this ;; function. ;; ;; February 16, 2009: (lazy branch) fixed read-lines to work with lazy ;; Clojure. ;; ;; January 10, 2009: added *default-encoding*, so streams are always ;; opened as UTF-8. ;; ;; December 19, 2008: rewrote reader and writer as multimethods; added ;; slurp*, file, and read-lines ;; ;; April 8, 2008: first version (ns ^{:author "Stuart Sierra", :deprecated "1.2" :doc "This file defines \"duck-typed\" I/O utility functions for Clojure. The 'reader' and 'writer' functions will open and return an instance of java.io.BufferedReader and java.io.PrintWriter, respectively, for a variety of argument types -- filenames as strings, URLs, java.io.File's, etc. 'reader' even works on http URLs. Note: this is not really \"duck typing\" as implemented in languages like Ruby. A better name would have been \"do-what-I-mean-streams\" or \"just-give-me-a-stream\", but ducks are funnier."} clojure.contrib.duck-streams (:refer-clojure :exclude (spit)) (:import (java.io Reader InputStream InputStreamReader PushbackReader BufferedReader File PrintWriter OutputStream OutputStreamWriter BufferedWriter Writer FileInputStream FileOutputStream ByteArrayOutputStream StringReader ByteArrayInputStream) (java.net URI URL MalformedURLException Socket))) (def ^{:doc "Name of the default encoding to use when reading & writing. Default is UTF-8." :tag "java.lang.String"} *default-encoding* "UTF-8") (def ^{:doc "Size, in bytes or characters, of the buffer used when copying streams."} *buffer-size* 1024) (def ^{:doc "Type object for a Java primitive byte array."} *byte-array-type* (class (make-array Byte/TYPE 0))) (defn ^File file-str "Concatenates args as strings and returns a java.io.File. Replaces all / and \\ with File/separatorChar. Replaces ~ at the start of the path with the user.home system property." [& args] (let [^String s (apply str args) s (.replaceAll (re-matcher #"[/\\]" s) File/separator) s (if (.startsWith s "~") (str (System/getProperty "user.home") File/separator (subs s 1)) s)] (File. s))) (defmulti ^{:tag BufferedReader :doc "Attempts to coerce its argument into an open java.io.BufferedReader. Argument may be an instance of Reader, BufferedReader, InputStream, File, URI, URL, Socket, or String. If argument is a String, it tries to resolve it first as a URI, then as a local file name. URIs with a 'file' protocol are converted to local file names. Uses *default-encoding* as the text encoding. Should be used inside with-open to ensure the Reader is properly closed." :arglists '([x])} reader class) (defmethod reader Reader [x] (BufferedReader. x)) (defmethod reader InputStream [^InputStream x] (BufferedReader. (InputStreamReader. x *default-encoding*))) (defmethod reader File [^File x] (reader (FileInputStream. x))) (defmethod reader URL [^URL x] (reader (if (= "file" (.getProtocol x)) (FileInputStream. (.getPath x)) (.openStream x)))) (defmethod reader URI [^URI x] (reader (.toURL x))) (defmethod reader String [^String x] (try (let [url (URL. x)] (reader url)) (catch MalformedURLException e (reader (File. x))))) (defmethod reader Socket [^Socket x] (reader (.getInputStream x))) (defmethod reader :default [x] (throw (Exception. (str "Cannot open " (pr-str x) " as a reader.")))) (def ^{:doc "If true, writer and spit will open files in append mode. Defaults to false. Use append-writer or append-spit." :tag "java.lang.Boolean"} *append-to-writer* false) (defmulti ^{:tag PrintWriter :doc "Attempts to coerce its argument into an open java.io.PrintWriter wrapped around a java.io.BufferedWriter. Argument may be an instance of Writer, PrintWriter, BufferedWriter, OutputStream, File, URI, URL, Socket, or String. If argument is a String, it tries to resolve it first as a URI, then as a local file name. URIs with a 'file' protocol are converted to local file names. Should be used inside with-open to ensure the Writer is properly closed." :arglists '([x])} writer class) (defn- assert-not-appending [] (when *append-to-writer* (throw (Exception. "Cannot change an open stream to append mode.")))) (defmethod writer PrintWriter [x] (assert-not-appending) x) (defmethod writer BufferedWriter [^BufferedWriter x] (assert-not-appending) (PrintWriter. x)) (defmethod writer Writer [x] (assert-not-appending) ;; Writer includes sub-classes such as FileWriter (PrintWriter. (BufferedWriter. x))) (defmethod writer OutputStream [^OutputStream x] (assert-not-appending) (PrintWriter. (BufferedWriter. (OutputStreamWriter. x *default-encoding*)))) (defmethod writer File [^File x] (let [stream (FileOutputStream. x *append-to-writer*)] (binding [*append-to-writer* false] (writer stream)))) (defmethod writer URL [^URL x] (if (= "file" (.getProtocol x)) (writer (File. (.getPath x))) (throw (Exception. (str "Cannot write to non-file URL <" x ">"))))) (defmethod writer URI [^URI x] (writer (.toURL x))) (defmethod writer String [^String x] (try (let [url (URL. x)] (writer url)) (catch MalformedURLException err (writer (File. x))))) (defmethod writer Socket [^Socket x] (writer (.getOutputStream x))) (defmethod writer :default [x] (throw (Exception. (str "Cannot open <" (pr-str x) "> as a writer.")))) (defn append-writer "Like writer but opens file for appending. Does not work on streams that are already open." [x] (binding [*append-to-writer* true] (writer x))) (defn write-lines "Writes lines (a seq) to f, separated by newlines. f is opened with writer, and automatically closed at the end of the sequence." [f lines] (with-open [^PrintWriter writer (writer f)] (loop [lines lines] (when-let [line (first lines)] (.write writer (str line)) (.println writer) (recur (rest lines)))))) (defn read-lines "Like clojure.core/line-seq but opens f with reader. Automatically closes the reader AFTER YOU CONSUME THE ENTIRE SEQUENCE." [f] (let [read-line (fn this [^BufferedReader rdr] (lazy-seq (if-let [line (.readLine rdr)] (cons line (this rdr)) (.close rdr))))] (read-line (reader f)))) (defn ^String slurp* "Like clojure.core/slurp but opens f with reader." [f] (with-open [^BufferedReader r (reader f)] (let [sb (StringBuilder.)] (loop [c (.read r)] (if (neg? c) (str sb) (do (.append sb (char c)) (recur (.read r)))))))) (defn spit "Opposite of slurp. Opens f with writer, writes content, then closes f." [f content] (with-open [^PrintWriter w (writer f)] (.print w content))) (defn append-spit "Like spit but appends to file." [f content] (with-open [^PrintWriter w (append-writer f)] (.print w content))) (defn pwd "Returns current working directory as a String. (Like UNIX 'pwd'.) Note: In Java, you cannot change the current working directory." [] (System/getProperty "user.dir")) (defmacro with-out-writer "Opens a writer on f, binds it to *out*, and evalutes body. Anything printed within body will be written to f." [f & body] `(with-open [stream# (writer ~f)] (binding [*out* stream#] ~@body))) (defmacro with-out-append-writer "Like with-out-writer but appends to file." [f & body] `(with-open [stream# (append-writer ~f)] (binding [*out* stream#] ~@body))) (defmacro with-in-reader "Opens a PushbackReader on f, binds it to *in*, and evaluates body." [f & body] `(with-open [stream# (PushbackReader. (reader ~f))] (binding [*in* stream#] ~@body))) (defmulti ^{:doc "Copies input to output. Returns nil. Input may be an InputStream, Reader, File, byte[], or String. Output may be an OutputStream, Writer, or File. Does not close any streams except those it opens itself (on a File). Writing a File fails if the parent directory does not exist." :arglists '([input output])} copy (fn [input output] [(type input) (type output)])) (defmethod copy [InputStream OutputStream] [^InputStream input ^OutputStream output] (let [buffer (make-array Byte/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (do (.write output buffer 0 size) (recur))))))) (defmethod copy [InputStream Writer] [^InputStream input ^Writer output] (let [^"[B" buffer (make-array Byte/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (let [chars (.toCharArray (String. buffer 0 size *default-encoding*))] (do (.write output chars) (recur)))))))) (defmethod copy [InputStream File] [^InputStream input ^File output] (with-open [out (FileOutputStream. output)] (copy input out))) (defmethod copy [Reader OutputStream] [^Reader input ^OutputStream output] (let [^"[C" buffer (make-array Character/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (let [bytes (.getBytes (String. buffer 0 size) *default-encoding*)] (do (.write output bytes) (recur)))))))) (defmethod copy [Reader Writer] [^Reader input ^Writer output] (let [^"[C" buffer (make-array Character/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (do (.write output buffer 0 size) (recur))))))) (defmethod copy [Reader File] [^Reader input ^File output] (with-open [out (FileOutputStream. output)] (copy input out))) (defmethod copy [File OutputStream] [^File input ^OutputStream output] (with-open [in (FileInputStream. input)] (copy in output))) (defmethod copy [File Writer] [^File input ^Writer output] (with-open [in (FileInputStream. input)] (copy in output))) (defmethod copy [File File] [^File input ^File output] (with-open [in (FileInputStream. input) out (FileOutputStream. output)] (copy in out))) (defmethod copy [String OutputStream] [^String input ^OutputStream output] (copy (StringReader. input) output)) (defmethod copy [String Writer] [^String input ^Writer output] (copy (StringReader. input) output)) (defmethod copy [String File] [^String input ^File output] (copy (StringReader. input) output)) (defmethod copy [*byte-array-type* OutputStream] [^"[B" input ^OutputStream output] (copy (ByteArrayInputStream. input) output)) (defmethod copy [*byte-array-type* Writer] [^"[B" input ^Writer output] (copy (ByteArrayInputStream. input) output)) (defmethod copy [*byte-array-type* File] [^"[B" input ^Writer output] (copy (ByteArrayInputStream. input) output)) (defn make-parents "Creates all parent directories of file." [^File file] (.mkdirs (.getParentFile file))) (defmulti ^{:doc "Converts argument into a Java byte array. Argument may be a String, File, InputStream, or Reader. If the argument is already a byte array, returns it." :arglists '([arg])} to-byte-array type) (defmethod to-byte-array *byte-array-type* [x] x) (defmethod to-byte-array String [^String x] (.getBytes x *default-encoding*)) (defmethod to-byte-array File [^File x] (with-open [input (FileInputStream. x) buffer (ByteArrayOutputStream.)] (copy input buffer) (.toByteArray buffer))) (defmethod to-byte-array InputStream [^InputStream x] (let [buffer (ByteArrayOutputStream.)] (copy x buffer) (.toByteArray buffer))) (defmethod to-byte-array Reader [^Reader x] (.getBytes (slurp* x) *default-encoding*)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/error_kit.clj000066400000000000000000000256471161102570000266160ustar00rootroot00000000000000; Copyright (c) Chris Houser, Jan 2009. 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. ; == EXPERIMENTAL == ; System for defining and using custom errors ; Please contact Chouser if you have any suggestions for better names ; or API adjustments. (ns ^{:author "Chris Houser", :doc "EXPERIMENTAL System for defining and using custom errors Please contact Chouser if you have any suggestions for better names or API adjustments."} clojure.contrib.error-kit (:use [clojure.contrib.def :only (defvar defvar-)] [clojure.stacktrace :only (root-cause)])) (defn- make-ctrl-exception [msg data] "Create an exception object with associated data, used for passing control and data to a dynamically containing handler." (proxy [Error clojure.lang.IDeref] [msg] (toString [] (str "Error Kit Control Exception: " msg ", " (pr-str data))) (deref [] data))) (defvar- ctrl-exception-class (class (make-ctrl-exception nil nil))) (defvar- *handler-stack* () "Stack of bound handler symbols") (defvar- *continues* {} "Map of currently available continue forms") (defmacro throw-msg "Returns a function that throws a Java Exception with the given name. Useful to associate a new error-kit error type with a particular Java Exception class, via the :unhandled error key." [class-name] `(fn [x#] (throw (new ~class-name (:msg x#))))) (defn error "Base type for all error-kit errors" {::args [:msg :unhandled :tag]} [details] (merge {:tag `error :msg "exception via error-kit" :unhandled (throw-msg Exception)} details)) (defn- qualify-sym [sym] (let [v (resolve sym)] (assert v) (apply symbol (map #(str (% (meta v))) [:ns :name])))) (defmacro deferror "Define a new error type" {:arglists '([name [parent-error?] doc-string? [args*] & body] [name [parent-error?] doc-string? args-destruct-map & body])} [err-name pvec & decl] (let [pvec (if (empty? pvec) [`error] pvec) [docstr args & body] (if (string? (first decl)) decl (cons nil decl)) args (or args []) argmap (if (vector? args) `{:keys ~args} args) body (or body {}) qual-err-name (symbol (str *ns*) (name err-name))] (assert (== (count pvec) 1)) ; only support single-inheritance for now (assert (vector? args)) ; only vector (keyword destruct) args for now `(do (defn ~err-name [details#] (let [basedata# ((resolve (first (parents '~qual-err-name))) details#) ~argmap basedata#] (merge basedata# {:tag '~qual-err-name} (do ~@body) details#))) (alter-meta! (var ~err-name) assoc :doc ~docstr ::args ~(vec (map #(keyword (str %)) args))) ~@(for [parent pvec] `(derive '~qual-err-name '~(qualify-sym parent))) (var ~err-name)))) (defn- throw-to [msg target-map args] (throw (make-ctrl-exception msg (assoc target-map :args args)))) (defn raise* "Raise the given error object, best if created by an error constructor defined with deferror. See also 'raise' macro." [err] (let [err-tag (:tag err)] (loop [hs *handler-stack*] (if (empty? hs) ((:unhandled err) err) (let [[{:keys [htag] :as handler}] hs] (if (and htag (not (isa? err-tag htag))) (recur (next hs)) (let [rtn ((:hfunc handler) err)] (if-not (vector? rtn) (throw-to "default" handler (list rtn)) (condp = (rtn 0) ::continue-with (rtn 1) ::continue (if-let [continue (*continues* (rtn 1))] (throw-to "continue" continue (rtn 2)) (do (prn *continues*) (throw (Exception. (str "Unbound continue name " (rtn 1)))))) ::do-not-handle (recur (next hs)) (throw-to "do-not-handle" handler (list rtn))))))))))) (defmacro raise "Raise an error of the type err-name, constructed with the given args" [err-name & args] `(raise* (~err-name ~(zipmap (::args (meta (resolve err-name))) args)))) ; It'd be nice to assert that these are used in a tail position of a handler (defmacro do-not-handle "Use in a tail position of a 'handle' form to indicate 'raise' should not consider the error handled, but should continue searching for an appropriate 'handle' form. Allows finer-grain control over catching than just the error type." [] `[::do-not-handle]) (defmacro continue-with [value] "Use in a tail position of a 'handle' form to cause the currently running 'raise' to return the given 'value'." `[::continue-with ~value]) (defmacro continue [continue-name & args] "Use in a tail position of a 'handle' form to pass control to the named 'continue' form, passing in the given args. The 'continue' form with the given name and the smallest dynamic scope surrounding the currently running 'raise' will be used." `[::continue '~continue-name [~@args]]) (def ^{:doc "Special form to be used inside a 'with-handler'. When any error is 'raised' from withing the dynamic scope of 'body' that is of error-name's type or a derived type, the args will be bound and the body executed. If no 'error-name' is given, the body will be executed for regardless of the type of error raised. The body may return a value, in which case that will be the return value of the entire 'with-handler' form, or it may use any of the special return forms, 'do-not-handle', 'continue-with', or 'continue'." :arglists '([error-name? [args*] & body] [error-name? args-destruct-map-args & body])} handle) (def ^{:doc "Special form to be used inside a 'with-handler'. Control can be passed to this 'continue' form from a 'raise' enclosed in this with-handler's dynamic scope, when this 'continue-name' is given to a 'continue' form." :arglists '([continue-name [args*] & body])} bind-continue) (defn- special-form [form] (and (list form) (symbol? (first form)) (#{#'handle #'bind-continue} (resolve (first form))))) (defmacro with-handler "This is error-kit's dynamic scope form. The body will be executed in a dynamic context that includes all of the following 'handle' and 'bind-continue' forms." [& forms] (let [[body special-forms] (split-with (complement special-form) forms)] (assert (every? special-form special-forms)) (let [blockid (gensym) handlers (for [[type & more] special-forms :when (= (resolve type) #'handle)] (let [[htag args & hbody] (if (symbol? (first more)) more (cons nil more)) argmap (if (vector? args) `{:keys ~args} args)] `{:blockid '~blockid :htag ~(when htag (list `quote (qualify-sym htag))) :hfunc (fn [~argmap] ~@hbody) :rfunc identity})) continues (into {} (for [[type & more] special-forms :when (= (resolve type) #'bind-continue)] [(list `quote (first more)) `{:blockid '~blockid :rfunc (fn ~@(next more))}]))] `(try (binding [*handler-stack* (list* ~@handlers @#'*handler-stack*) *continues* (merge @#'*continues* ~@continues)] ~@body) (catch Throwable e# (let [root-cause# (root-cause e#)] (if-not (instance? @#'ctrl-exception-class root-cause#) (throw e#) (let [data# @root-cause#] (if (= '~blockid (:blockid data#)) (apply (:rfunc data#) (:args data#)) (throw e#)))))))))) (defn rebind-fn [func] (let [a *handler-stack*, b *continues*] (fn [& args] (binding [*handler-stack* a *continues* b] (apply func args))))) (comment (alias 'kit 'clojure.contrib.error-kit) ; This defines an error and its action if unhandled. A good choice of ; unhandled. action is to throw a Java exception so users of your code ; who do not want to use error-kit can still use normal Java try/catch ; forms to handle the error. (kit/deferror number-error [] [n] {:msg (str "Number error: " n) :unhandled (kit/throw-msg NumberFormatException)}) (kit/deferror odd-number-error [number-error] "Indicates an odd number was given to an operation that is only defined for even numbers." [n] {:msg (str "Can't handle odd number: " n)}) ; Raise an error by name with any extra args defined by the deferror (defn int-half [i] (if (even? i) (quot i 2) (kit/raise odd-number-error i))) ; Throws Java NumberFormatException because there's no 'handle' form (vec (map int-half [2 4 5 8])) ; Throws Java Exception with details provided by 'raise' (kit/with-handler (vec (map int-half [2 4 5 8])) (kit/handle odd-number-error [n] (throw (Exception. (format "Odd number %d in vector." n))))) ; The above is equivalent to the more complicated version below: (kit/with-handler (vec (map int-half [2 4 5 8])) (kit/handle {:keys [n tag]} (if (isa? tag `odd-number-error) (throw (Exception. (format "Odd number %d in vector." n))) (kit/do-not-handle)))) ; Returns "invalid" string instead of a vector when an error is encountered (kit/with-handler (vec (map int-half [2 4 5 8])) (kit/handle kit/error [n] "invalid")) ; Inserts a zero into the returned vector where there was an error, in ; this case [1 2 0 4] (kit/with-handler (vec (map int-half [2 4 5 8])) (kit/handle number-error [n] (kit/continue-with 0))) ; Intermediate continue: [1 2 :oops 5 4] (defn int-half-vec [s] (reduce (fn [v i] (kit/with-handler (conj v (int-half i)) (kit/bind-continue instead-of-half [& instead-seq] (apply conj v instead-seq)))) [] s)) (kit/with-handler (int-half-vec [2 4 5 8]) (kit/handle number-error [n] (kit/continue instead-of-half :oops n))) ; Notes: ; It seems likely you'd want to convert a handle clause to ; bind-continue, since it would allow higher forms to request what you ; used to do by default. Thus both should appear in the same ; with-handler form ; Should continue-names be namespace qualified, and therefore require ; pre-definition in some namespace? ; (kit/defcontinue skip-thing "docstring") ; Could add 'catch' for Java Exceptions and 'finally' support to ; with-handler forms. ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/except.clj000066400000000000000000000065651161102570000261040ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; except.clj ;; ;; Provides functions that make it easy to specify the class, cause, and ;; message when throwing an Exception or Error. The optional message is ;; formatted using clojure.core/format. ;; ;; scgilardi (gmail) ;; Created 07 July 2008 (ns ^{:author "Stephen C. Gilardi", :doc "Provides functions that make it easy to specify the class, cause, and message when throwing an Exception or Error. The optional message is formatted using clojure.core/format."} clojure.contrib.except (:import (clojure.lang Reflector))) (declare throwable) (defn throwf "Throws an Exception or Error with an optional message formatted using clojure.core/format. All arguments are optional: class? cause? format? format-args* - class defaults to Exception, if present it must name a kind of Throwable - cause defaults to nil, if present it must be a Throwable - format is a format string for clojure.core/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)))) (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: cause? format? format-args* - cause defaults to nil, if present it must be a Throwable - format is a format string for clojure.core/format - format-args are objects that correspond to format specifiers in format." [& args] (throw (throwable (cons IllegalArgumentException args)))) (defn- throwable? "Returns true if x is a Throwable" [x] (instance? Throwable x)) (defn- throwable "Constructs a Throwable with optional cause and 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 [[arg] args [class & args] (if (class? arg) args (cons Exception args)) [arg] args [cause & args] (if (throwable? arg) args (cons nil args)) message (when args (apply format args)) ctor-args (into-array Object (cond (and message cause) [message cause] message [message] cause [cause])) 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 StackTraceElement (drop 3 (drop-while not-us? raw-trace)))] (.setStackTrace throwable edited-trace) throwable)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/fcase.clj000066400000000000000000000077121161102570000256700ustar00rootroot00000000000000;;; fcase.clj -- simple variants of "case" for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; April 7, 2008 ;; Copyright (c) Stuart Sierra, 2008. 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. ;; 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. ;; Note (December 23, 2008): This library has been supplanted by the ;; inclusion of "condp" in clojure.core as of Clojure SVN rev. 1180. (ns ^{:author "Stuart Sierra", :doc "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. Note (December 23, 2008): This library has been supplanted by the inclusion of \"condp\" in clojure.core as of Clojure SVN rev. 1180."} clojure.contrib.fcase (:refer-clojure :exclude (case))) (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)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/find_namespaces.clj000066400000000000000000000115751161102570000277300ustar00rootroot00000000000000;;; find_namespaces.clj: search for ns declarations in dirs, JARs, or CLASSPATH ;; by Stuart Sierra, http://stuartsierra.com/ ;; April 19, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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 ^{:author "Stuart Sierra", :doc "Search for ns declarations in dirs, JARs, or CLASSPATH"} clojure.contrib.find-namespaces (:require [clojure.contrib.classpath :as cp] [clojure.contrib.jar :as jar]) (import (java.io File FileReader BufferedReader PushbackReader InputStreamReader) (java.util.jar JarFile))) ;;; Finding namespaces in a directory tree (defn clojure-source-file? "Returns true if file is a normal file with a .clj extension." [^File file] (and (.isFile file) (.endsWith (.getName file) ".clj"))) (defn find-clojure-sources-in-dir "Searches recursively under dir for Clojure source files (.clj). Returns a sequence of File objects, in breadth-first sort order." [^File dir] ;; Use sort by absolute path to get breadth-first search. (sort-by #(.getAbsolutePath %) (filter clojure-source-file? (file-seq dir)))) (defn comment? "Returns true if form is a (comment ...)" [form] (and (list? form) (= 'comment (first form)))) (defn ns-decl? "Returns true if form is a (ns ...) declaration." [form] (and (list? form) (= 'ns (first form)))) (defn read-ns-decl "Attempts to read a (ns ...) declaration from rdr, and returns the unevaluated form. Returns nil if read fails or if a ns declaration cannot be found. The ns declaration must be the first Clojure form in the file, except for (comment ...) forms." [^PushbackReader rdr] (try (let [form (read rdr)] (cond (ns-decl? form) form (comment? form) (recur rdr) :else nil)) (catch Exception e nil))) (defn read-file-ns-decl "Attempts to read a (ns ...) declaration from file, and returns the unevaluated form. Returns nil if read fails, or if the first form is not a ns declaration." [^File file] (with-open [rdr (PushbackReader. (BufferedReader. (FileReader. file)))] (read-ns-decl rdr))) (defn find-ns-decls-in-dir "Searches dir recursively for (ns ...) declarations in Clojure source files; returns the unevaluated ns declarations." [^File dir] (filter identity (map read-file-ns-decl (find-clojure-sources-in-dir dir)))) (defn find-namespaces-in-dir "Searches dir recursively for (ns ...) declarations in Clojure source files; returns the symbol names of the declared namespaces." [^File dir] (map second (find-ns-decls-in-dir dir))) ;;; Finding namespaces in JAR files (defn clojure-sources-in-jar "Returns a sequence of filenames ending in .clj found in the JAR file." [^JarFile jar-file] (filter #(.endsWith % ".clj") (jar/filenames-in-jar jar-file))) (defn read-ns-decl-from-jarfile-entry "Attempts to read a (ns ...) declaration from the named entry in the JAR file, and returns the unevaluated form. Returns nil if the read fails, or if the first form is not a ns declaration." [^JarFile jarfile ^String entry-name] (with-open [rdr (PushbackReader. (BufferedReader. (InputStreamReader. (.getInputStream jarfile (.getEntry jarfile entry-name)))))] (read-ns-decl rdr))) (defn find-ns-decls-in-jarfile "Searches the JAR file for Clojure source files containing (ns ...) declarations; returns the unevaluated ns declarations." [^JarFile jarfile] (filter identity (map #(read-ns-decl-from-jarfile-entry jarfile %) (clojure-sources-in-jar jarfile)))) (defn find-namespaces-in-jarfile "Searches the JAR file for Clojure source files containing (ns ...) declarations. Returns a sequence of the symbol names of the declared namespaces." [^JarFile jarfile] (map second (find-ns-decls-in-jarfile jarfile))) ;;; Finding namespaces anywhere on CLASSPATH (defn find-ns-decls-on-classpath "Searches CLASSPATH (both directories and JAR files) for Clojure source files containing (ns ...) declarations. Returns a sequence of the unevaluated ns declaration forms." [] (concat (mapcat find-ns-decls-in-dir (cp/classpath-directories)) (mapcat find-ns-decls-in-jarfile (cp/classpath-jarfiles)))) (defn find-namespaces-on-classpath "Searches CLASSPATH (both directories and JAR files) for Clojure source files containing (ns ...) declarations. Returns a sequence of the symbol names of the declared namespaces." [] (map second (find-ns-decls-on-classpath))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/fnmap.clj000066400000000000000000000025731161102570000257100ustar00rootroot00000000000000;;; fnmap.clj: maps that dispatch get/assoc to functions ;; Copyright (c) Stuart Sierra, 2008. 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 ^{:author "Stuart Sierra" :doc "Maps that dispatch get/assoc to user-defined functions. Note: requires AOT-compilation"} clojure.contrib.fnmap (:require clojure.contrib.fnmap.PersistentFnMap)) (defn fnmap "Creates a fnmap, or functional map. A fnmap behaves like an ordinary Clojure map, except that calls to get and assoc are filtered through user-defined getter and setter functions, which operate on an internal map. (getter m key) should return a value for key. (setter m key value) should assoc key with value and return a new map for m. All other map operations are passed through to the internal map." ([getter setter] (clojure.contrib.fnmap.PersistentFnMap/create getter setter)) ([getter setter & keyvals] (apply assoc (clojure.contrib.fnmap.PersistentFnMap/create getter setter) keyvals))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/fnmap/000077500000000000000000000000001161102570000252075ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/fnmap/PersistentFnMap.clj000066400000000000000000000036751161102570000307760ustar00rootroot00000000000000;; PersistentFnMap.clj: implementation for clojure.contrib.fnmap ;; Copyright (c) Stuart Sierra, 2009. 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. ;; Thanks to Meikel Brandmeyer for his work on lazymap, which made ;; this implementation easier. (ns clojure.contrib.fnmap.PersistentFnMap (:gen-class :extends clojure.lang.APersistentMap :state state :init init :constructors {[clojure.lang.IPersistentMap] [], [clojure.lang.IPersistentMap clojure.lang.IPersistentMap] [clojure.lang.IPersistentMap]})) (defn -init ([theMap] [[] theMap]) ([theMap metadata] [[metadata] theMap])) (defn create [getter setter] (clojure.contrib.fnmap.PersistentFnMap. {::getter getter ::setter setter})) ;; IPersistentMap (defn -assoc [this key value] (clojure.contrib.fnmap.PersistentFnMap. ((::setter (. this state)) (. this state) key value))) ;; Associative (defn- -containsKey [this key] (not (nil? ((::getter (. this state)) this key)))) (defn- -entryAt [this key] (clojure.lang.MapEntry. key ((::getter (. this state)) (. this state) key))) (defn -valAt ([this key] ((::getter (. this state)) (. this state) key)) ([this key default] (or ((::getter (. this state)) (. this state) key) default))) ;; Iterable (defn -iterator [this] (.. this state iterator)) ;; IPersistentCollection (defn -count [this] (count (. this state))) (defn -seq [this] (seq (. this state))) (defn -cons [this that] (.. this state (cons this that))) (defn -empty [this] (.. this state empty)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/gen_html_docs.clj000066400000000000000000000350271161102570000274140ustar00rootroot00000000000000;;; gen-html-docs.clj: Generate HTML documentation for Clojure libs ;; by Craig Andera, http://pluralsight.com/craig, candera@wangdera.com ;; February 13th, 2009 ;; Copyright (c) Craig Andera, 2009. 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. ;; Generates a single HTML page that contains the documentation for ;; one or more Clojure libraries. See the comments section at the end ;; of this file for usage. ;; TODO ;; ;; * Make symbols in the source hyperlinks to the appropriate section ;; of the documentation. ;; * Investigate issue with miglayout mentioned here: ;; http://groups.google.com/group/clojure/browse_thread/thread/5a0c4395e44f5a79/3ae483100366bd3d?lnk=gst&q=documentation+browser#3ae483100366bd3d ;; ;; DONE ;; ;; * Move to clojure.contrib ;; * Change namespace ;; * Change license as appropriate ;; * Double-check doc strings ;; * Remove doc strings from source code ;; * Add collapse/expand functionality for all namespaces ;; * Add collapse/expand functionality for each namespace ;; * See if converting to use clojure.contrib.prxml is possible ;; * Figure out why the source doesn't show up for most things ;; * Add collapsible source ;; * Add links at the top to jump to each namespace ;; * Add object type (var, function, whatever) ;; * Add argument lists for functions ;; * Add links at the top of each namespace to jump to members ;; * Add license statement ;; * Remove the whojure dependency (ns ^{:author "Craig Andera", :doc "Generates a single HTML page that contains the documentation for one or more Clojure libraries."} clojure.contrib.gen-html-docs (:require [clojure.contrib.io :as io] [clojure.contrib.string :as s]) (:use [clojure.contrib repl-utils def prxml]) (:import [java.lang Exception] [java.util.regex Pattern])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Doc generation constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def *script* " // ") (def *style* " .library { padding: 0.5em 0 0 0 } .all-libs-toggle,.library-contents-toggle { font-size: small; } .all-libs-toggle a,.library-contents-toggle a { color: white } .library-member-doc-whitespace { white-space: pre } .library-member-source-toggle { font-size: small; margin-top: 0.5em } .library-member-source { display: none; border-left: solid lightblue } .library-member-docs { font-family:monospace } .library-member-arglists { font-family: monospace } .library-member-type { font-weight: bold; font-size: small; font-style: italic; color: darkred } .lib-links { margin: 0 0 1em 0 } .lib-link-header { color: white; background: darkgreen; width: 100% } .library-name { color: white; background: darkblue; width: 100% } .missing-library { color: darkred; margin: 0 0 1em 0 } .library-members { list-style: none } .library-member-name { font-weight: bold; font-size: 105% }") (defn- extract-documentation "Pulls the documentation for a var v out and turns it into HTML" [v] (if-let [docs (:doc (meta v))] (map (fn [l] [:div {:class "library-member-doc-line"} (if (= 0 (count l)) [:span {:class "library-member-doc-whitespace"} " "] ; We need something here to make the blank line show up l)]) (s/split #"\n" docs)) "")) (defn- member-type "Figures out for a var x whether it's a macro, function, var or multifunction" [x] (try (let [dx (deref x)] (cond (:macro (meta x)) :macro (fn? dx) :fn (= clojure.lang.MultiFn (:tag (meta x))) :multi true :var)) (catch Exception e :unknown))) (defn- anchor-for-member "Returns a suitable HTML anchor name given a library id and a member id" [libid memberid] (str "member-" libid "-" memberid)) (defn- id-for-member-source "Returns a suitable HTML id for a source listing given a library and a member" [libid memberid] (str "membersource-" libid "-" memberid)) (defn- id-for-member-source-link "Returns a suitable HTML id for a link to a source listing given a library and a member" [libid memberid] (str "linkto-membersource-" libid "-" memberid)) (defn- symbol-for "Given a namespace object ns and a namespaceless symbol memberid naming a member of that namespace, returns a namespaced symbol that identifies that member." [ns memberid] (symbol (name (ns-name ns)) (name memberid))) (defn- elide-to-one-line "Elides a string down to one line." [s] (s/replace-re #"(\n.*)+" "..." s)) (defn- elide-string "Returns a string that is at most the first limit characters of s" [s limit] (if (< (- limit 3) (count s)) (str (subs s 0 (- limit 3)) "...") s)) (defn- doc-elided-src "Returns the src with the docs elided." [docs src] (s/replace-re (re-pattern (str "\"" (Pattern/quote docs) "\"")) (str "\"" (elide-to-one-line docs) ;; (elide-string docs 10) ;; "..." "\"") src)) (defn- format-source [libid memberid v] (try (let [docs (:doc (meta v)) src (if-let [ns (find-ns libid)] (get-source (symbol-for ns memberid)))] (if (and src docs) (doc-elided-src docs src) src)) (catch Exception ex nil))) (defn- generate-lib-member [libid [n v]] [:li {:class "library-member"} [:a {:name (anchor-for-member libid n)}] [:dl {:class "library-member-table"} [:dt {:class "library-member-name"} (str n)] [:dd [:div {:class "library-member-info"} [:span {:class "library-member-type"} (name (member-type v))] " " [:span {:class "library-member-arglists"} (str (:arglists (meta v)))]] (into [:div {:class "library-member-docs"}] (extract-documentation v)) (let [member-source-id (id-for-member-source libid n) member-source-link-id (id-for-member-source-link libid n)] (if-let [member-source (format-source libid n v)] [:div {:class "library-member-source-section"} [:div {:class "library-member-source-toggle"} "[ " [:a {:href (format "javascript:toggleSource('%s')" member-source-id) :id member-source-link-id} "Show Source"] " ]"] [:div {:class "library-member-source" :id member-source-id} [:pre member-source]]]))]]]) (defn- anchor-for-library "Given a symbol id identifying a namespace, returns an identifier suitable for use as the name attribute of an HTML anchor tag." [id] (str "library-" id)) (defn- generate-lib-member-link "Emits a hyperlink to a member of a namespace given libid (a symbol identifying the namespace) and the vector [n v], where n is the symbol naming the member in question and v is the var pointing to the member." [libid [n v]] [:a {:class "lib-member-link" :href (str "#" (anchor-for-member libid n))} (name n)]) (defn- anchor-for-library-contents "Returns an HTML ID that identifies the element that holds the documentation contents for the specified library." [lib] (str "library-contents-" lib)) (defn- anchor-for-library-contents-toggle "Returns an HTML ID that identifies the element that toggles the visibility of the library contents." [lib] (str "library-contents-toggle-" lib)) (defn- generate-lib-doc "Emits the HTML that documents the namespace identified by the symbol lib." [lib] [:div {:class "library"} [:a {:name (anchor-for-library lib)}] [:div {:class "library-name"} [:span {:class "library-contents-toggle"} "[ " [:a {:id (anchor-for-library-contents-toggle lib) :href (format "javascript:toggle('%s', '%s', '-', '+')" (anchor-for-library-contents lib) (anchor-for-library-contents-toggle lib))} "-"] " ] "] (name lib)] (let [ns (find-ns lib)] (if ns (let [lib-members (sort (ns-publics ns))] [:a {:name (anchor-for-library lib)}] [:div {:class "library-contents" :id (anchor-for-library-contents lib)} (into [:div {:class "library-member-links"}] (interpose " " (map #(generate-lib-member-link lib %) lib-members))) (into [:ol {:class "library-members"}] (map #(generate-lib-member lib %) lib-members))]) [:div {:class "missing-library library-contents" :id (anchor-for-library-contents lib)} "Could not load library"]))]) (defn- load-lib "Calls require on the library identified by lib, eating any exceptions." [lib] (try (require lib) (catch java.lang.Exception x nil))) (defn- generate-lib-link "Generates a hyperlink to the documentation for a namespace given lib, a symbol identifying that namespace." [lib] (let [ns (find-ns lib)] (if ns [:a {:class "lib-link" :href (str "#" (anchor-for-library lib))} (str (ns-name ns))]))) (defn- generate-lib-links "Generates the list of hyperlinks to each namespace, given libs, a vector of symbols naming namespaces." [libs] (into [:div {:class "lib-links"} [:div {:class "lib-link-header"} "Namespaces" [:span {:class "all-libs-toggle"} " [ " [:a {:href "javascript:expandAllNamespaces()"} "Expand All"] " ] [ " [:a {:href "javascript:collapseAllNamespaces()"} "Collapse All"] " ]"]]] (interpose " " (map generate-lib-link libs)))) (defn generate-toggle-namespace-script [action toggle-text lib] (str (format "%s('%s');\n" action (anchor-for-library-contents lib)) (format "setLinkToggleText('%s', '%s');\n" (anchor-for-library-contents-toggle lib) toggle-text))) (defn generate-all-namespaces-action-script [action toggle-text libs] (str (format "function %sAllNamespaces()" action) \newline "{" \newline (reduce str (map #(generate-toggle-namespace-script action toggle-text %) libs)) \newline "}")) (defn generate-documentation "Returns a string which is the HTML documentation for the libraries named by libs. Libs is a vector of symbols identifying Clojure libraries." [libs] (dorun (map load-lib libs)) (let [writer (new java.io.StringWriter)] (binding [*out* writer] (prxml [:html {:xmlns "http://www.w3.org/1999/xhtml"} [:head [:title "Clojure documentation browser"] [:style *style*] [:script {:language "JavaScript" :type "text/javascript"} [:raw! *script*]] [:script {:language "JavaScript" :type "text/javascript"} [:raw! "// "]]] (let [lib-vec (sort libs)] (into [:body (generate-lib-links lib-vec)] (map generate-lib-doc lib-vec)))])) (.toString writer))) (defn generate-documentation-to-file "Calls generate-documentation on the libraries named by libs and emits the generated HTML to the path named by path." [path libs] (io/spit path (generate-documentation libs))) (comment (generate-documentation-to-file "C:/TEMP/CLJ-DOCS.HTML" ['clojure.contrib.accumulators]) (defn gen-all-docs [] (generate-documentation-to-file "C:/temp/clj-libs.html" [ 'clojure.set 'clojure.main 'clojure.core 'clojure.zip 'clojure.xml 'clojure.contrib.accumulators 'clojure.contrib.apply-macro 'clojure.contrib.auto-agent 'clojure.contrib.combinatorics 'clojure.contrib.command-line 'clojure.contrib.complex-numbers 'clojure.contrib.cond 'clojure.contrib.def 'clojure.contrib.io 'clojure.contrib.enum 'clojure.contrib.error-kit 'clojure.contrib.except 'clojure.contrib.fcase 'clojure.contrib.generic 'clojure.contrib.generic.arithmetic 'clojure.contrib.generic.collection 'clojure.contrib.generic.comparison 'clojure.contrib.generic.functor 'clojure.contrib.generic.math-functions 'clojure.contrib.import-static 'clojure.contrib.javadoc 'clojure.contrib.javalog 'clojure.contrib.lazy-seqs 'clojure.contrib.lazy-xml 'clojure.contrib.macro-utils 'clojure.contrib.macros 'clojure.contrib.math 'clojure.contrib.miglayout 'clojure.contrib.mmap 'clojure.contrib.monads 'clojure.contrib.ns-utils 'clojure.contrib.prxml 'clojure.contrib.repl-ln 'clojure.contrib.repl-utils 'clojure.contrib.seq 'clojure.contrib.server-socket 'clojure.contrib.shell 'clojure.contrib.sql 'clojure.contrib.stream-utils 'clojure.contrib.string 'clojure.contrib.test-contrib 'clojure.contrib.trace 'clojure.contrib.types 'clojure.contrib.zip-filter 'clojure.contrib.javadoc.browse 'clojure.contrib.json.read 'clojure.contrib.json.write 'clojure.contrib.lazy-xml.with-pull 'clojure.contrib.miglayout.internal 'clojure.contrib.probabilities.finite-distributions 'clojure.contrib.probabilities.monte-carlo 'clojure.contrib.probabilities.random-numbers 'clojure.contrib.sql.internal 'clojure.contrib.test-clojure.evaluation 'clojure.contrib.test-clojure.for 'clojure.contrib.test-clojure.numbers 'clojure.contrib.test-clojure.printer 'clojure.contrib.test-clojure.reader 'clojure.contrib.test-clojure.sequences 'clojure.contrib.test-contrib.shell 'clojure.contrib.test-contrib.string 'clojure.contrib.zip-filter.xml ])) ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic.clj000066400000000000000000000034561161102570000262240ustar00rootroot00000000000000;; Support code for generic interfaces ;; by Konrad Hinsen ;; last updated May 4, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :skip-wiki true :doc "Generic interfaces This library provides generic interfaces in the form of multimethods that can be implemented for any type. The interfaces partly duplicate existing non-generic functions in clojure.core (arithmetic, comparison, collections) and partly provide additional functions that can be defined for a wide variety of types (functors, math functions). More functions will be added in the future."} clojure.contrib.generic (:use [clojure.contrib.types :only (defadt)])) ; ; A dispatch function that separates nulary, unary, binary, and ; higher arity calls and also selects on type for unary and binary ; calls. ; (defn nary-dispatch ([] ::nulary) ([x] (type x)) ([x y] [(type x) (type y)]) ([x y & more] ::nary)) ; ; We can't use [::binary :default], so we need to define a root type ; of the type hierarcy. The derivation for Object covers all classes, ; but all non-class types will need an explicit derive clause. ; Ultimately, a macro might take care of this. ; (def root-type ::any) (derive Object root-type) ; ; Symbols referring to ::nulary and ::n-ary ; (def nulary-type ::nulary) (def nary-type ::nary) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic/000077500000000000000000000000001161102570000255225ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic/arithmetic.clj000066400000000000000000000123551161102570000303530ustar00rootroot00000000000000;; Generic interfaces for arithmetic operations ;; by Konrad Hinsen ;; last updated May 5, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Generic arithmetic interface This library defines generic versions of + - * / as multimethods that can be defined for any type. The minimal required implementations for a type are binary + and * plus unary - and /. Everything else is derived from these automatically. Explicit binary definitions for - and / can be provided for efficiency reasons."} clojure.contrib.generic.arithmetic (:use [clojure.contrib.generic :only (root-type nulary-type nary-type nary-dispatch)] [clojure.contrib.types :only (defadt)]) (:refer-clojure :exclude [+ - * /])) ; ; Universal zero and one values ; (defadt ::zero zero) (defadt ::one one) (derive ::zero root-type) (derive ::one root-type) ; ; Addition ; ; The minimal implementation is for binary my-type. It is possible ; in principle to implement [::unary my-type] as well, though this ; doesn't make any sense. ; (defmulti + "Return the sum of all arguments. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod + nulary-type [] zero) (defmethod + root-type [x] x) (defmethod + [root-type ::zero] [x y] x) (defmethod + [::zero root-type] [x y] y) (defmethod + nary-type [x y & more] (if more (recur (+ x y) (first more) (next more)) (+ x y))) ; ; Subtraction ; ; The minimal implementation is for unary my-type. A default binary ; implementation is provided as (+ x (- y)), but it is possible to ; implement unary my-type explicitly for efficiency reasons. ; (defmulti - "Return the difference of the first argument and the sum of all other arguments. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod - nulary-type [] (throw (java.lang.IllegalArgumentException. "Wrong number of arguments passed"))) (defmethod - [root-type ::zero] [x y] x) (defmethod - [::zero root-type] [x y] (- y)) (defmethod - [root-type root-type] [x y] (+ x (- y))) (defmethod - nary-type [x y & more] (if more (recur (- x y) (first more) (next more)) (- x y))) ; ; Multiplication ; ; The minimal implementation is for binary [my-type my-type]. It is possible ; in principle to implement unary my-type as well, though this ; doesn't make any sense. ; (defmulti * "Return the product of all arguments. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod * nulary-type [] one) (defmethod * root-type [x] x) (defmethod * [root-type ::one] [x y] x) (defmethod * [::one root-type] [x y] y) (defmethod * nary-type [x y & more] (if more (recur (* x y) (first more) (next more)) (* x y))) ; ; Division ; ; The minimal implementation is for unary my-type. A default binary ; implementation is provided as (* x (/ y)), but it is possible to ; implement binary [my-type my-type] explicitly for efficiency reasons. ; (defmulti / "Return the quotient of the first argument and the product of all other arguments. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod / nulary-type [] (throw (java.lang.IllegalArgumentException. "Wrong number of arguments passed"))) (defmethod / [root-type ::one] [x y] x) (defmethod / [::one root-type] [x y] (/ y)) (defmethod / [root-type root-type] [x y] (* x (/ y))) (defmethod / nary-type [x y & more] (if more (recur (/ x y) (first more) (next more)) (/ x y))) ; ; Macros to permit access to the / multimethod via namespace qualification ; (defmacro defmethod* "Define a method implementation for the multimethod name in namespace ns. Required for implementing the division function from another namespace." [ns name & args] (let [qsym (symbol (str ns) (str name))] `(defmethod ~qsym ~@args))) (defmacro qsym "Create the qualified symbol corresponding to sym in namespace ns. Required to access the division function from another namespace, e.g. as (qsym clojure.contrib.generic.arithmetic /)." [ns sym] (symbol (str ns) (str sym))) ; ; Minimal implementations for java.lang.Number ; (defmethod + [java.lang.Number java.lang.Number] [x y] (clojure.core/+ x y)) (defmethod - java.lang.Number [x] (clojure.core/- x)) (defmethod * [java.lang.Number java.lang.Number] [x y] (clojure.core/* x y)) (defmethod / java.lang.Number [x] (clojure.core// x)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic/collection.clj000066400000000000000000000055221161102570000303530ustar00rootroot00000000000000;; Generic interfaces for collection-related functions ;; by Konrad Hinsen ;; last updated May 5, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Generic arithmetic interface This library defines generic versions of common collection-related functions as multimethods that can be defined for any type."} clojure.contrib.generic.collection (:refer-clojure :exclude [assoc conj dissoc empty get into seq])) ; ; assoc ; (defmulti assoc "Returns a new collection in which the values corresponding to the given keys are updated by the given values. Each type of collection can have specific restrictions on the possible keys." {:arglists '([coll & key-val-pairs])} (fn [coll & items] (type coll))) (defmethod assoc :default [map & key-val-pairs] (apply clojure.core/assoc map key-val-pairs)) ; assoc-in ; ; conj ; (defmulti conj "Returns a new collection resulting from adding all xs to coll." {:arglists '([coll & xs])} (fn [coll & xs] (type coll))) (defmethod conj :default [coll & xs] (apply clojure.core/conj coll xs)) ; ; diassoc ; (defmulti dissoc "Returns a new collection in which the entries corresponding to the given keys are removed. Each type of collection can have specific restrictions on the possible keys." {:arglists '([coll & keys])} (fn [coll & keys] (type coll))) (defmethod dissoc :default [map & keys] (apply clojure.core/dissoc map keys)) ; ; empty ; (defmulti empty "Returns an empty collection of the same kind as the argument" {:arglists '([coll])} type) (defmethod empty :default [coll] (clojure.core/empty coll)) ; ; get ; (defmulti get "Returns the element of coll referred to by key. Each type of collection can have specific restrictions on the possible keys." {:arglists '([coll key] [coll key not-found])} (fn [coll & args] (type coll))) (defmethod get :default ([coll key] (clojure.core/get coll key)) ([coll key not-found] (clojure.core/get coll key not-found))) ; ; into ; (defmulti into "Returns a new coll consisting of to-coll with all of the items of from-coll conjoined." {:arglists '([to from])} (fn [to from] (type to))) (declare seq) (defmethod into :default [to from] (reduce conj to (seq from))) ; ; seq ; (defmulti seq "Returns a seq on the object s." {:arglists '([s])} type) (defmethod seq :default [s] (clojure.core/seq s)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic/comparison.clj000066400000000000000000000122011161102570000303620ustar00rootroot00000000000000;; Generic interfaces for comparison operations ;; by Konrad Hinsen ;; last updated May 25, 2010 ;; Copyright (c) Konrad Hinsen, 2009-2010. 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 ^{:author "Konrad Hinsen" :doc "Generic comparison interface This library defines generic versions of = < > <= >= zero? as multimethods that can be defined for any type. Of the greater/less-than relations, types must minimally implement >."} clojure.contrib.generic.comparison (:refer-clojure :exclude [= < > <= >= zero? pos? neg? min max]) (:use [clojure.contrib.generic :only (root-type nulary-type nary-type nary-dispatch)])) ; ; zero? pos? neg? ; (defmulti zero? "Return true of x is zero." {:arglists '([x])} type) (defmulti pos? "Return true of x is positive." {:arglists '([x])} type) (defmulti neg? "Return true of x is negative." {:arglists '([x])} type) ; ; Equality ; (defmulti = "Return true if all arguments are equal. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod = root-type [x] true) (defmethod = nary-type [x y & more] (if (= x y) (if (next more) (recur y (first more) (next more)) (= y (first more))) false)) ; ; Greater-than ; (defmulti > "Return true if each argument is larger than the following ones. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod > root-type [x] true) (defmethod > nary-type [x y & more] (if (> x y) (if (next more) (recur y (first more) (next more)) (> y (first more))) false)) ; ; Less-than defaults to greater-than with arguments inversed ; (defmulti < "Return true if each argument is smaller than the following ones. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]. A default implementation is provided in terms of >." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod < root-type [x] true) (defmethod < [root-type root-type] [x y] (> y x)) (defmethod < nary-type [x y & more] (if (< x y) (if (next more) (recur y (first more) (next more)) (< y (first more))) false)) ; ; Greater-or-equal defaults to (complement <) ; (defmulti >= "Return true if each argument is larger than or equal to the following ones. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]. A default implementation is provided in terms of <." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod >= root-type [x] true) (defmethod >= [root-type root-type] [x y] (not (< x y))) (defmethod >= nary-type [x y & more] (if (>= x y) (if (next more) (recur y (first more) (next more)) (>= y (first more))) false)) ; ; Less-than defaults to (complement >) ; (defmulti <= "Return true if each arguments is smaller than or equal to the following ones. The minimal implementation for type ::my-type is the binary form with dispatch value [::my-type ::my-type]. A default implementation is provided in terms of >." {:arglists '([x] [x y] [x y & more])} nary-dispatch) (defmethod <= root-type [x] true) (defmethod <= [root-type root-type] [x y] (not (> x y))) (defmethod <= nary-type [x y & more] (if (<= x y) (if (next more) (recur y (first more) (next more)) (<= y (first more))) false)) ; ; Implementations for Clojure's built-in types ; (defmethod zero? java.lang.Number [x] (clojure.core/zero? x)) (defmethod pos? java.lang.Number [x] (clojure.core/pos? x)) (defmethod neg? java.lang.Number [x] (clojure.core/neg? x)) (defmethod = [Object Object] [x y] (clojure.core/= x y)) (defmethod > [java.lang.Number java.lang.Number] [x y] (clojure.core/> x y)) (defmethod < [java.lang.Number java.lang.Number] [x y] (clojure.core/< x y)) (defmethod >= [java.lang.Number java.lang.Number] [x y] (clojure.core/>= x y)) (defmethod <= [java.lang.Number java.lang.Number] [x y] (clojure.core/<= x y)) ; ; Functions defined in terms of the comparison operators ; (defn max "Returns the greatest of its arguments. Like clojure.core/max except that is uses generic comparison functions implementable for any data type." ([x] x) ([x y] (if (> x y) x y)) ([x y & more] (reduce max (max x y) more))) (defn min "Returns the least of its arguments. Like clojure.core/min except that is uses generic comparison functions implementable for any data type." ([x] x) ([x y] (if (< x y) x y)) ([x y & more] (reduce min (min x y) more))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic/functor.clj000066400000000000000000000022431161102570000276750ustar00rootroot00000000000000;; Generic interface for functors ;; by Konrad Hinsen ;; last updated May 3, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Generic functor interface (fmap)"} clojure.contrib.generic.functor) (defmulti fmap "Applies function f to each item in the data structure s and returns a structure of the same kind." {:arglists '([f s])} (fn [f s] (type s))) (defmethod fmap clojure.lang.IPersistentList [f v] (into (empty v) (map f v))) (defmethod fmap clojure.lang.IPersistentVector [f v] (into (empty v) (map f v))) (defmethod fmap clojure.lang.IPersistentMap [f m] (into (empty m) (for [[k v] m] [k (f v)]))) (defmethod fmap clojure.lang.IPersistentSet [f s] (into (empty s) (map f s))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/generic/math_functions.clj000066400000000000000000000051771161102570000312470ustar00rootroot00000000000000;; Generic interfaces for mathematical functions ;; by Konrad Hinsen ;; last updated May 5, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Generic math function interface This library defines generic versions of common mathematical functions such as sqrt or sin as multimethods that can be defined for any type."} clojure.contrib.generic.math-functions (:use [clojure.contrib.def :only (defmacro-)]) (:require [clojure.contrib.generic.arithmetic :as ga] [clojure.contrib.generic.comparison :as gc])) (defmacro- defmathfn-1 [name] (let [java-symbol (symbol "java.lang.Math" (str name))] `(do (defmulti ~name ~(str "Return the " name " of x.") {:arglists '([~'x])} type) (defmethod ~name java.lang.Number [~'x] (~java-symbol ~'x))))) (defn- two-types [x y] [(type x) (type y)]) (defmacro- defmathfn-2 [name] (let [java-symbol (symbol "java.lang.Math" (str name))] `(do (defmulti ~name ~(str "Return the " name " of x and y.") {:arglists '([~'x ~'y])} two-types) (defmethod ~name [java.lang.Number java.lang.Number] [~'x ~'y] (~java-symbol ~'x ~'y))))) ; List of math functions taken from ; http://java.sun.com/j2se/1.4.2/docs/api/java/lang/Math.html (defmathfn-1 abs) (defmathfn-1 acos) (defmathfn-1 asin) (defmathfn-1 atan) (defmathfn-2 atan2) (defmathfn-1 ceil) (defmathfn-1 cos) (defmathfn-1 exp) (defmathfn-1 floor) (defmathfn-1 log) (defmathfn-2 pow) (defmathfn-1 rint) (defmathfn-1 round) (defmathfn-1 sin) (defmathfn-1 sqrt) (defmathfn-1 tan) ; ; Sign ; (defmulti sgn "Return the sign of x (-1, 0, or 1)." {:arglists '([x])} type) (defmethod sgn :default [x] (cond (gc/zero? x) 0 (gc/> x 0) 1 :else -1)) ; ; Conjugation ; (defmulti conjugate "Return the conjugate of x." {:arglists '([x])} type) (defmethod conjugate :default [x] x) ; ; Square ; (defmulti sqr "Return the square of x." {:arglists '([x])} type) (defmethod sqr :default [x] (ga/* x x)) ; ; Approximate equality for use with floating point types ; (defn approx= "Return true if the absolute value of the difference between x and y is less than eps." [x y eps] (gc/< (abs (ga/- x y)) eps)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/graph.clj000066400000000000000000000176071161102570000257140ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; graph ;; ;; Basic Graph Theory Algorithms ;; ;; straszheimjeffrey (gmail) ;; Created 23 June 2009 (ns ^{:author "Jeffrey Straszheim", :doc "Basic graph theory algorithms"} clojure.contrib.graph (use [clojure.set :only (union)])) (defstruct directed-graph :nodes ; The nodes of the graph, a collection :neighbors) ; A function that, given a node returns a collection ; neighbor nodes. (defn get-neighbors "Get the neighbors of a node." [g n] ((:neighbors g) n)) ;; Graph Modification (defn reverse-graph "Given a directed graph, return another directed graph with the order of the edges reversed." [g] (let [op (fn [rna idx] (let [ns (get-neighbors g idx) am (fn [m val] (assoc m val (conj (get m val #{}) idx)))] (reduce am rna ns))) rn (reduce op {} (:nodes g))] (struct directed-graph (:nodes g) rn))) (defn add-loops "For each node n, add the edge n->n if not already present." [g] (struct directed-graph (:nodes g) (into {} (map (fn [n] [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) (defn remove-loops "For each node n, remove any edges n->n." [g] (struct directed-graph (:nodes g) (into {} (map (fn [n] [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) ;; Graph Walk (defn lazy-walk "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, provide a set of visited notes (v) and a collection of nodes to visit (ns)." ([g n] (lazy-walk g [n] #{})) ([g ns v] (lazy-seq (let [s (seq (drop-while v ns)) n (first s) ns (rest s)] (when s (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) (defn transitive-closure "Returns the transitive closure of a graph. The neighbors are lazily computed. Note: some version of this algorithm return all edges a->a regardless of whether such loops exist in the original graph. This version does not. Loops will be included only if produced by cycles in the graph. If you have code that depends on such behavior, call (-> g transitive-closure add-loops)" [g] (let [nns (fn [n] [n (delay (lazy-walk g (get-neighbors g n) #{}))]) nbs (into {} (map nns (:nodes g)))] (struct directed-graph (:nodes g) (fn [n] (force (nbs n)))))) ;; Strongly Connected Components (defn- post-ordered-visit "Starting at node n, perform a post-ordered walk." [g n [visited acc :as state]] (if (visited n) state (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) [(conj visited n) acc] (get-neighbors g n))] [v2 (conj acc2 n)]))) (defn post-ordered-nodes "Return a sequence of indexes of a post-ordered walk of the graph." [g] (fnext (reduce #(post-ordered-visit g %2 %1) [#{} []] (:nodes g)))) (defn scc "Returns, as a sequence of sets, the strongly connected components of g." [g] (let [po (reverse (post-ordered-nodes g)) rev (reverse-graph g) step (fn [stack visited acc] (if (empty? stack) acc (let [[nv comp] (post-ordered-visit rev (first stack) [visited #{}]) ns (remove nv stack)] (recur ns nv (conj acc comp)))))] (step po #{} []))) (defn component-graph "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. Each node in the new graph will be a set of nodes from the old. These sets are the strongly connected components. Each edge will be the union of the corresponding edges of the prior graph." ([g] (component-graph g (scc g))) ([g sccs] (let [find-node-set (fn [n] (some #(if (% n) % nil) sccs)) find-neighbors (fn [ns] (let [nbs1 (map (partial get-neighbors g) ns) nbs2 (map set nbs1) nbs3 (apply union nbs2)] (set (map find-node-set nbs3)))) nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] (struct directed-graph (set sccs) nm)))) (defn recursive-component? "Is the component (recieved from scc) self recursive?" [g ns] (or (> (count ns) 1) (let [n (first ns)] (some #(= % n) (get-neighbors g n))))) (defn self-recursive-sets "Returns, as a sequence of sets, the components of a graph that are self-recursive." [g] (filter (partial recursive-component? g) (scc g))) ;; Dependency Lists (defn fixed-point "Repeatedly apply fun to data until (equal old-data new-data) returns true. If max iterations occur, it will throw an exception. Set max to nil for unlimited iterations." [data fun max equal] (let [step (fn step [data idx] (when (and idx (= 0 idx)) (throw (Exception. "Fixed point overflow"))) (let [new-data (fun data)] (if (equal data new-data) new-data (recur new-data (and idx (dec idx))))))] (step data max))) (defn- fold-into-sets [priorities] (let [max (inc (apply max 0 (vals priorities))) step (fn [acc [n dep]] (assoc acc dep (conj (acc dep) n)))] (reduce step (vec (replicate max #{})) priorities))) (defn dependency-list "Similar to a topological sort, this returns a vector of sets. The set of nodes at index 0 are independent. The set at index 1 depend on index 0; those at 2 depend on 0 and 1, and so on. Those withing a set have no mutual dependencies. Assume the input graph (which much be acyclic) has an edge a->b when a depends on b." [g] (let [step (fn [d] (let [update (fn [n] (inc (apply max -1 (map d (get-neighbors g n)))))] (into {} (map (fn [[k v]] [k (update k)]) d)))) counts (fixed-point (zipmap (:nodes g) (repeat 0)) step (inc (count (:nodes g))) =)] (fold-into-sets counts))) (defn stratification-list "Similar to dependency-list (see doc), except two graphs are provided. The first is as dependency-list. The second (which may have cycles) provides a partial-dependency relation. If node a depends on node b (meaning an edge a->b exists) in the second graph, node a must be equal or later in the sequence." [g1 g2] (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) (let [step (fn [d] (let [update (fn [n] (max (inc (apply max -1 (map d (get-neighbors g1 n)))) (apply max -1 (map d (get-neighbors g2 n)))))] (into {} (map (fn [[k v]] [k (update k)]) d)))) counts (fixed-point (zipmap (:nodes g1) (repeat 0)) step (inc (count (:nodes g1))) =)] (fold-into-sets counts))) ;; End of file clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/greatest_least.clj000066400000000000000000000031001161102570000276000ustar00rootroot00000000000000(ns ^{:author "Vincent Foley", :doc "Various functions for finding greatest and least values in a collection"} clojure.contrib.greatest-least) (defn- boundary [cmp-fn f & args] (when args (reduce (fn [a b] (if (cmp-fn (compare (f b) (f a))) b a)) args))) (defn greatest-by "Return the argument for which f yields the greatest value." [f & args] (apply boundary pos? f args)) (defn greatest "Return the greatest argument." [& args] (apply greatest-by identity args)) (defn least-by "Return the argument for which f yields the smallest value." [f & args] (apply boundary neg? f args)) (defn least "Return the smallest element." [& args] (apply least-by identity args)) (defn- boundary-all [cmp-fn f & args] (when args (reduce (fn [a b] (if (nil? a) (cons b nil) (let [x (compare (f b) (f (first a)))] (cond (zero? x) (cons b a) (cmp-fn x) (cons b nil) :else a)))) nil args))) (defn all-greatest-by "Return all the elements for which f yields the greatest value." [f & args] (apply boundary-all pos? f args)) (defn all-greatest "Returns all the greatest elements." [& args] (apply all-greatest-by identity args)) (defn all-least-by "Return all the elements for which f yields the least value." [f & args] (apply boundary-all neg? f args)) (defn all-least "Returns all the least elements." [& args] (apply all-least-by identity args)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/http/000077500000000000000000000000001161102570000250655ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/http/agent.clj000066400000000000000000000307531161102570000266650ustar00rootroot00000000000000;;; http/agent.clj: agent-based asynchronous HTTP client ;; by Stuart Sierra, http://stuartsierra.com/ ;; August 17, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; DEPRECATED IN 1.2. Use direct Java bits, or take a look at ;; http://github.com/technomancy/clojure-http-client (ns ^{:deprecated "1.2" :doc "Agent-based asynchronous HTTP client. This is a HTTP client library based on Java's HttpURLConnection class and Clojure's Agent system. It allows you to make multiple HTTP requests in parallel. Start an HTTP request with the 'http-agent' function, which immediately returns a Clojure Agent. You will never deref this agent; that is handled by the accessor functions. The agent will execute the HTTP request on a separate thread. If you pass a :handler function to http-agent, that function will be called as soon as the HTTP response body is ready. The handler function is called with one argument, the HTTP agent itself. The handler can read the response body by calling the 'stream' function on the agent. The value returned by the handler function becomes part of the state of the agent, and you can retrieve it with the 'result' function. If you call 'result' before the HTTP request has finished, it will block until the handler function returns. If you don't provide a handler function, the default handler will buffer the entire response body in memory, which you can retrieve with the 'bytes', 'string', or 'stream' functions. Like 'result', these functions will block until the HTTP request is completed. If you want to check if an HTTP request is finished without blocking, use the 'done?' function. A single GET request could be as simple as: (string (http-agent \"http://www.stuartsierra.com/\")) A simple POST might look like: (http-agent \"http...\" :method \"POST\" :body \"foo=1\") And you could write the response directly to a file like this: (require '[clojure.contrib.io :as d]) (http-agent \"http...\" :handler (fn [agnt] (with-open [w (d/writer \"/tmp/out\")] (d/copy (stream agnt) w)))) " :author "Stuart Sierra" } clojure.contrib.http.agent (:refer-clojure :exclude [bytes]) (:require [clojure.contrib.http.connection :as c] [clojure.contrib.io :as duck]) (:import (java.io InputStream ByteArrayOutputStream ByteArrayInputStream) (java.net HttpURLConnection))) ;;; PRIVATE (declare result stream) (defn- setup-http-connection "Sets the instance method, redirect behavior, and request headers of the HttpURLConnection." [^HttpURLConnection conn options] (when-let [t (:connect-timeout options)] (.setConnectTimeout conn t)) (when-let [t (:read-timeout options)] (.setReadTimeout conn t)) (.setRequestMethod conn (:method options)) (.setInstanceFollowRedirects conn (:follow-redirects options)) (doseq [[name value] (:headers options)] (.setRequestProperty conn name value))) (defn- start-request "Agent action that starts sending the HTTP request." [state options] (let [conn (::connection state)] (setup-http-connection conn options) (c/start-http-connection conn (:body options)) (assoc state ::state ::started))) (defn- connection-success? [^HttpURLConnection conn] "Returns true if the HttpURLConnection response code is in the 2xx range." (= 2 (quot (.getResponseCode conn) 100))) (defn- open-response "Agent action that opens the response body stream on the HTTP request; this will block until the response stream is available." ; [state options] (let [^HttpURLConnection conn (::connection state)] (assoc state ::response-stream (if (connection-success? conn) (.getInputStream conn) (.getErrorStream conn)) ::state ::receiving))) (defn- handle-response "Agent action that calls the provided handler function, with no arguments, and sets the ::result key of the agent to the handler's return value." [state handler options] (let [conn (::connection state)] (assoc state ::result (handler) ::state ::finished))) (defn- disconnect "Agent action that closes the response body stream and disconnects the HttpURLConnection." [state options] (when (::response-stream state) (.close ^InputStream (::response-stream state))) (.disconnect ^HttpURLConnection (::connection state)) (assoc state ::response-stream nil ::state ::disconnected)) (defn- status-in-range? "Returns true if the response status of the HTTP agent begins with digit, an Integer." [digit http-agnt] (= digit (quot (.getResponseCode ^HttpURLConnection (::connection @http-agnt)) 100))) (defn- ^ByteArrayOutputStream get-byte-buffer [http-agnt] (let [buffer (result http-agnt)] (if (instance? ByteArrayOutputStream buffer) buffer (throw (Exception. "Handler result was not a ByteArrayOutputStream"))))) (defn buffer-bytes "The default HTTP agent result handler; it collects the response body in a java.io.ByteArrayOutputStream, which can later be retrieved with the 'stream', 'string', and 'bytes' functions." [http-agnt] (let [output (ByteArrayOutputStream.)] (duck/copy (or (stream http-agnt) "") output) output)) ;;; CONSTRUCTOR (def *http-agent-defaults* {:method "GET" :headers {} :body nil :connect-timeout 0 :read-timeout 0 :follow-redirects true :handler buffer-bytes}) (defn http-agent "Creates (and immediately returns) an Agent representing an HTTP request running in a new thread. options are key/value pairs: :method string The HTTP method name. Default is \"GET\". :headers h HTTP headers, as a Map or a sequence of pairs like ([key1,value1], [key2,value2]) Default is nil. :body b HTTP request entity body, one of nil, String, byte[], InputStream, Reader, or File. Default is nil. :connect-timeout int Timeout value, in milliseconds, when opening a connection to the URL. Default is zero, meaning no timeout. :read-timeout int Timeout value, in milliseconds, when reading data from the connection. Default is zero, meaning no timeout. :follow-redirects boolean If true, HTTP 3xx redirects will be followed automatically. Default is true. :handler f Function to be called when the HTTP response body is ready. If you do not provide a handler function, the default is to buffer the entire response body in memory. The handler function will be called with the HTTP agent as its argument, and can use the 'stream' function to read the response body. The return value of this function will be stored in the state of the agent and can be retrieved with the 'result' function. Any exceptions thrown by this function will be added to the agent's error queue (see agent-errors). The default function collects the response stream in a memory buffer. " ([uri & options] (let [opts (merge *http-agent-defaults* (apply array-map options))] (let [a (agent {::connection (c/http-connection uri) ::state ::created ::uri uri ::options opts})] (send-off a start-request opts) (send-off a open-response opts) (send-off a handle-response (partial (:handler opts) a) opts) (send-off a disconnect opts))))) ;;; RESPONSE BODY ACCESSORS (defn result "Returns the value returned by the :handler function of the HTTP agent; blocks until the HTTP request is completed. The default handler function returns a ByteArrayOutputStream." [http-agnt] (await http-agnt) (::result @http-agnt)) (defn stream "Returns an InputStream of the HTTP response body. When called by the handler function passed to http-agent, this is the raw HttpURLConnection stream. If the default handler function was used, this function returns a ByteArrayInputStream on the buffered response body." [http-agnt] (let [a @http-agnt] (if (= (::state a) ::receiving) (::response-stream a) (ByteArrayInputStream. (.toByteArray (get-byte-buffer http-agnt)))))) (defn bytes "Returns a Java byte array of the content returned by the server; nil if the content is not yet available." [http-agnt] (.toByteArray (get-byte-buffer http-agnt))) (defn string "Returns the HTTP response body as a string, using the given encoding. If no encoding is given, uses the encoding specified in the server headers, or clojure.contrib.io/*default-encoding* if it is not specified." ([http-agnt] (await http-agnt) ;; have to wait for Content-Encoding (string http-agnt (or (.getContentEncoding ^HttpURLConnection (::connection @http-agnt)) duck/*default-encoding*))) ([http-agnt ^String encoding] (.toString (get-byte-buffer http-agnt) encoding))) ;;; REQUEST ACCESSORS (defn request-uri "Returns the URI/URL requested by this HTTP agent, as a String." [http-agnt] (::uri @http-agnt)) (defn request-headers "Returns the request headers specified for this HTTP agent." [http-agnt] (:headers (::options @http-agnt))) (defn method "Returns the HTTP method name used by this HTTP agent, as a String." [http-agnt] (:method (::options @http-agnt))) (defn request-body "Returns the HTTP request body given to this HTTP agent. Note: if the request body was an InputStream or a Reader, it will no longer be usable." [http-agnt] (:body (::options @http-agnt))) ;;; RESPONSE ACCESSORS (defn done? "Returns true if the HTTP request/response has completed." [http-agnt] (if (#{::finished ::disconnected} (::state @http-agnt)) true false)) (defn status "Returns the HTTP response status code (e.g. 200, 404) for this request, as an Integer, or nil if the status has not yet been received." [http-agnt] (when (done? http-agnt) (.getResponseCode ^HttpURLConnection (::connection @http-agnt)))) (defn message "Returns the HTTP response message (e.g. 'Not Found'), for this request, or nil if the response has not yet been received." [http-agnt] (when (done? http-agnt) (.getResponseMessage ^HttpURLConnection (::connection @http-agnt)))) (defn headers "Returns a map of HTTP response headers. Header names are converted to keywords in all lower-case Header values are strings. If a header appears more than once, only the last value is returned." [http-agnt] (reduce (fn [m [^String k v]] (assoc m (when k (keyword (.toLowerCase k))) (last v))) {} (.getHeaderFields ^HttpURLConnection (::connection @http-agnt)))) (defn headers-seq "Returns the HTTP response headers in order as a sequence of [String,String] pairs. The first 'header' name may be null for the HTTP status line." [http-agnt] (let [^HttpURLConnection conn (::connection @http-agnt) f (fn thisfn [^Integer i] ;; Get value first because first key may be nil. (when-let [value (.getHeaderField conn i)] (cons [(.getHeaderFieldKey conn i) value] (thisfn (inc i)))))] (lazy-seq (f 0)))) ;;; RESPONSE STATUS CODE ACCESSORS (defn success? "Returns true if the HTTP response code was in the 200-299 range." [http-agnt] (status-in-range? 2 http-agnt)) (defn redirect? "Returns true if the HTTP response code was in the 300-399 range. Note: if the :follow-redirects option was true (the default), redirects will be followed automatically and a the agent will never return a 3xx response code." [http-agnt] (status-in-range? 3 http-agnt)) (defn client-error? "Returns true if the HTTP response code was in the 400-499 range." [http-agnt] (status-in-range? 4 http-agnt)) (defn server-error? "Returns true if the HTTP response code was in the 500-599 range." [http-agnt] (status-in-range? 5 http-agnt)) (defn error? "Returns true if the HTTP response code was in the 400-499 range OR the 500-599 range." [http-agnt] (or (client-error? http-agnt) (server-error? http-agnt))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/http/connection.clj000066400000000000000000000045471161102570000277300ustar00rootroot00000000000000;;; http/connection.clj: low-level HTTP client API around HttpURLConnection ;; by Stuart Sierra, http://stuartsierra.com/ ;; June 8, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; DEPRECATED IN 1.2. Use direct Java bits, or take a look at ;; http://github.com/technomancy/clojure-http-client (ns ^{:deprecated "1.2" :doc "Low-level HTTP client API around HttpURLConnection"} clojure.contrib.http.connection (:require [clojure.contrib.io :as duck]) (:import (java.net URI URL HttpURLConnection) (java.io File InputStream Reader))) (defn http-connection "Opens an HttpURLConnection at the URL, handled by as-url." [url] (.openConnection (duck/as-url url))) (defmulti ^{:doc "Transmits a request entity body."} send-request-entity (fn [conn entity] (type entity))) (defmethod send-request-entity duck/*byte-array-type* [^HttpURLConnection conn entity] (.setFixedLengthStreamingMode conn (count entity)) (.connect conn) (duck/copy entity (.getOutputStream conn))) (defmethod send-request-entity String [conn ^String entity] (send-request-entity conn (.getBytes entity duck/*default-encoding*))) (defmethod send-request-entity File [^HttpURLConnection conn ^File entity] (.setFixedLengthStreamingMode conn (.length entity)) (.connect conn) (duck/copy entity (.getOutputStream conn))) (defmethod send-request-entity InputStream [^HttpURLConnection conn entity] (.setChunkedStreamingMode conn -1) (.connect conn) (duck/copy entity (.getOutputStream conn))) (defmethod send-request-entity Reader [^HttpURLConnection conn entity] (.setChunkedStreamingMode conn -1) (.connect conn) (duck/copy entity (.getOutputStream conn))) (defn start-http-connection ([^HttpURLConnection conn] (.connect conn)) ([^HttpURLConnection conn request-entity-body] (if request-entity-body (do (.setDoOutput conn true) (send-request-entity conn request-entity-body)) (.connect conn)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/import_static.clj000066400000000000000000000047451161102570000274730ustar00rootroot00000000000000;;; import_static.clj -- import static Java methods/fields into Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; June 1, 2008 ;; Copyright (c) Stuart Sierra, 2008. 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 ^{:author "Stuart Sierra", :doc "Import static Java methods/fields into Clojure"} clojure.contrib.import-static (:use clojure.set)) (defmacro import-static "Imports the named static fields and/or static methods of the class as (private) symbols in the current namespace. Example: user=> (import-static java.lang.Math PI sqrt) nil user=> PI 3.141592653589793 user=> (sqrt 16) 4.0 Note: The class name must be fully qualified, even if it has already been imported. Static methods are defined as MACROS, not first-class fns." [class & fields-and-methods] (let [only (set (map str fields-and-methods)) the-class (. Class forName (str class)) static? (fn [x] (. java.lang.reflect.Modifier (isStatic (. x (getModifiers))))) statics (fn [array] (set (map (memfn getName) (filter static? array)))) all-fields (statics (. the-class (getFields))) all-methods (statics (. the-class (getMethods))) fields-to-do (intersection all-fields only) methods-to-do (intersection all-methods only) make-sym (fn [string] (with-meta (symbol string) {:private true})) import-field (fn [name] (list 'def (make-sym name) (list '. class (symbol name)))) import-method (fn [name] (list 'defmacro (make-sym name) '[& args] (list 'list ''. (list 'quote class) (list 'apply 'list (list 'quote (symbol name)) 'args))))] `(do ~@(map import-field fields-to-do) ~@(map import-method methods-to-do)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/io.clj000066400000000000000000000453501161102570000252160ustar00rootroot00000000000000;;; io.clj -- duck-typed I/O streams for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; May 13, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; This file defines "duck-typed" I/O utility functions for Clojure. ;; The 'reader' and 'writer' functions will open and return an ;; instance of java.io.BufferedReader and java.io.BufferedWriter, ;; respectively, for a variety of argument types -- filenames as ;; strings, URLs, java.io.File's, etc. 'reader' even works on http ;; URLs. ;; ;; Note: this is not really "duck typing" as implemented in languages ;; like Ruby. A better name would have been "do-what-I-mean-streams" ;; or "just-give-me-a-stream", but ducks are funnier. ;; CHANGE LOG ;; ;; July 23, 2010: Most functions here are deprecated. Use ;; clojure.java.io ;; ;; May 13, 2009: added functions to open writers for appending ;; ;; May 3, 2009: renamed file to file-str, for compatibility with ;; clojure.contrib.java. reader/writer no longer use this ;; function. ;; ;; February 16, 2009: (lazy branch) fixed read-lines to work with lazy ;; Clojure. ;; ;; January 10, 2009: added *default-encoding*, so streams are always ;; opened as UTF-8. ;; ;; December 19, 2008: rewrote reader and writer as multimethods; added ;; slurp*, file, and read-lines ;; ;; April 8, 2008: first version (ns ^{:author "Stuart Sierra", :doc "This file defines polymorphic I/O utility functions for Clojure. The Streams protocol defines reader, writer, input-stream and output-stream methods that return BufferedReader, BufferedWriter, BufferedInputStream and BufferedOutputStream instances (respectively), with default implementations extended to a variety of argument types: URLs or filenames as strings, java.io.File's, Sockets, etc."} clojure.contrib.io (:refer-clojure :exclude (spit)) (:import (java.io Reader InputStream InputStreamReader PushbackReader BufferedReader File OutputStream OutputStreamWriter BufferedWriter Writer FileInputStream FileOutputStream ByteArrayOutputStream StringReader ByteArrayInputStream BufferedInputStream BufferedOutputStream CharArrayReader) (java.net URI URL MalformedURLException Socket))) (def ^{:doc "Name of the default encoding to use when reading & writing. Default is UTF-8." :tag "java.lang.String"} *default-encoding* "UTF-8") (def ^{:doc "Size, in bytes or characters, of the buffer used when copying streams."} *buffer-size* 1024) (def ^{:doc "Type object for a Java primitive byte array."} *byte-array-type* (class (make-array Byte/TYPE 0))) (def ^{:doc "Type object for a Java primitive char array."} *char-array-type* (class (make-array Character/TYPE 0))) (defn ^File file-str "Concatenates args as strings and returns a java.io.File. Replaces all / and \\ with File/separatorChar. Replaces ~ at the start of the path with the user.home system property." [& args] (let [^String s (apply str args) s (.replace s \\ File/separatorChar) s (.replace s \/ File/separatorChar) s (if (.startsWith s "~") (str (System/getProperty "user.home") File/separator (subs s 1)) s)] (File. s))) (def ^{:doc "If true, writer, output-stream and spit will open files in append mode. Defaults to false. Instead of binding this var directly, use append-writer, append-output-stream or append-spit." :tag "java.lang.Boolean"} *append* false) (defn- assert-not-appending [] (when *append* (throw (Exception. "Cannot change an open stream to append mode.")))) ;; @todo -- Both simple and elaborate methods for controlling buffering of ;; in the Streams protocol were implemented, considered, and postponed ;; see http://groups.google.com/group/clojure-dev/browse_frm/thread/3e39e9b3982f542b (defprotocol Streams (reader [x] "Attempts to coerce its argument into an open java.io.Reader. The default implementations of this protocol always return a java.io.BufferedReader. Default implementations are provided for Reader, BufferedReader, InputStream, File, URI, URL, Socket, byte arrays, character arrays, and String. If argument is a String, it tries to resolve it first as a URI, then as a local file name. URIs with a 'file' protocol are converted to local file names. If this fails, a final attempt is made to resolve the string as a resource on the CLASSPATH. Uses *default-encoding* as the text encoding. Should be used inside with-open to ensure the Reader is properly closed.") (writer [x] "Attempts to coerce its argument into an open java.io.Writer. The default implementations of this protocol always return a java.io.BufferedWriter. Default implementations are provided for Writer, BufferedWriter, OutputStream, File, URI, URL, Socket, and String. If the argument is a String, it tries to resolve it first as a URI, then as a local file name. URIs with a 'file' protocol are converted to local file names. Should be used inside with-open to ensure the Writer is properly closed.") (input-stream [x] "Attempts to coerce its argument into an open java.io.InputStream. The default implementations of this protocol always return a java.io.BufferedInputStream. Default implementations are defined for OutputStream, File, URI, URL, Socket, byte array, and String arguments. If the argument is a String, it tries to resolve it first as a URI, then as a local file name. URIs with a 'file' protocol are converted to local file names. Should be used inside with-open to ensure the InputStream is properly closed.") (output-stream [x] "Attempts to coerce its argument into an open java.io.OutputStream. The default implementations of this protocol always return a java.io.BufferedOutputStream. Default implementations are defined for OutputStream, File, URI, URL, Socket, and String arguments. If the argument is a String, it tries to resolve it first as a URI, then as a local file name. URIs with a 'file' protocol are converted to local file names. Should be used inside with-open to ensure the OutputStream is properly closed.")) (def default-streams-impl {:reader #(reader (input-stream %)) :writer #(writer (output-stream %)) :input-stream #(throw (Exception. (str "Cannot open <" (pr-str %) "> as an InputStream."))) :output-stream #(throw (Exception. (str "Cannot open <" (pr-str %) "> as an OutputStream.")))}) (extend File Streams (assoc default-streams-impl :input-stream #(input-stream (FileInputStream. ^File %)) :output-stream #(let [stream (FileOutputStream. ^File % *append*)] (binding [*append* false] (output-stream stream))))) (extend URL Streams (assoc default-streams-impl :input-stream (fn [^URL x] (input-stream (if (= "file" (.getProtocol x)) (FileInputStream. (.getPath x)) (.openStream x)))) :output-stream (fn [^URL x] (if (= "file" (.getProtocol x)) (output-stream (File. (.getPath x))) (throw (Exception. (str "Can not write to non-file URL <" x ">"))))))) (extend URI Streams (assoc default-streams-impl :input-stream #(input-stream (.toURL ^URI %)) :output-stream #(output-stream (.toURL ^URI %)))) (extend String Streams (assoc default-streams-impl :input-stream #(try (input-stream (URL. %)) (catch MalformedURLException e (input-stream (File. ^String %)))) :output-stream #(try (output-stream (URL. %)) (catch MalformedURLException err (output-stream (File. ^String %)))))) (extend Socket Streams (assoc default-streams-impl :input-stream #(.getInputStream ^Socket %) :output-stream #(output-stream (.getOutputStream ^Socket %)))) (extend *byte-array-type* Streams (assoc default-streams-impl :input-stream #(input-stream (ByteArrayInputStream. %)))) (extend *char-array-type* Streams (assoc default-streams-impl :reader #(reader (CharArrayReader. %)))) (extend Object Streams default-streams-impl) (extend Reader Streams (assoc default-streams-impl :reader #(BufferedReader. %))) (extend BufferedReader Streams (assoc default-streams-impl :reader identity)) (defn- inputstream->reader [^InputStream is] (reader (InputStreamReader. is *default-encoding*))) (extend InputStream Streams (assoc default-streams-impl :input-stream #(BufferedInputStream. %) :reader inputstream->reader)) (extend BufferedInputStream Streams (assoc default-streams-impl :input-stream identity :reader inputstream->reader)) (extend Writer Streams (assoc default-streams-impl :writer #(do (assert-not-appending) (BufferedWriter. %)))) (extend BufferedWriter Streams (assoc default-streams-impl :writer #(do (assert-not-appending) %))) (defn- outputstream->writer [^OutputStream os] (assert-not-appending) (writer (OutputStreamWriter. os *default-encoding*))) (extend OutputStream Streams (assoc default-streams-impl :output-stream #(do (assert-not-appending) (BufferedOutputStream. %)) :writer outputstream->writer)) (extend BufferedOutputStream Streams (assoc default-streams-impl :output-stream #(do (assert-not-appending) %) :writer outputstream->writer)) (defn append-output-stream "Like output-stream but opens file for appending. Does not work on streams that are already open." {:deprecated "1.2"} [x] (binding [*append* true] (output-stream x))) (defn append-writer "Like writer but opens file for appending. Does not work on streams that are already open." {:deprecated "1.2"} [x] (binding [*append* true] (writer x))) (defn write-lines "Writes lines (a seq) to f, separated by newlines. f is opened with writer, and automatically closed at the end of the sequence." [f lines] (with-open [^BufferedWriter writer (writer f)] (loop [lines lines] (when-let [line (first lines)] (.write writer (str line)) (.newLine writer) (recur (rest lines)))))) (defn read-lines "Like clojure.core/line-seq but opens f with reader. Automatically closes the reader AFTER YOU CONSUME THE ENTIRE SEQUENCE." [f] (let [read-line (fn this [^BufferedReader rdr] (lazy-seq (if-let [line (.readLine rdr)] (cons line (this rdr)) (.close rdr))))] (read-line (reader f)))) (defn ^String slurp* "Like clojure.core/slurp but opens f with reader." {:deprecated "1.2"} [f] (with-open [^BufferedReader r (reader f)] (let [sb (StringBuilder.)] (loop [c (.read r)] (if (neg? c) (str sb) (do (.append sb (char c)) (recur (.read r)))))))) (defn spit "Opposite of slurp. Opens f with writer, writes content, then closes f." {:deprecated "1.2"} [f content] (with-open [^Writer w (writer f)] (.write w content))) (defn append-spit "Like spit but appends to file." {:deprecated "1.2"} [f content] (with-open [^Writer w (append-writer f)] (.write w content))) (defn pwd "Returns current working directory as a String. (Like UNIX 'pwd'.) Note: In Java, you cannot change the current working directory." {:deprecated "1.2"} [] (System/getProperty "user.dir")) (defmacro with-out-writer "Opens a writer on f, binds it to *out*, and evalutes body. Anything printed within body will be written to f." [f & body] `(with-open [stream# (writer ~f)] (binding [*out* stream#] ~@body))) (defmacro with-out-append-writer "Like with-out-writer but appends to file." {:deprecated "1.2"} [f & body] `(with-open [stream# (append-writer ~f)] (binding [*out* stream#] ~@body))) (defmacro with-in-reader "Opens a PushbackReader on f, binds it to *in*, and evaluates body." [f & body] `(with-open [stream# (PushbackReader. (reader ~f))] (binding [*in* stream#] ~@body))) (defmulti ^{:deprecated "1.2" :doc "Copies input to output. Returns nil. Input may be an InputStream, Reader, File, byte[], or String. Output may be an OutputStream, Writer, or File. Does not close any streams except those it opens itself (on a File). Writing a File fails if the parent directory does not exist." :arglists '([input output])} copy (fn [input output] [(type input) (type output)])) (defmethod copy [InputStream OutputStream] [^InputStream input ^OutputStream output] (let [buffer (make-array Byte/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (do (.write output buffer 0 size) (recur))))))) (defmethod copy [InputStream Writer] [^InputStream input ^Writer output] (let [^"[B" buffer (make-array Byte/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (let [chars (.toCharArray (String. buffer 0 size *default-encoding*))] (do (.write output chars) (recur)))))))) (defmethod copy [InputStream File] [^InputStream input ^File output] (with-open [out (FileOutputStream. output)] (copy input out))) (defmethod copy [Reader OutputStream] [^Reader input ^OutputStream output] (let [^"[C" buffer (make-array Character/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (let [bytes (.getBytes (String. buffer 0 size) *default-encoding*)] (do (.write output bytes) (recur)))))))) (defmethod copy [Reader Writer] [^Reader input ^Writer output] (let [^"[C" buffer (make-array Character/TYPE *buffer-size*)] (loop [] (let [size (.read input buffer)] (when (pos? size) (do (.write output buffer 0 size) (recur))))))) (defmethod copy [Reader File] [^Reader input ^File output] (with-open [out (FileOutputStream. output)] (copy input out))) (defmethod copy [File OutputStream] [^File input ^OutputStream output] (with-open [in (FileInputStream. input)] (copy in output))) (defmethod copy [File Writer] [^File input ^Writer output] (with-open [in (FileInputStream. input)] (copy in output))) (defmethod copy [File File] [^File input ^File output] (with-open [in (FileInputStream. input) out (FileOutputStream. output)] (copy in out))) (defmethod copy [String OutputStream] [^String input ^OutputStream output] (copy (StringReader. input) output)) (defmethod copy [String Writer] [^String input ^Writer output] (copy (StringReader. input) output)) (defmethod copy [String File] [^String input ^File output] (copy (StringReader. input) output)) (defmethod copy [*char-array-type* OutputStream] [input ^OutputStream output] (copy (CharArrayReader. input) output)) (defmethod copy [*char-array-type* Writer] [input ^Writer output] (copy (CharArrayReader. input) output)) (defmethod copy [*char-array-type* File] [input ^File output] (copy (CharArrayReader. input) output)) (defmethod copy [*byte-array-type* OutputStream] [^"[B" input ^OutputStream output] (copy (ByteArrayInputStream. input) output)) (defmethod copy [*byte-array-type* Writer] [^"[B" input ^Writer output] (copy (ByteArrayInputStream. input) output)) (defmethod copy [*byte-array-type* File] [^"[B" input ^Writer output] (copy (ByteArrayInputStream. input) output)) (defn make-parents "Creates all parent directories of file." [^File file] (.mkdirs (.getParentFile file))) (defmulti ^{:doc "Converts argument into a Java byte array. Argument may be a String, File, InputStream, or Reader. If the argument is already a byte array, returns it." :arglists '([arg])} to-byte-array type) (defmethod to-byte-array *byte-array-type* [x] x) (defmethod to-byte-array String [^String x] (.getBytes x *default-encoding*)) (defmethod to-byte-array File [^File x] (with-open [input (FileInputStream. x) buffer (ByteArrayOutputStream.)] (copy input buffer) (.toByteArray buffer))) (defmethod to-byte-array InputStream [^InputStream x] (let [buffer (ByteArrayOutputStream.)] (copy x buffer) (.toByteArray buffer))) (defmethod to-byte-array Reader [^Reader x] (.getBytes (slurp* x) *default-encoding*)) (defmulti relative-path-string "Interpret a String or java.io.File as a relative path string. Building block for clojure.contrib.java/file." {:deprecated "1.2"} class) (defmethod relative-path-string String [^String s] (relative-path-string (File. s))) (defmethod relative-path-string File [^File f] (if (.isAbsolute f) (throw (IllegalArgumentException. (str f " is not a relative path"))) (.getPath f))) (defmulti ^File as-file "Interpret a String or a java.io.File as a File. Building block for clojure.contrib.java/file, which you should prefer in most cases." {:deprecated "1.2"} class) (defmethod as-file String [^String s] (File. s)) (defmethod as-file File [f] f) (defn ^File file "Returns a java.io.File from string or file args." {:deprecated "1.2"} ([arg] (as-file arg)) ([parent child] (File. ^File (as-file parent) ^String (relative-path-string child))) ([parent child & more] (reduce file (file parent child) more))) (defn delete-file "Delete file f. Raise an exception if it fails unless silently is true." [f & [silently]] (or (.delete (file f)) silently (throw (java.io.IOException. (str "Couldn't delete " f))))) (defn delete-file-recursively "Delete file f. If it's a directory, recursively delete all its contents. Raise an exception if any deletion fails unless silently is true." [f & [silently]] (let [f (file f)] (if (.isDirectory f) (doseq [child (.listFiles f)] (delete-file-recursively child silently))) (delete-file f silently))) (defmulti ^{:deprecated "1.2" :doc "Coerces argument (URL, URI, or String) to a java.net.URL." :arglists '([arg])} as-url type) (defmethod as-url URL [x] x) (defmethod as-url URI [^URI x] (.toURL x)) (defmethod as-url String [^String x] (URL. x)) (defmethod as-url File [^File x] (.toURL x)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jar.clj000066400000000000000000000023221161102570000253530ustar00rootroot00000000000000;;; jar.clj: utilities for working with Java JAR files ;; by Stuart Sierra, http://stuartsierra.com/ ;; April 19, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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 ^{:author "Stuart Sierra", :doc "Utilities for working with Java JAR files"} clojure.contrib.jar (:import (java.io File) (java.util.jar JarFile))) (defn jar-file? "Returns true if file is a normal file with a .jar or .JAR extension." [^File file] (and (.isFile file) (or (.endsWith (.getName file) ".jar") (.endsWith (.getName file) ".JAR")))) (defn filenames-in-jar "Returns a sequence of Strings naming the non-directory entries in the JAR file." [^JarFile jar-file] (map #(.getName %) (filter #(not (.isDirectory %)) (enumeration-seq (.entries jar-file))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/java_utils.clj000066400000000000000000000157141161102570000267510ustar00rootroot00000000000000; Copyright (c) Stuart Halloway & Contributors, April 2009. 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. ;; ;; CHANGELOG ;; ;; Most functions deprecated in 1.2. Some already exist in c.c.io, and ;; some replaced by c.c.reflections (ns ^{:author "Stuart Halloway, Stephen C. Gilardi, Shawn Hoover, Perry Trolard, Stuart Sierra", :doc "A set of utilties for dealing with Java stuff like files and properties. Design goals: (1) Ease-of-use. These APIs should be convenient. Performance is secondary. (2) Duck typing. I hate having to think about the difference between a string that names a file, and a File. Ditto for a ton of other wrapper classes in the Java world (URL, InternetAddress). With these APIs you should be able to think about domain equivalence, not type equivalence. (3) No bossiness. I am not marking any of these functions as private the docstrings will tell you the intended usage but do what works for you. Feedback welcome! If something in this module violates the principle of least surprise, please let me (Stu) and the Clojure community know via the mailing list. Contributors: Stuart Halloway Stephen C. Gilardi Shawn Hoover Perry Trolard Stuart Sierra "} clojure.contrib.java-utils (:import [java.io File FileOutputStream] [java.util Properties] [java.net URI URL])) (defmulti relative-path-string "Interpret a String or java.io.File as a relative path string. Building block for clojure.contrib.java-utils/file." {:deprecated "1.2"} class) (defmethod relative-path-string String [^String s] (relative-path-string (File. s))) (defmethod relative-path-string File [^File f] (if (.isAbsolute f) (throw (IllegalArgumentException. (str f " is not a relative path"))) (.getPath f))) (defmulti ^File as-file "Interpret a String or a java.io.File as a File. Building block for clojure.contrib.java-utils/file, which you should prefer in most cases." {:deprecated "1.2"} class) (defmethod as-file String [^String s] (File. s)) (defmethod as-file File [f] f) (defn ^File file "Returns a java.io.File from string or file args." {:deprecated "1.2"} ([arg] (as-file arg)) ([parent child] (File. ^File (as-file parent) ^String (relative-path-string child))) ([parent child & more] (reduce file (file parent child) more))) (defn as-str "Like clojure.core/str, but if an argument is a keyword or symbol, its name will be used instead of its literal representation. Example: (str :foo :bar) ;;=> \":foo:bar\" (as-str :foo :bar) ;;=> \"foobar\" Note that this does not apply to keywords or symbols nested within data structures; they will be rendered as with str. Example: (str {:foo :bar}) ;;=> \"{:foo :bar}\" (as-str {:foo :bar}) ;;=> \"{:foo :bar}\" " {:deprecated "1.2"} ([] "") ([x] (if (instance? clojure.lang.Named x) (name x) (str x))) ([x & ys] ((fn [^StringBuilder sb more] (if more (recur (. sb (append (as-str (first more)))) (next more)) (str sb))) (new StringBuilder ^String (as-str x)) ys))) (defn get-system-property "Get a system property." ([stringable] (System/getProperty (as-str stringable))) ([stringable default] (System/getProperty (as-str stringable) default))) (defn set-system-properties "Set some system properties. Nil clears a property." [settings] (doseq [[name val] settings] (if val (System/setProperty (as-str name) (as-str val)) (System/clearProperty (as-str name))))) (defmacro with-system-properties "setting => property-name value Sets the system properties to the supplied values, executes the body, and sets the properties back to their original values. Values of nil are translated to a clearing of the property." [settings & body] `(let [settings# ~settings current# (reduce (fn [coll# k#] (assoc coll# k# (get-system-property k#))) {} (keys settings#))] (set-system-properties settings#) (try ~@body (finally (set-system-properties current#))))) ; Not there is no corresponding props->map. Just destructure! (defn ^Properties as-properties "Convert any seq of pairs to a java.utils.Properties instance. Uses as-str to convert both keys and values into strings." {:tag Properties} [m] (let [p (Properties.)] (doseq [[k v] m] (.setProperty p (as-str k) (as-str v))) p)) (defn read-properties "Read properties from file-able." [file-able] (with-open [f (java.io.FileInputStream. (file file-able))] (doto (Properties.) (.load f)))) (defn write-properties "Write properties to file-able." {:tag Properties} ([m file-able] (write-properties m file-able nil)) ([m file-able comments] (with-open [^FileOutputStream f (FileOutputStream. (file file-able))] (doto (as-properties m) (.store f ^String comments))))) (defn delete-file "Delete file f. Raise an exception if it fails unless silently is true." {:deprecated "1.2"} [f & [silently]] (or (.delete (file f)) silently (throw (java.io.IOException. (str "Couldn't delete " f))))) (defn delete-file-recursively "Delete file f. If it's a directory, recursively delete all its contents. Raise an exception if any deletion fails unless silently is true." {:deprecated "1.2"} [f & [silently]] (let [f (file f)] (if (.isDirectory f) (doseq [child (.listFiles f)] (delete-file-recursively child silently))) (delete-file f silently))) (defmulti ^{:deprecated "1.2" :doc "Coerces argument (URL, URI, or String) to a java.net.URL." :arglists '([arg])} as-url type) (defmethod as-url URL [x] x) (defmethod as-url URI [^URI x] (.toURL x)) (defmethod as-url String [^String x] (URL. x)) (defmethod as-url File [^File x] (.toURL x)) (defn wall-hack-method "Calls a private or protected method. params is a vector of class which correspond to the arguments to the method obj is nil for static methods, the instance object otherwise the method name is given as a symbol or a keyword (something Named)" {:deprecated "1.2"} [class-name method-name params obj & args] (-> class-name (.getDeclaredMethod (name method-name) (into-array Class params)) (doto (.setAccessible true)) (.invoke obj (into-array Object args)))) (defn wall-hack-field "Access to private or protected field." {:deprecated "1.2"} [class-name field-name obj] (-> class-name (.getDeclaredField (name field-name)) (doto (.setAccessible true)) (.get obj))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/javadoc.clj000066400000000000000000000002251161102570000262060ustar00rootroot00000000000000(ns ^{:deprecated "1.2"} clojure.contrib.javadoc) (throw (Exception. "clojure.contrib.javadoc/javadoc can now be found in clojure.java.javadoc")) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/javadoc/000077500000000000000000000000001161102570000255155ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/javadoc/browse.clj000066400000000000000000000037441161102570000275200ustar00rootroot00000000000000;;; browse.clj -- start a web browser from Clojure ; Copyright (c) Christophe Grand, December 2008. 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 ^{:author "Christophe Grand", :deprecated "1.2" :doc "Start a web browser from Clojure"} clojure.contrib.javadoc.browse (:require [clojure.contrib.shell :as sh]) (:import (java.net URI))) (defn- macosx? [] (-> "os.name" System/getProperty .toLowerCase (.startsWith "mac os x"))) (def *open-url-script* (when (macosx?) "/usr/bin/open")) (defn open-url-in-browser "Opens url (a string) in the default system web browser. May not work on all platforms. Returns url on success, nil if not supported." [url] (try (when (clojure.lang.Reflector/invokeStaticMethod "java.awt.Desktop" "isDesktopSupported" (to-array nil)) (-> (clojure.lang.Reflector/invokeStaticMethod "java.awt.Desktop" "getDesktop" (to-array nil)) (.browse (URI. url))) url) (catch ClassNotFoundException e nil))) (defn open-url-in-swing "Opens url (a string) in a Swing window." [url] ; the implementation of this function resides in another namespace to be loaded "on demand" ; this fixes a bug on mac os x where requiring repl-utils turns the process into a GUI app ; see http://code.google.com/p/clojure-contrib/issues/detail?id=32 (require 'clojure.contrib.javadoc.browse-ui) ((find-var 'clojure.contrib.javadoc.browse-ui/open-url-in-swing) url)) (defn browse-url [url] (or (open-url-in-browser url) (when *open-url-script* (sh/sh *open-url-script* (str url)) true) (open-url-in-swing url))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/javadoc/browse_ui.clj000066400000000000000000000025251161102570000302110ustar00rootroot00000000000000;;; browse_ui.clj -- starts a swing web browser :-( ; Copyright (c) Christophe Grand, December 2008. 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 ^{:deprecated "1.2"} clojure.contrib.javadoc.browse-ui) (defn open-url-in-swing "Opens url (a string) in a Swing window." [url] (let [htmlpane (javax.swing.JEditorPane. url)] (.setEditable htmlpane false) (.addHyperlinkListener htmlpane (proxy [javax.swing.event.HyperlinkListener] [] (hyperlinkUpdate [^javax.swing.event.HyperlinkEvent e] (when (= (.getEventType e) (. javax.swing.event.HyperlinkEvent$EventType ACTIVATED)) (if (instance? javax.swing.text.html.HTMLFrameHyperlinkEvent e) (-> htmlpane .getDocument (.processHTMLFrameHyperlinkEvent e)) (.setPage htmlpane (.getURL e))))))) (doto (javax.swing.JFrame.) (.setContentPane (javax.swing.JScrollPane. htmlpane)) (.setBounds 32 32 700 900) (.show)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jmx.clj000066400000000000000000000100071161102570000253740ustar00rootroot00000000000000;; Copyright (c) Stuart Halloway, 2009. 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 ^{:author "Stuart Halloway" :doc "JMX support for Clojure Requires post-Clojure 1.0 git edge for clojure.test, clojure.backtrace. This is prerelease. This API will change. Send reports to stu@thinkrelevance.com. Usage (require '[clojure.contrib.jmx :as jmx]) What beans do I have? (jmx/mbean-names \"*:*\") -> # (:Verbose :ObjectPendingFinalizationCount :HeapMemoryUsage :NonHeapMemoryUsage) What is the value of an attribute? (jmx/read \"java.lang:type=Memory\" :ObjectPendingFinalizationCount) -> 0 Can't I just have *all* the attributes in a Clojure map? (jmx/mbean \"java.lang:type=Memory\") -> {:NonHeapMemoryUsage {:used 16674024, :max 138412032, :init 24317952, :committed 24317952}, :HeapMemoryUsage {:used 18619064, :max 85393408, :init 0, :committed 83230720}, :ObjectPendingFinalizationCount 0, :Verbose false} Can I find and invoke an operation? (jmx/operation-names \"java.lang:type=Memory\") -> (:gc) (jmx/invoke \"java.lang:type=Memory\" :gc) -> nil What about some other process? Just run *any* of the above code inside a with-connection: (jmx/with-connection {:host \"localhost\", :port 3000} (jmx/mbean \"java.lang:type=Memory\")) -> {:ObjectPendingFinalizationCount 0, :HeapMemoryUsage ... etc.} Can I serve my own beans? Sure, just drop a Clojure ref into an instance of clojure.contrib.jmx.Bean, and the bean will expose read-only attributes for every key/value pair in the ref: (jmx/register-mbean (Bean. (ref {:string-attribute \"a-string\"})) \"my.namespace:name=Value\")"} clojure.contrib.jmx (:refer-clojure :exclude [read]) (:use clojure.contrib.def [clojure.contrib.string :only [as-str]] [clojure.stacktrace :only (root-cause)] [clojure.walk :only [postwalk]]) (:import [clojure.lang Associative] java.lang.management.ManagementFactory [javax.management Attribute DynamicMBean MBeanInfo ObjectName RuntimeMBeanException MBeanAttributeInfo] [javax.management.remote JMXConnectorFactory JMXServiceURL])) (defvar *connection* (ManagementFactory/getPlatformMBeanServer) "The connection to be used for JMX ops. Defaults to the local process.") (load "jmx/data") (load "jmx/client") (load "jmx/server") (defn mbean-names "Finds all MBeans matching a name on the current *connection*." [n] (.queryNames *connection* (as-object-name n) nil)) (defn attribute-names "All attribute names available on an MBean." [n] (doall (map #(-> % .getName keyword) (.getAttributes (mbean-info n))))) (defn operation-names "All operation names available on an MBean." [n] (doall (map #(-> % .getName keyword) (operations n)))) (defn invoke [n op & args] (if ( seq args) (.invoke *connection* (as-object-name n) (as-str op) (into-array args) (into-array String (op-param-types n op))) (.invoke *connection* (as-object-name n) (as-str op) nil nil))) (defn mbean "Like clojure.core/bean, but for JMX beans. Returns a read-only map of a JMX bean's attributes. If an attribute it not supported, value is set to the exception thrown." [n] (into {} (map (fn [attr-name] [(keyword attr-name) (read-supported n attr-name)]) (attribute-names n)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jmx/000077500000000000000000000000001161102570000247045ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jmx/Bean.clj000066400000000000000000000022471161102570000262500ustar00rootroot00000000000000(ns clojure.contrib.jmx.Bean (:gen-class :implements [javax.management.DynamicMBean] :init init :state state :constructors {[Object] []}) (:require [clojure.contrib.jmx :as jmx]) (:import [javax.management DynamicMBean MBeanInfo AttributeList])) (defn -init [derefable] [[] derefable]) ; TODO: rest of the arguments, as needed (defn generate-mbean-info [clj-bean] (MBeanInfo. (.. clj-bean getClass getName) ; class name "Clojure Dynamic MBean" ; description (jmx/map->attribute-infos @(.state clj-bean)) ; attributes nil ; constructors nil ; operations nil)) ; notifications (defn -getMBeanInfo [this] (generate-mbean-info this)) (defn -getAttribute [this attr] (@(.state this) (keyword attr))) (defn -getAttributes [this attrs] (let [result (AttributeList.)] (doseq [attr attrs] (.add result (.getAttribute this attr))) result))clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jmx/client.clj000066400000000000000000000052741161102570000266640ustar00rootroot00000000000000;; JMX client APIs for Clojure ;; docs in clojure/contrib/jmx.clj!! ;; by Stuart Halloway ;; Copyright (c) Stuart Halloway, 2009. 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. (in-ns 'clojure.contrib.jmx) (defmacro with-connection "Execute body with JMX connection specified by opts. opts can also include an optional :environment key which is passed as the environment arg to JMXConnectorFactory/connect." [opts & body] `(let [opts# ~opts env# (get opts# :environment {}) opts# (dissoc opts# :environment)] (with-open [connector# (javax.management.remote.JMXConnectorFactory/connect (JMXServiceURL. (jmx-url opts#)) env#)] (binding [*connection* (.getMBeanServerConnection connector#)] ~@body)))) (defn mbean-info [n] (.getMBeanInfo *connection* (as-object-name n))) (defn raw-read "Read an mbean property. Returns low-level Java object model for composites, tabulars, etc. Most callers should use read." [n attr] (.getAttribute *connection* (as-object-name n) (as-str attr))) (defvar read (comp jmx->clj raw-read) "Read an mbean property.") (defn read-supported "Calls read to read an mbean property, *returning* unsupported operation exceptions instead of throwing them. Used to keep mbean from blowing up. Note: There is no good exception that aggregates unsupported operations, hence the overly-general catch block." [n attr] (try (read n attr) (catch Exception e e))) (defn write! [n attr value] (.setAttribute *connection* (as-object-name n) (Attribute. (as-str attr) value))) (defn attribute-info "Get the MBeanAttributeInfo for an attribute." [object-name attr-name] (filter #(= (as-str attr-name) (.getName %)) (.getAttributes (mbean-info object-name)))) (defn readable? "Is attribute readable?" [n attr] (.isReadable () (mbean-info n))) (defn operations "All oeprations available on an MBean." [n] (.getOperations (mbean-info n))) (defn operation "The MBeanOperationInfo for operation op on mbean n. Used by invoke." [n op] (first (filter #(= (-> % .getName keyword) op) (operations n)))) (defn op-param-types "The parameter types (as class name strings) for operation op on n. Used for invoke." [n op] (map #(-> % .getType) (.getSignature (operation n op)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jmx/data.clj000066400000000000000000000071751161102570000263210ustar00rootroot00000000000000;; Conversions between JMX data structures and idiomatic Clojure ;; docs in clojure/contrib/jmx.clj!! ;; by Stuart Halloway ;; Copyright (c) Stuart Halloway, 2009. 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. (in-ns 'clojure.contrib.jmx) (declare jmx->clj) (defn jmx-url "Build a JMX URL from options." ([] (jmx-url {})) ([overrides] (let [opts (merge {:host "localhost", :port "3000", :jndi-path "jmxrmi"} overrides)] (format "service:jmx:rmi:///jndi/rmi://%s:%s/%s" (opts :host) (opts :port) (opts :jndi-path))))) (defmulti as-object-name "Interpret an object as a JMX ObjectName." { :arglists '([string-or-name]) } class) (defmethod as-object-name String [n] (ObjectName. n)) (defmethod as-object-name ObjectName [n] n) (defn composite-data->map [cd] (into {} (map (fn [attr] [(keyword attr) (jmx->clj (.get cd attr))]) (.. cd getCompositeType keySet)))) (defn maybe-keywordize "Convert a string key to a keyword, leaving other types alone. Used to simplify keys in the tabular data API." [s] (if (string? s) (keyword s) s)) (defn maybe-atomize "Convert a list of length 1 into its contents, leaving other things alone. Used to simplify keys in the tabular data API." [k] (if (and (instance? java.util.List k) (= 1 (count k))) (first k) k)) (defvar simplify-tabular-data-key (comp maybe-keywordize maybe-atomize)) (defn tabular-data->map [td] (into {} ; the need for into-array here was a surprise, and may not ; work for all examples. Are keys always arrays? (map (fn [k] [(simplify-tabular-data-key k) (jmx->clj (.get td (into-array k)))]) (.keySet td)))) (defmulti jmx->clj "Coerce JMX data structures into Clojure data. Handles CompositeData, TabularData, maps, and atoms." { :argslists '([jmx-data-structure]) } (fn [x] (cond (instance? javax.management.openmbean.CompositeData x) :composite (instance? javax.management.openmbean.TabularData x) :tabular (instance? clojure.lang.Associative x) :map :default :default))) (defmethod jmx->clj :composite [c] (composite-data->map c)) (defmethod jmx->clj :tabular [t] (tabular-data->map t)) (defmethod jmx->clj :map [m] (into {} (zipmap (keys m) (map jmx->clj (vals m))))) (defmethod jmx->clj :default [obj] obj) (def guess-attribute-map {"java.lang.Integer" "int" "java.lang.Boolean" "boolean" "java.lang.Long" "long" }) (defn guess-attribute-typename "Guess the attribute typename for MBeanAttributeInfo based on the attribute value." [value] (let [classname (.getName (class value))] (get guess-attribute-map classname classname))) (defn build-attribute-info "Construct an MBeanAttributeInfo. Normally called with a key/value pair from a Clojure map." ([attr-name attr-value] (build-attribute-info (as-str attr-name) (guess-attribute-typename attr-value) (as-str attr-name) true false false)) ([name type desc readable? writable? is?] (MBeanAttributeInfo. name type desc readable? writable? is? ))) (defn map->attribute-infos "Construct an MBeanAttributeInfo[] from a Clojure associative." [attr-map] (into-array (map (fn [[attr-name value]] (build-attribute-info attr-name value)) attr-map))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/jmx/server.clj000066400000000000000000000012741161102570000267100ustar00rootroot00000000000000;; JMX server APIs for Clojure ;; docs in clojure/contrib/jmx.clj!! ;; by Stuart Halloway ;; Copyright (c) Stuart Halloway, 2009. 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. (in-ns 'clojure.contrib.jmx) (defn register-mbean [mbean mbean-name] (.registerMBean *connection* mbean (as-object-name mbean-name))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/json.clj000066400000000000000000000276721161102570000255670ustar00rootroot00000000000000;;; json.clj: JavaScript Object Notation (JSON) parser/writer ;; by Stuart Sierra, http://stuartsierra.com/ ;; January 30, 2010 ;; Copyright (c) Stuart Sierra, 2010. 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 ^{:author "Stuart Sierra" :doc "JavaScript Object Notation (JSON) parser/writer. See http://www.json.org/ To write JSON, use json-str, write-json, or write-json. To read JSON, use read-json."} clojure.contrib.json (:use [clojure.contrib.pprint :only (write formatter-out)] [clojure.contrib.string :only (as-str)]) (:import (java.io PrintWriter PushbackReader StringWriter StringReader Reader EOFException))) ;;; JSON READER (declare read-json-reader) (defn- read-json-array [^PushbackReader stream keywordize?] ;; Expects to be called with the head of the stream AFTER the ;; opening bracket. (loop [i (.read stream), result (transient [])] (let [c (char i)] (cond (= i -1) (throw (EOFException. "JSON error (end-of-file inside array)")) (Character/isWhitespace c) (recur (.read stream) result) (= c \,) (recur (.read stream) result) (= c \]) (persistent! result) :else (do (.unread stream (int c)) (let [element (read-json-reader stream keywordize? true nil)] (recur (.read stream) (conj! result element)))))))) (defn- read-json-object [^PushbackReader stream keywordize?] ;; Expects to be called with the head of the stream AFTER the ;; opening bracket. (loop [i (.read stream), key nil, result (transient {})] (let [c (char i)] (cond (= i -1) (throw (EOFException. "JSON error (end-of-file inside object)")) (Character/isWhitespace c) (recur (.read stream) key result) (= c \,) (recur (.read stream) nil result) (= c \:) (recur (.read stream) key result) (= c \}) (if (nil? key) (persistent! result) (throw (Exception. "JSON error (key missing value in object)"))) :else (do (.unread stream i) (let [element (read-json-reader stream keywordize? true nil)] (if (nil? key) (if (string? element) (recur (.read stream) element result) (throw (Exception. "JSON error (non-string key in object)"))) (recur (.read stream) nil (assoc! result (if keywordize? (keyword key) key) element))))))))) (defn- read-json-hex-character [^PushbackReader stream] ;; Expects to be called with the head of the stream AFTER the ;; initial "\u". Reads the next four characters from the stream. (let [digits [(.read stream) (.read stream) (.read stream) (.read stream)]] (when (some neg? digits) (throw (EOFException. "JSON error (end-of-file inside Unicode character escape)"))) (let [chars (map char digits)] (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9 \a \b \c \d \e \f \A \B \C \D \E \F} chars) (throw (Exception. "JSON error (invalid hex character in Unicode character escape)"))) (char (Integer/parseInt (apply str chars) 16))))) (defn- read-json-escaped-character [^PushbackReader stream] ;; Expects to be called with the head of the stream AFTER the ;; initial backslash. (let [c (char (.read stream))] (cond (#{\" \\ \/} c) c (= c \b) \backspace (= c \f) \formfeed (= c \n) \newline (= c \r) \return (= c \t) \tab (= c \u) (read-json-hex-character stream)))) (defn- read-json-quoted-string [^PushbackReader stream] ;; Expects to be called with the head of the stream AFTER the ;; opening quotation mark. (let [buffer (StringBuilder.)] (loop [i (.read stream)] (let [c (char i)] (cond (= i -1) (throw (EOFException. "JSON error (end-of-file inside string)")) (= c \") (str buffer) (= c \\) (do (.append buffer (read-json-escaped-character stream)) (recur (.read stream))) :else (do (.append buffer c) (recur (.read stream)))))))) (defn- read-json-reader ([^PushbackReader stream keywordize? eof-error? eof-value] (loop [i (.read stream)] (let [c (char i)] (cond ;; Handle end-of-stream (= i -1) (if eof-error? (throw (EOFException. "JSON error (end-of-file)")) eof-value) ;; Ignore whitespace (Character/isWhitespace c) (recur (.read stream)) ;; Read numbers, true, and false with Clojure reader (#{\- \0 \1 \2 \3 \4 \5 \6 \7 \8 \9} c) (do (.unread stream i) (read stream true nil)) ;; Read strings (= c \") (read-json-quoted-string stream) ;; Read null as nil (= c \n) (let [ull [(char (.read stream)) (char (.read stream)) (char (.read stream))]] (if (= ull [\u \l \l]) nil (throw (Exception. (str "JSON error (expected null): " c ull))))) ;; Read true (= c \t) (let [rue [(char (.read stream)) (char (.read stream)) (char (.read stream))]] (if (= rue [\r \u \e]) true (throw (Exception. (str "JSON error (expected true): " c rue))))) ;; Read false (= c \f) (let [alse [(char (.read stream)) (char (.read stream)) (char (.read stream)) (char (.read stream))]] (if (= alse [\a \l \s \e]) false (throw (Exception. (str "JSON error (expected false): " c alse))))) ;; Read JSON objects (= c \{) (read-json-object stream keywordize?) ;; Read JSON arrays (= c \[) (read-json-array stream keywordize?) :else (throw (Exception. (str "JSON error (unexpected character): " c)))))))) (defprotocol Read-JSON-From (read-json-from [input keywordize? eof-error? eof-value] "Reads one JSON value from input String or Reader. If keywordize? is true, object keys will be converted to keywords. If eof-error? is true, empty input will throw an EOFException; if false EOF will return eof-value. ")) (extend-protocol Read-JSON-From String (read-json-from [input keywordize? eof-error? eof-value] (read-json-reader (PushbackReader. (StringReader. input)) keywordize? eof-error? eof-value)) PushbackReader (read-json-from [input keywordize? eof-error? eof-value] (read-json-reader input keywordize? eof-error? eof-value)) Reader (read-json-from [input keywordize? eof-error? eof-value] (read-json-reader (PushbackReader. input) keywordize? eof-error? eof-value))) (defn read-json "Reads one JSON value from input String or Reader. If keywordize? is true (default), object keys will be converted to keywords. If eof-error? is true (default), empty input will throw an EOFException; if false EOF will return eof-value. " ([input] (read-json-from input true true nil)) ([input keywordize?] (read-json-from input keywordize? true nil)) ([input keywordize? eof-error? eof-value] (read-json-from input keywordize? eof-error? eof-value))) ;;; JSON PRINTER (defprotocol Write-JSON (write-json [object out] "Print object to PrintWriter out as JSON")) (defn- write-json-string [^CharSequence s ^PrintWriter out] (let [sb (StringBuilder. ^Integer (count s))] (.append sb \") (dotimes [i (count s)] (let [cp (Character/codePointAt s i)] (cond ;; Handle printable JSON escapes before ASCII (= cp 34) (.append sb "\\\"") (= cp 92) (.append sb "\\\\") (= cp 47) (.append sb "\\/") ;; Print simple ASCII characters (< 31 cp 127) (.append sb (.charAt s i)) ;; Handle non-printable JSON escapes (= cp 8) (.append sb "\\b") (= cp 12) (.append sb "\\f") (= cp 10) (.append sb "\\n") (= cp 13) (.append sb "\\r") (= cp 9) (.append sb "\\t") ;; Any other character is Hexadecimal-escaped :else (.append sb (format "\\u%04x" cp))))) (.append sb \") (.print out (str sb)))) (defn- write-json-object [m ^PrintWriter out] (.print out \{) (loop [x m] (when (seq m) (let [[k v] (first x)] (when (nil? k) (throw (Exception. "JSON object keys cannot be nil/null"))) (.print out \") (.print out (as-str k)) (.print out \") (.print out \:) (write-json v out)) (let [nxt (next x)] (when (seq nxt) (.print out \,) (recur nxt))))) (.print out \})) (defn- write-json-array [s ^PrintWriter out] (.print out \[) (loop [x s] (when (seq x) (let [fst (first x) nxt (next x)] (write-json fst out) (when (seq nxt) (.print out \,) (recur nxt))))) (.print out \])) (defn- write-json-bignum [x ^PrintWriter out] (.print out (str x))) (defn- write-json-plain [x ^PrintWriter out] (.print out x)) (defn- write-json-null [x ^PrintWriter out] (.print out "null")) (defn- write-json-named [x ^PrintWriter out] (write-json-string (name x) out)) (defn- write-json-generic [x out] (if (.isArray (class x)) (write-json (seq x) out) (throw (Exception. (str "Don't know how to write JSON of " (class x)))))) (extend nil Write-JSON {:write-json write-json-null}) (extend clojure.lang.Named Write-JSON {:write-json write-json-named}) (extend java.lang.Boolean Write-JSON {:write-json write-json-plain}) (extend java.lang.Number Write-JSON {:write-json write-json-plain}) (extend java.math.BigInteger Write-JSON {:write-json write-json-bignum}) (extend java.math.BigDecimal Write-JSON {:write-json write-json-bignum}) (extend java.lang.CharSequence Write-JSON {:write-json write-json-string}) (extend java.util.Map Write-JSON {:write-json write-json-object}) (extend java.util.Collection Write-JSON {:write-json write-json-array}) (extend clojure.lang.ISeq Write-JSON {:write-json write-json-array}) (extend java.lang.Object Write-JSON {:write-json write-json-generic}) (defn json-str "Converts x to a JSON-formatted string." [x] (let [sw (StringWriter.) out (PrintWriter. sw)] (write-json x out) (.toString sw))) (defn print-json "Write JSON-formatted output to *out*" [x] (write-json x *out*)) ;;; JSON PRETTY-PRINTER ;; Based on code by Tom Faulhaber (defn- pprint-json-array [s] ((formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>") s)) (defn- pprint-json-object [m] ((formatter-out "~<{~;~@{~<~w:~_~w~:>~^, ~_~}~;}~:>") (for [[k v] m] [(as-str k) v]))) (defn- pprint-json-generic [x] (if (.isArray (class x)) (pprint-json-array (seq x)) (print (json-str x)))) (defn- pprint-json-dispatch [x] (cond (nil? x) (print "null") (instance? java.util.Map x) (pprint-json-object x) (instance? java.util.Collection x) (pprint-json-array x) (instance? clojure.lang.ISeq x) (pprint-json-array x) :else (pprint-json-generic x))) (defn pprint-json "Pretty-prints JSON representation of x to *out*" [x] (write x :dispatch pprint-json-dispatch)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/lazy_seqs.clj000066400000000000000000000057021161102570000266160ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; 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 - all the Fibonacci numbers ;; ;; powers-of-2 - all the powers of 2 ;; ;; == Lazy sequence functions == ;; ;; (partition-all, shuffle moved to clojure.core) ;; (rand-elt moved to clojure.core/rand-nth) ;; (rotations, moved to seq_utils.clj) ;; (permutations and combinations moved to combinatorics.clj) ;; ;; [1] http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf ;; [2] http://clj-me.blogspot.com/2008/06/primes.html ;; ;; scgilardi (gmail) ;; Created 07 June 2008 (ns ^{:author "Stephen C. Gilardi", :doc " ==== 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 - all the Fibonacci numbers powers-of-2 - all the powers of 2 ==== Lazy sequence functions ==== (partition-all, shuffle moved to clojure.core) (rand-elt moved to clojure.core/rand-nth) (rotations, rand-elt moved to seq_utils.clj) (permutations and combinations moved to combinatorics.clj) [1] http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf [2] http://clj-me.blogspot.com/2008/06/primes.html "} clojure.contrib.lazy-seqs (:use clojure.contrib.def)) ; primes cannot be written efficiently as a function, because ; it needs to look back on the whole sequence. contrast with ; fibs and powers-of-2 which only need a fixed buffer of 1 or 2 ; previous values. (defvar primes (concat [2 3 5 7] (lazy-seq (let [primes-from (fn primes-from [n [f & r]] (if (some #(zero? (rem n %)) (take-while #(<= (* % %) n) primes)) (recur (+ n f) r) (lazy-seq (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)))) "Lazy sequence of all the prime numbers.") (defn fibs "Returns a lazy sequence of all the Fibonacci numbers." [] (map first (iterate (fn [[a b]] [b (+ a b)]) [0 1]))) (defn powers-of-2 "Returns a lazy sequence of all the powers of 2" [] (iterate #(bit-shift-left % 1) 1)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/lazy_xml.clj000066400000000000000000000201431161102570000264370ustar00rootroot00000000000000; Copyright (c) Chris Houser, Dec 2008. 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. ; Functions to parse xml lazily and emit back to text. (ns ^{:author "Chris Houser", :doc "Functions to parse xml lazily and emit back to text."} clojure.contrib.lazy-xml (:use [clojure.xml :as xml :only []] [clojure.contrib.seq :only [fill-queue]]) (:import (org.xml.sax Attributes InputSource) (org.xml.sax.helpers DefaultHandler) (javax.xml.parsers SAXParserFactory) (java.util.concurrent LinkedBlockingQueue TimeUnit) (java.lang.ref WeakReference) (java.io Reader))) (defstruct node :type :name :attrs :str) ; http://www.extreme.indiana.edu/xgws/xsoap/xpp/ (def has-pull false) (defn- parse-seq-pull [& _]) (try (load "lazy_xml/with_pull") (catch Exception e (when-not (re-find #"XmlPullParser" (str e)) (throw e)))) (defn startparse-sax [s ch] (.. SAXParserFactory newInstance newSAXParser (parse s ch))) (defn parse-seq "Parses the source s, which can be a File, InputStream or String naming a URI. Returns a lazy sequence of maps with two or more of the keys :type, :name, :attrs, and :str. Other SAX-compatible parsers can be supplied by passing startparse, a fn taking a source and a ContentHandler and returning a parser. If a parser is specified, it will be run in a separate thread and be allowed to get ahead by queue-size items, which defaults to maxint. If no parser is specified and org.xmlpull.v1.XmlPullParser is in the classpath, this superior pull parser will be used." ([s] (if has-pull (parse-seq-pull s) (parse-seq s startparse-sax))) ([s startparse] (parse-seq s startparse Integer/MAX_VALUE)) ([s startparse queue-size] (let [s (if (instance? Reader s) (InputSource. s) s) f (fn filler-func [fill] (startparse s (proxy [DefaultHandler] [] (startElement [uri local-name q-name ^Attributes atts] ;(prn :start-element q-name)(flush) (let [attrs (into {} (for [i (range (.getLength atts))] [(keyword (.getQName atts i)) (.getValue atts i)]))] (fill (struct node :start-element (keyword q-name) attrs)))) (endElement [uri local-name q-name] ;(prn :end-element q-name)(flush) (fill (struct node :end-element (keyword q-name)))) (characters [ch start length] ;(prn :characters)(flush) (let [st (String. ch start length)] (when (seq (.trim st)) (fill (struct node :characters nil nil st))))))))] (fill-queue f :queue-size queue-size)))) (defstruct element :tag :attrs :content) (declare mktree) (defn- siblings [coll] (lazy-seq (when-let [s (seq coll)] (let [event (first s)] (condp = (:type event) :characters (cons (:str event) (siblings (rest s))) :start-element (let [t (mktree s)] (cons (first t) (siblings (rest t)))) :end-element [(rest s)]))))) (defn- mktree [[elem & events]] (lazy-seq (let [sibs (siblings events)] ;(prn :elem elem) (cons (struct element (:name elem) (:attrs elem) (drop-last sibs)) (lazy-seq (last sibs)))))) (defn parse-trim "Parses the source s, which can be a File, InputStream or String naming a URI. Returns a lazy tree of the clojure.xml/element struct-map, which has the keys :tag, :attrs, and :content and accessor fns tag, attrs, and content, with the whitespace trimmed from around each content string. This format is compatible with what clojure.xml/parse produces, except :content is a lazy seq instead of a vector. Other SAX-compatible parsers can be supplied by passing startparse, a fn taking a source and a ContentHandler and returning a parser. If a parser is specified, it will be run in a separate thread and be allowed to get ahead by queue-size items, which defaults to maxing. If no parser is specified and org.xmlpull.v1.XmlPullParser is in the classpath, this superior pull parser will be used." ([s] (first (mktree (parse-seq s)))) ([s startparse queue-size] (first (mktree (parse-seq s startparse queue-size))))) (defn attributes [e] (let [v (vec (:attrs e))] (reify org.xml.sax.Attributes (getLength [_] (count v)) (getURI [_ i] (namespace (key (v i)))) (getLocalName [_ i] (name (key (v i)))) (getQName [_ i] (name (key (v i)))) (getValue [_ uri name] (get (:attrs e) name)) (^String getValue [_ ^int i] (val (v i))) (^String getType [_ ^int i] "CDATA")))) (defn- emit-element "Recursively prints as XML text the element struct e. To have it print extra whitespace like clojure.xml/emit, use the :pad true option." [e ^org.xml.sax.ContentHandler ch] (if (instance? String e) (.characters ch (.toCharArray ^String e) 0 (count e)) (let [nspace (namespace (:tag e)) qname (name (:tag e))] (.startElement ch (or nspace "") qname qname (attributes e)) (doseq [c (:content e)] (emit-element c ch)) (.endElement ch (or nspace "") qname qname)))) (defn emit [e & {:as opts}] (let [content-handler (atom nil) trans (-> (javax.xml.transform.TransformerFactory/newInstance) .newTransformer)] (when (:indent opts) (.setOutputProperty trans "indent" "yes") (.setOutputProperty trans "{http://xml.apache.org/xslt}indent-amount" (str (:indent opts)))) (when (contains? opts :xml-declaration) (.setOutputProperty trans "omit-xml-declaration" (if (:xml-declaration opts) "no" "yes"))) (when (:encoding opts) (.setOutputProperty trans "encoding" (:encoding opts))) (.transform trans (javax.xml.transform.sax.SAXSource. (reify org.xml.sax.XMLReader (getContentHandler [_] @content-handler) (setDTDHandler [_ handler]) (setFeature [_ name value]) (setProperty [_ name value]) (setContentHandler [_ ch] (reset! content-handler ch)) (^void parse [_ ^org.xml.sax.InputSource _] (when @content-handler (.startDocument @content-handler) (emit-element e @content-handler) (.endDocument @content-handler)))) (org.xml.sax.InputSource.)) (javax.xml.transform.stream.StreamResult. *out*)))) (comment (def atomstr " tag:blogger.com,1999:blog-28403206 2008-02-14T08:00:58.567-08:00 n01senet 1 2008-02-13 clojure is the best lisp yet Chouser 2 2008-02-07 experimenting with vnc agriffis ") (def tree (parse-trim (java.io.StringReader. atomstr) startparse-sax 1)) (println "\nsax") (emit tree) (def tree (parse-trim (java.io.StringReader. atomstr))) (println "\ndefault") (emit tree) (def tree (xml/parse (org.xml.sax.InputSource. (java.io.StringReader. atomstr)))) (println "\norig") (emit tree) ; When used with zip and zip-filter, you can get do queries like this ; without parsing more than the first few tags: ; (zip/node (first (xml-> (zip/xml-zip tree) :id))) ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/lazy_xml/000077500000000000000000000000001161102570000257455ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/lazy_xml/with_pull.clj000066400000000000000000000042341161102570000304510ustar00rootroot00000000000000; Copyright (c) Chris Houser, Dec 2008. 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. ; optional module to allow lazy-xml to use pull parser instead of sax (in-ns 'clojure.contrib.lazy-xml) (import '(org.xmlpull.v1 XmlPullParser XmlPullParserFactory)) (defn- attrs [xpp] (for [i (range (.getAttributeCount xpp))] [(keyword (.getAttributeName xpp i)) (.getAttributeValue xpp i)])) (defn- ns-decs [xpp] (let [d (.getDepth xpp)] (for [i (range (.getNamespaceCount xpp (dec d)) (.getNamespaceCount xpp d))] (let [prefix (.getNamespacePrefix xpp i)] [(keyword (str "xmlns" (when prefix (str ":" prefix)))) (.getNamespaceUri xpp i)])))) (defn- attr-hash [xpp] (into {} (concat (ns-decs xpp) (attrs xpp)))) (defn- pull-step [xpp] (let [step (fn [xpp] (condp = (.next xpp) XmlPullParser/START_TAG (cons (struct node :start-element (keyword (.getName xpp)) (attr-hash xpp)) (pull-step xpp)) XmlPullParser/END_TAG (cons (struct node :end-element (keyword (.getName xpp))) (pull-step xpp)) XmlPullParser/TEXT (let [text (.trim (.getText xpp))] (if (empty? text) (recur xpp) (cons (struct node :characters nil nil text) (pull-step xpp))))))] (lazy-seq (step xpp)))) (def ^{:private true} factory (doto (XmlPullParserFactory/newInstance) (.setNamespaceAware true))) (defn- parse-seq-pull [s] (let [xpp (.newPullParser factory)] (.setInput xpp s) (pull-step xpp))) (def has-pull true) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/logging.clj000066400000000000000000000272251161102570000262360ustar00rootroot00000000000000;;; logging.clj -- delegated logging for Clojure ;; by Alex Taggart ;; July 27, 2009 ;; Copyright (c) Alex Taggart, July 2009. 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 ^{:author "Alex Taggart, Timothy Pratley", :doc "Logging macros which delegate to a specific logging implementation. At runtime a specific implementation is selected from, in order, Apache commons-logging, log4j, and finally java.util.logging. Logging levels are specified by clojure keywords corresponding to the values used in log4j and commons-logging: :trace, :debug, :info, :warn, :error, :fatal Logging occurs with the log macro, or the level-specific convenience macros, which write either directly or via an agent. For performance reasons, direct logging is enabled by default, but setting the *allow-direct-logging* boolean atom to false will disable it. If logging is invoked within a transaction it will always use an agent. The log macros will not evaluate their 'message' unless the specific logging level is in effect. Alternately, you can use the spy macro when you have code that needs to be evaluated, and also want to output the code and its result to the debug log. Unless otherwise specified, the current namespace (as identified by *ns*) will be used as the log-ns (similar to how the java class name is usually used). Note: your log configuration should display the name that was passed to the logging implementation, and not perform stack-inspection, otherwise you'll see something like \"fn__72$impl_write_BANG__39__auto____81\" in your logs. Use the enabled? macro to write conditional code against the logging level (beyond simply whether or not to call log, which is handled automatically). You can redirect all java writes of System.out and System.err to the log system by calling log-capture!. To rebind *out* and *err* to the log system invoke with-logs. In both cases a log-ns (e.g., \"com.example.captured\") needs to be specified to namespace the output."} clojure.contrib.logging) (declare *impl-name* impl-get-log impl-enabled? impl-write!) ;; Macros used so that implementation-specific functions all have the same meta. (defmacro def-impl-name {:private true} [& body] `(def ^{:doc "The name of the logging implementation used."} *impl-name* ~@body)) (defmacro def-impl-get-log {:private true} [& body] `(def ^{:doc "Returns an implementation-specific log by string namespace. End-users should not need to call this." :arglist '([~'log-ns])} impl-get-log (memoize ~@body))) (defmacro def-impl-enabled? {:private true} [& body] `(def ^{:doc "Implementation-specific check if a particular level is enabled. End-users should not need to call this." :arglist '([~'log ~'level])} impl-enabled? ~@body)) (defmacro def-impl-write! {:private true} [& body] `(def ^{:doc "Implementation-specific write of a log message. End-users should not need to call this." :arglist '([~'log ~'level ~'message ~'throwable])} impl-write! ~@body)) (defn- commons-logging "Defines the commons-logging-based implementations of the core logging functions. End-users should never need to call this." [] (try (import (org.apache.commons.logging LogFactory Log)) (eval `(do (def-impl-name "org.apache.commons.logging") (def-impl-get-log (fn [log-ns#] (org.apache.commons.logging.LogFactory/getLog ^String log-ns#))) (def-impl-enabled? (fn [^org.apache.commons.logging.Log log# level#] (condp = level# :trace (.isTraceEnabled log#) :debug (.isDebugEnabled log#) :info (.isInfoEnabled log#) :warn (.isWarnEnabled log#) :error (.isErrorEnabled log#) :fatal (.isFatalEnabled log#)))) (def-impl-write! (fn [^org.apache.commons.logging.Log log# level# msg# e#] (condp = level# :trace (.trace log# msg# e#) :debug (.debug log# msg# e#) :info (.info log# msg# e#) :warn (.warn log# msg# e#) :error (.error log# msg# e#) :fatal (.fatal log# msg# e#)))) true)) (catch Exception e nil))) (defn- log4j-logging "Defines the log4j-based implementations of the core logging functions. End-users should never need to call this." [] (try (import (org.apache.log4j Logger Level)) (eval '(do (def-impl-name "org.apache.log4j") (def-impl-get-log (fn [log-ns#] (org.apache.log4j.Logger/getLogger ^String log-ns#))) (let [levels# {:trace org.apache.log4j.Level/TRACE :debug org.apache.log4j.Level/DEBUG :info org.apache.log4j.Level/INFO :warn org.apache.log4j.Level/WARN :error org.apache.log4j.Level/ERROR :fatal org.apache.log4j.Level/FATAL}] (def-impl-enabled? (fn [^org.apache.log4j.Logger log# level#] (.isEnabledFor log# (levels# level#)))) (def-impl-write! (fn [^org.apache.log4j.Logger log# level# msg# e#] (if-not e# (.log log# (levels# level#) msg#) (.log log# (levels# level#) msg# e#))))) true)) (catch Exception e nil))) (defn- java-logging "Defines the java-logging-based implementations of the core logging functions. End-users should never need to call this." [] (try (import (java.util.logging Logger Level)) (eval `(do (def-impl-name "java.util.logging") (def-impl-get-log (fn [log-ns#] (java.util.logging.Logger/getLogger log-ns#))) (let [levels# {:trace java.util.logging.Level/FINEST :debug java.util.logging.Level/FINE :info java.util.logging.Level/INFO :warn java.util.logging.Level/WARNING :error java.util.logging.Level/SEVERE :fatal java.util.logging.Level/SEVERE}] (def-impl-enabled? (fn [^java.util.logging.Logger log# level#] (.isLoggable log# (levels# level#)))) (def-impl-write! (fn [^java.util.logging.Logger log# level# msg# e#] (if-not e# (.log log# ^java.util.logging.Level (levels# level#) ^String (str msg#)) (.log log# ^java.util.logging.Level (levels# level#) ^String (str msg#) ^Throwable e#))))) true)) (catch Exception e nil))) ;; Initialize implementation-specific functions (or (commons-logging) (log4j-logging) (java-logging) (throw ; this should never happen in 1.5+ (RuntimeException. "Valid logging implementation could not be found."))) (def ^{:doc "The default agent used for performing logging durng a transaction or when direct logging is disabled."} *logging-agent* (agent nil)) (def ^{:doc "A boolean indicating whether direct logging (as opposed to via an agent) is allowed when not operating from within a transaction. Defaults to true."} *allow-direct-logging* (atom true)) (defmacro log "Logs a message, either directly or via an agent. Also see the level-specific convenience macros." ([level message] `(log ~level ~message nil)) ([level message throwable] `(log ~level ~message ~throwable ~(str *ns*))) ([level message throwable log-ns] `(let [log# (impl-get-log ~log-ns)] (if (impl-enabled? log# ~level) (if (and @*allow-direct-logging* (not (clojure.lang.LockingTransaction/isRunning))) (impl-write! log# ~level ~message ~throwable) (send-off *logging-agent* (fn [_# l# v# m# t#] (impl-write! l# v# m# t#)) log# ~level ~message ~throwable)))))) (defmacro enabled? "Returns true if the specific logging level is enabled. Use of this function should only be necessary if one needs to execute alternate code paths beyond whether the log should be written to." ([level] `(enabled? ~level ~(str *ns*))) ([level log-ns] `(impl-enabled? (impl-get-log ~log-ns) ~level))) (defmacro spy "Evaluates expr and outputs the form and its result to the debug log; returns the result of expr." [expr] `(let [a# ~expr] (log :debug (str '~expr " => " a#)) a#)) (defn log-stream "Creates a PrintStream that will output to the log. End-users should not need to invoke this." [level log-ns] (java.io.PrintStream. (proxy [java.io.ByteArrayOutputStream] [] (flush [] (proxy-super flush) (let [s (.trim (.toString ^java.io.ByteArrayOutputStream this))] (proxy-super reset) (if (> (.length s) 0) (log level s nil log-ns))))) true)) (def ^{:doc "A ref used by log-capture! to maintain a reference to the original System.out and System.err streams." :private true} *old-std-streams* (ref nil)) (defn log-capture! "Captures System.out and System.err, redirecting all writes of those streams to :info and :error logging, respectively. The specified log-ns value will be used to namespace all redirected logging. NOTE: this will not redirect output of *out* or *err*; for that, use with-logs." [log-ns] (dosync (let [new-out (log-stream :info log-ns) new-err (log-stream :error log-ns)] ; don't overwrite the original values (if (nil? @*old-std-streams*) (ref-set *old-std-streams* {:out System/out :err System/err})) (System/setOut new-out) (System/setErr new-err)))) (defn log-uncapture! "Restores System.out and System.err to their original values." [] (dosync (when-let [{old-out :out old-err :err} @*old-std-streams*] (ref-set *old-std-streams* nil) (System/setOut old-out) (System/setErr old-err)))) (defmacro with-logs "Evaluates exprs in a context in which *out* and *err* are bound to :info and :error logging, respectively. The specified log-ns value will be used to namespace all redirected logging." [log-ns & body] (if (and log-ns (seq body)) `(binding [*out* (java.io.OutputStreamWriter. (log-stream :info ~log-ns)) *err* (java.io.OutputStreamWriter. (log-stream :error ~log-ns))] ~@body))) (defmacro trace "Logs a message at the trace level." ([message] `(log :trace ~message)) ([message throwable] `(log :trace ~message ~throwable))) (defmacro debug "Logs a message at the debug level." ([message] `(log :debug ~message)) ([message throwable] `(log :debug ~message ~throwable))) (defmacro info "Logs a message at the info level." ([message] `(log :info ~message)) ([message throwable] `(log :info ~message ~throwable))) (defmacro warn "Logs a message at the warn level." ([message] `(log :warn ~message)) ([message throwable] `(log :warn ~message ~throwable))) (defmacro error "Logs a message at the error level." ([message] `(log :error ~message)) ([message throwable] `(log :error ~message ~throwable))) (defmacro fatal "Logs a message at the fatal level." ([message] `(log :fatal ~message)) ([message throwable] `(log :fatal ~message ~throwable))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/macro_utils.clj000066400000000000000000000220131161102570000271170ustar00rootroot00000000000000;; Macrolet and symbol-macrolet ;; by Konrad Hinsen ;; last updated January 14, 2010 ;; Copyright (c) Konrad Hinsen, 2009-2010. 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 ^{:author "Konrad Hinsen" :doc "Local macros and symbol macros Local macros are defined by a macrolet form. They are usable only inside its body. Symbol macros can be defined globally (defsymbolmacro) or locally (symbol-macrolet). A symbol macro defines a form that replaces a symbol during macro expansion. Function arguments and symbols bound in let forms are not subject to symbol macro expansion. Local macros are most useful in the definition of the expansion of another macro, they may be used anywhere. Global symbol macros can be used only inside a with-symbol-macros form."} clojure.contrib.macro-utils (:use [clojure.contrib.def :only (defvar-)])) ; A set of all special forms. Special forms are not macro-expanded, making ; it impossible to shadow them by macro definitions. For most special ; forms, all the arguments are simply macro-expanded, but some forms ; get special treatment. (defvar- special-forms (into #{} (keys clojure.lang.Compiler/specials))) ; Value in the Clojure 1.2 branch: ; #{deftype* new quote & var set! monitor-enter recur . case* clojure.core/import* reify* do fn* throw monitor-exit letfn* finally let* loop* try catch if def} ; The following three vars are constantly redefined using the binding ; form, imitating dynamic scoping. ; ; Local macros. (defvar- macro-fns {}) ; Local symbol macros. (defvar- macro-symbols {}) ; Symbols defined inside let forms or function arguments. (defvar- protected-symbols #{}) (defn- reserved? [symbol] "Return true if symbol is a reserved symbol (starting or ending with a dot)." (let [s (str symbol)] (or (= "." (subs s 0 1)) (= "." (subs s (dec (count s))))))) (defn- expand-symbol "Expand symbol macros" [symbol] (cond (contains? protected-symbols symbol) symbol (reserved? symbol) symbol (contains? macro-symbols symbol) (get macro-symbols symbol) :else (let [v (resolve symbol) m (meta v)] (if (:symbol-macro m) (var-get v) symbol)))) (defn- expand-1 "Perform a single non-recursive macro expansion of form." [form] (cond (seq? form) (let [f (first form)] (cond (contains? special-forms f) form (contains? macro-fns f) (apply (get macro-fns f) (rest form)) (symbol? f) (let [exp (expand-symbol f)] (if (= exp f) (clojure.core/macroexpand-1 form) (cons exp (rest form)))) ; handle defmacro macros and Java method special forms :else (clojure.core/macroexpand-1 form))) (symbol? form) (expand-symbol form) :else form)) (defn- expand "Perform repeated non-recursive macro expansion of form, until it no longer changes." [form] (let [ex (expand-1 form)] (if (identical? ex form) form (recur ex)))) (declare expand-all) (defn- expand-args "Recursively expand the arguments of form, leaving its first n elements unchanged." ([form] (expand-args form 1)) ([form n] (doall (concat (take n form) (map expand-all (drop n form)))))) (defn- expand-bindings [bindings exprs] (if (empty? bindings) (list (doall (map expand-all exprs))) (let [[[s b] & bindings] bindings] (let [b (expand-all b)] (binding [protected-symbols (conj protected-symbols s)] (doall (cons [s b] (expand-bindings bindings exprs)))))))) (defn- expand-with-bindings "Handle let* and loop* forms. The symbols defined in them are protected from symbol macro expansion, the definitions and the body expressions are expanded recursively." [form] (let [f (first form) bindings (partition 2 (second form)) exprs (rest (rest form)) expanded (expand-bindings bindings exprs) bindings (vec (apply concat (butlast expanded))) exprs (last expanded)] (cons f (cons bindings exprs)))) (defn- expand-fn-body [[args & exprs]] (binding [protected-symbols (reduce conj protected-symbols (filter #(not (= % '&)) args))] (cons args (doall (map expand-all exprs))))) (defn- expand-fn "Handle fn* forms. The arguments are protected from symbol macro expansion, the bodies are expanded recursively." [form] (let [[f & bodies] form name (when (symbol? (first bodies)) (first bodies)) bodies (if (symbol? (first bodies)) (rest bodies) bodies) bodies (if (vector? (first bodies)) (list bodies) bodies) bodies (doall (map expand-fn-body bodies))] (if (nil? name) (cons f bodies) (cons f (cons name bodies))))) (defn- expand-method "Handle a method in a deftype* or reify* form." [m] (rest (expand-fn (cons 'fn* m)))) (defn- expand-deftype "Handle deftype* forms." [[symbol typename classname fields implements interfaces & methods]] (assert (= implements :implements)) (let [expanded-methods (map expand-method methods)] (concat (list symbol typename classname fields implements interfaces) expanded-methods))) (defn- expand-reify "Handle reify* forms." [[symbol interfaces & methods]] (let [expanded-methods (map expand-method methods)] (cons symbol (cons interfaces expanded-methods)))) ; Handlers for special forms that require special treatment. The default ; is expand-args. (defvar- special-form-handlers {'quote identity 'var identity 'def #(expand-args % 2) 'new #(expand-args % 2) 'let* expand-with-bindings 'loop* expand-with-bindings 'fn* expand-fn 'deftype* expand-deftype 'reify* expand-reify}) (defn- expand-list "Recursively expand a form that is a list or a cons." [form] (let [f (first form)] (if (symbol? f) (if (contains? special-forms f) ((get special-form-handlers f expand-args) form) (expand-args form)) (doall (map expand-all form))))) (defn- expand-all "Expand a form recursively." [form] (let [exp (expand form)] (cond (symbol? exp) exp (seq? exp) (expand-list exp) (vector? exp) (into [] (map expand-all exp)) (map? exp) (into {} (map expand-all (seq exp))) :else exp))) (defmacro macrolet "Define local macros that are used in the expansion of exprs. The syntax is the same as for letfn forms." [fn-bindings & exprs] (let [names (map first fn-bindings) name-map (into {} (map (fn [n] [(list 'quote n) n]) names)) macro-map (eval `(letfn ~fn-bindings ~name-map))] (binding [macro-fns (merge macro-fns macro-map) macro-symbols (apply dissoc macro-symbols names)] `(do ~@(doall (map expand-all exprs)))))) (defmacro symbol-macrolet "Define local symbol macros that are used in the expansion of exprs. The syntax is the same as for let forms." [symbol-bindings & exprs] (let [symbol-map (into {} (map vec (partition 2 symbol-bindings))) names (keys symbol-map)] (binding [macro-fns (apply dissoc macro-fns names) macro-symbols (merge macro-symbols symbol-map)] `(do ~@(doall (map expand-all exprs)))))) (defmacro defsymbolmacro "Define a symbol macro. Because symbol macros are not part of Clojure's built-in macro expansion system, they can be used only inside a with-symbol-macros form." [symbol expansion] (let [meta-map (if (meta symbol) (meta symbol) {}) meta-map (assoc meta-map :symbol-macro true)] `(def ~(with-meta symbol meta-map) (quote ~expansion)))) (defmacro with-symbol-macros "Fully expand exprs, including symbol macros." [& exprs] `(do ~@(doall (map expand-all exprs)))) (defmacro deftemplate "Define a macro that expands into forms after replacing the symbols in params (a vector) by the corresponding parameters given in the macro call." [name params & forms] (let [param-map (for [p params] (list (list 'quote p) (gensym))) template-params (vec (map second param-map)) param-map (vec (apply concat param-map)) expansion (list 'list (list 'quote `symbol-macrolet) param-map (list 'quote (cons 'do forms)))] `(defmacro ~name ~template-params ~expansion))) (defn mexpand-1 "Like clojure.core/macroexpand-1, but takes into account symbol macros." [form] (binding [macro-fns {} macro-symbols {} protected-symbols #{}] (expand-1 form))) (defn mexpand "Like clojure.core/macroexpand, but takes into account symbol macros." [form] (binding [macro-fns {} macro-symbols {} protected-symbols #{}] (expand form))) (defn mexpand-all "Perform a full recursive macro expansion of a form." [form] (binding [macro-fns {} macro-symbols {} protected-symbols #{}] (expand-all form))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/macros.clj000066400000000000000000000056061161102570000260730ustar00rootroot00000000000000;; Various useful macros ;; ;; Everybody is invited to add their own little macros here! ;; ;; 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 ^{:author "Konrad Hinsen" :doc "Various small macros"} clojure.contrib.macros) ;; By Konrad Hinsen (defmacro const "Evaluate the constant expression expr at compile time." [expr] (eval expr)) ;; By Konrad Hinsen ; This macro is made obsolete by Clojure's built-in letfn. I renamed it to ; letfn- (to avoid a name clash) but leave it in for a while, since its ; syntax is not quite the same as Clojure's. Expect this to disappear ; in the long run! (defmacro letfn- "OBSOLETE: use clojure.core/letfn A variant of let for local function definitions. fn-bindings consists of name/args/body triples, with (letfn [name args body] ...) being equivalent to (let [name (fn name args body)] ...)." [fn-bindings & exprs] (let [makefn (fn [[name args body]] (list name (list 'fn name args body))) fns (vec (apply concat (map makefn (partition 3 fn-bindings))))] `(let ~fns ~@exprs))) ;; By Konrad Hinsen (defn- unqualified-symbol [s] (let [s-str (str s)] (symbol (subs s-str (inc (.indexOf s-str (int \/))))))) (defn- bound-var? [var] (try (do (deref var) true) (catch java.lang.IllegalStateException e false))) (defn- fns-from-ns [ns ns-symbol] (apply concat (for [[k v] (ns-publics ns) :when (and (bound-var? v) (fn? @v) (not (:macro (meta v))))] [k (symbol (str ns-symbol) (str k))]))) (defn- expand-symbol [ns-or-var-sym] (if (= ns-or-var-sym '*ns*) (fns-from-ns *ns* (ns-name *ns*)) (if-let [ns (find-ns ns-or-var-sym)] (fns-from-ns ns ns-or-var-sym) (list (unqualified-symbol ns-or-var-sym) ns-or-var-sym)))) (defmacro with-direct-linking "EXPERIMENTAL! Compiles the functions in body with direct links to the functions named in symbols, i.e. without a var lookup for each invocation. Symbols is a vector of symbols that name either vars or namespaces. A namespace reference is replaced by the list of all symbols in the namespace that are bound to functions. If symbols is not provided, the default value ['clojure.core] is used. The symbol *ns* can be used to refer to the current namespace." {:arglists '([symbols? & body])} [& body] (let [[symbols body] (if (vector? (first body)) [(first body) (rest body)] [['clojure.core] body]) bindings (vec (mapcat expand-symbol symbols))] `(let ~bindings ~@body))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/map_utils.clj000066400000000000000000000032521161102570000265770ustar00rootroot00000000000000;; Copyright (c) Jason Wolfe. 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. ;; ;; map_utils.clj ;; ;; Utilities for operating on Clojure maps. ;; ;; jason at w01fe dot com ;; Created 25 Feb 2009 (ns ^{:author "Jason Wolfe, Chris Houser", :doc "Utilities for operating on Clojure maps."} clojure.contrib.map-utils) (defmacro lazy-get "Like get, but doesn't evaluate not-found unless it is needed." [map key not-found] `(if-let [pair# (find ~map ~key)] (val pair#) ~not-found)) (defn safe-get "Like get, but throws an exception if the key is not found." [map key] (lazy-get map key (throw (IllegalArgumentException. (format "Key %s not found in %s" key map))))) (defn safe-get-in "Like get-in, but throws an exception if any key is not found." [map ks] (reduce safe-get map ks)) ; by Chouser: (defn deep-merge-with "Like merge-with, but merges maps recursively, applying the given fn only when there's a non-map at a particular level. (deepmerge + {:a {:b {:c 1 :d {:x 1 :y 2}} :e 3} :f 4} {:a {:b {:c 2 :d {:z 9} :z 3} :e 100}}) -> {:a {:b {:z 3, :c 3, :d {:z 9, :x 1, :y 2}}, :e 103}, :f 4}" [f & maps] (apply (fn m [& maps] (if (every? map? maps) (apply merge-with m maps) (apply f maps))) maps)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/math.clj000066400000000000000000000237211161102570000255360ustar00rootroot00000000000000;;; math.clj: math functions that deal intelligently with the various ;;; types in Clojure's numeric tower, as well as math functions ;;; commonly found in Scheme implementations. ;; by Mark Engelberg (mark.engelberg@gmail.com) ;; January 17, 2009 ;; expt - (expt x y) is x to the yth power, returns an exact number ;; if the base is an exact number, and the power is an integer, ;; otherwise returns a double. ;; abs - (abs n) is the absolute value of n ;; gcd - (gcd m n) returns the greatest common divisor of m and n ;; lcm - (lcm m n) returns the least common multiple of m and n ;; The behavior of the next three functions on doubles is consistent ;; with the behavior of the corresponding functions ;; in Java's Math library, but on exact numbers, returns an integer. ;; floor - (floor n) returns the greatest integer less than or equal to n. ;; If n is an exact number, floor returns an integer, ;; otherwise a double. ;; ceil - (ceil n) returns the least integer greater than or equal to n. ;; If n is an exact number, ceil returns an integer, ;; otherwise a double. ;; round - (round n) rounds to the nearest integer. ;; round always returns an integer. round rounds up for values ;; exactly in between two integers. ;; sqrt - Implements the sqrt behavior I'm accustomed to from PLT Scheme, ;; specifically, if the input is an exact number, and is a square ;; of an exact number, the output will be exact. The downside ;; is that for the common case (inexact square root), some extra ;; computation is done to look for an exact square root first. ;; So if you need blazingly fast square root performance, and you ;; know you're just going to need a double result, you're better ;; off calling java's Math/sqrt, or alternatively, you could just ;; convert your input to a double before calling this sqrt function. ;; If Clojure ever gets complex numbers, then this function will ;; need to be updated (so negative inputs yield complex outputs). ;; exact-integer-sqrt - Implements a math function from the R6RS Scheme ;; standard. (exact-integer-sqrt k) where k is a non-negative integer, ;; returns [s r] where k = s^2+r and k < (s+1)^2. In other words, it ;; returns the floor of the square root and the "remainder". (ns ^{:author "Mark Engelberg", :doc "Math functions that deal intelligently with the various types in Clojure's numeric tower, as well as math functions commonly found in Scheme implementations. expt - (expt x y) is x to the yth power, returns an exact number if the base is an exact number, and the power is an integer, otherwise returns a double. abs - (abs n) is the absolute value of n gcd - (gcd m n) returns the greatest common divisor of m and n lcm - (lcm m n) returns the least common multiple of m and n The behavior of the next three functions on doubles is consistent with the behavior of the corresponding functions in Java's Math library, but on exact numbers, returns an integer. floor - (floor n) returns the greatest integer less than or equal to n. If n is an exact number, floor returns an integer, otherwise a double. ceil - (ceil n) returns the least integer greater than or equal to n. If n is an exact number, ceil returns an integer, otherwise a double. round - (round n) rounds to the nearest integer. round always returns an integer. round rounds up for values exactly in between two integers. sqrt - Implements the sqrt behavior I'm accustomed to from PLT Scheme, specifically, if the input is an exact number, and is a square of an exact number, the output will be exact. The downside is that for the common case (inexact square root), some extra computation is done to look for an exact square root first. So if you need blazingly fast square root performance, and you know you're just going to need a double result, you're better off calling java's Math/sqrt, or alternatively, you could just convert your input to a double before calling this sqrt function. If Clojure ever gets complex numbers, then this function will need to be updated (so negative inputs yield complex outputs). exact-integer-sqrt - Implements a math function from the R6RS Scheme standard. (exact-integer-sqrt k) where k is a non-negative integer, returns [s r] where k = s^2+r and k < (s+1)^2. In other words, it returns the floor of the square root and the "remainder". "} clojure.contrib.math) (derive ::integer ::exact) (derive java.lang.Integer ::integer) (derive java.math.BigInteger ::integer) (derive java.lang.Long ::integer) (derive java.math.BigDecimal ::exact) (derive clojure.lang.Ratio ::exact) (derive java.lang.Double ::inexact) (derive java.lang.Float ::inexact) (defmulti ^{:arglists '([base pow]) :doc "(expt base pow) is base to the pow power. Returns an exact number if the base is an exact number and the power is an integer, otherwise returns a double."} expt (fn [x y] [(class x) (class y)])) (defn- expt-int [base pow] (loop [n pow, y (num 1), z base] (let [t (bit-and n 1), n (bit-shift-right n 1)] (cond (zero? t) (recur n y (* z z)) (zero? n) (* z y) :else (recur n (* z y) (* z z)))))) (defmethod expt [::exact ::integer] [base pow] (cond (pos? pow) (expt-int base pow) (zero? pow) 1 :else (/ 1 (expt-int base (- pow))))) (defmethod expt :default [base pow] (Math/pow base pow)) (defn abs "(abs n) is the absolute value of n" [n] (cond (not (number? n)) (throw (IllegalArgumentException. "abs requires a number")) (neg? n) (- n) :else n)) (defmulti ^{:arglists '([n]) :doc "(floor n) returns the greatest integer less than or equal to n. If n is an exact number, floor returns an integer, otherwise a double."} floor class) (defmethod floor ::integer [n] n) (defmethod floor java.math.BigDecimal [n] (.. n (setScale 0 BigDecimal/ROUND_FLOOR) (toBigInteger))) (defmethod floor clojure.lang.Ratio [n] (if (pos? n) (quot (. n numerator) (. n denominator)) (dec (quot (. n numerator) (. n denominator))))) (defmethod floor :default [n] (Math/floor n)) (defmulti ^{:arglists '([n]) :doc "(ceil n) returns the least integer greater than or equal to n. If n is an exact number, ceil returns an integer, otherwise a double."} ceil class) (defmethod ceil ::integer [n] n) (defmethod ceil java.math.BigDecimal [n] (.. n (setScale 0 BigDecimal/ROUND_CEILING) (toBigInteger))) (defmethod ceil clojure.lang.Ratio [n] (if (pos? n) (inc (quot (. n numerator) (. n denominator))) (quot (. n numerator) (. n denominator)))) (defmethod ceil :default [n] (Math/ceil n)) (defmulti ^{:arglists '([n]) :doc "(round n) rounds to the nearest integer. round always returns an integer. Rounds up for values exactly in between two integers."} round class) (defmethod round ::integer [n] n) (defmethod round java.math.BigDecimal [n] (floor (+ n 0.5M))) (defmethod round clojure.lang.Ratio [n] (floor (+ n 1/2))) (defmethod round :default [n] (Math/round n)) (defn gcd "(gcd a b) returns the greatest common divisor of a and b" [a b] (if (or (not (integer? a)) (not (integer? b))) (throw (IllegalArgumentException. "gcd requires two integers")) (loop [a (abs a) b (abs b)] (if (zero? b) a, (recur b (mod a b)))))) (defn lcm "(lcm a b) returns the least common multiple of a and b" [a b] (when (or (not (integer? a)) (not (integer? b))) (throw (IllegalArgumentException. "lcm requires two integers"))) (cond (zero? a) 0 (zero? b) 0 :else (abs (* b (quot a (gcd a b)))))) ; Length of integer in binary, used as helper function for sqrt. (defmulti ^{:private true} integer-length class) (defmethod integer-length java.lang.Integer [n] (count (Integer/toBinaryString n))) (defmethod integer-length java.lang.Long [n] (count (Long/toBinaryString n))) (defmethod integer-length java.math.BigInteger [n] (count (. n toString 2))) ;; Produces the largest integer less than or equal to the square root of n ;; Input n must be a non-negative integer (defn- integer-sqrt [n] (cond (> n 24) (let [n-len (integer-length n)] (loop [init-value (if (even? n-len) (bit-shift-left 1 (bit-shift-right n-len 1)) (bit-shift-left 2 (bit-shift-right n-len 1)))] (let [iterated-value (bit-shift-right (+ init-value (quot n init-value)) 1)] (if (>= iterated-value init-value) init-value (recur iterated-value))))) (> n 15) 4 (> n 8) 3 (> n 3) 2 (> n 0) 1 (> n -1) 0)) (defn exact-integer-sqrt "(exact-integer-sqrt n) expects a non-negative integer n, and returns [s r] where n = s^2+r and n < (s+1)^2. In other words, it returns the floor of the square root and the 'remainder'. For example, (exact-integer-sqrt 15) is [3 6] because 15 = 3^2+6." [n] (if (or (not (integer? n)) (neg? n)) (throw (IllegalArgumentException. "exact-integer-sqrt requires a non-negative integer")) (let [isqrt (integer-sqrt n), error (- n (* isqrt isqrt))] [isqrt error]))) (defmulti ^{:arglists '([n]) :doc "Square root, but returns exact number if possible."} sqrt class) (defmethod sqrt ::integer [n] (if (neg? n) Double/NaN (let [isqrt (integer-sqrt n), error (- n (* isqrt isqrt))] (if (zero? error) isqrt (Math/sqrt n))))) (defmethod sqrt clojure.lang.Ratio [n] (if (neg? n) Double/NaN (let [numerator (.numerator n), denominator (.denominator n), sqrtnum (sqrt numerator)] (if (float? sqrtnum) (Math/sqrt n) (let [sqrtden (sqrt denominator)] (if (float? sqrtnum) (Math/sqrt n) (/ sqrtnum sqrtden))))))) (defmethod sqrt java.math.BigDecimal [n] (if (neg? n) Double/NaN (let [frac (rationalize n), sqrtfrac (sqrt frac)] (if (ratio? sqrtfrac) (/ (BigDecimal. (.numerator sqrtfrac)) (BigDecimal. (.denominator sqrtfrac))) sqrtfrac)))) (defmethod sqrt :default [n] (Math/sqrt n)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/miglayout.clj000066400000000000000000000053331161102570000266160ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; clojure.contrib.miglayout ;; ;; Clojure support for the MiGLayout layout manager ;; http://www.miglayout.com/ ;; ;; Example: ;; ;; (use '[clojure.contrib.miglayout.test :as mlt :only ()]) ;; (dotimes [i 5] (mlt/run-test i)) ;; ;; scgilardi (gmail) ;; Created 5 October 2008 (ns ^{:author "Stephen C. Gilardi", :doc "Clojure support for the MiGLayout layout manager http://www.miglayout.com/ Example: (use '[clojure.contrib.miglayout.test :as mlt :only ()]) (dotimes [i 5] (mlt/run-test i)) "} clojure.contrib.miglayout (:import javax.swing.JComponent) (:use clojure.contrib.miglayout.internal)) (defn miglayout "Adds java.awt.Components to a javax.swing.JComponent with constraints formatted for the MiGLayout layout manager. Arguments: container [item constraint*]* - container: the container for the specified components, its layout manager will be set to a new instance of MigLayout - an inline series of items and constraints--each item may be followed by zero or more constraints. Item: - An item is either a Component or one of the keywords :layout :column or :row. Constraints for a keyword item affect the entire layout. Constraint: string, keyword, vector, map, or set - A string specifies one or more constraints each with zero or more arguments. - A keyword specifies a single constraint without arguments - A vector specifies a single constraint with one or more arguments - A map specifies one or more constraints as keys, each mapped to a single argument - A set groups two or more constraints, each a string, keyword, vector, map, or set Any items marked with an \"id\" constraint will be included in a map from id to component attached to the container. The map can be retrieved using clojure.contrib.miglayout/components." [^JComponent container & args] (let [item-constraints (apply parse-item-constraints args) {:keys [keywords components]} item-constraints {:keys [layout column row]} keywords] (do-layout container layout column row components))) (defn components "Returns a map from id (a keyword) to component for all components with an id constraint set" [^JComponent container] (get-components container)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/miglayout/000077500000000000000000000000001161102570000261205ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/miglayout/internal.clj000066400000000000000000000101271161102570000304270ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; clojure.contrib.miglayout.internal ;; ;; Internal functions for 'clojure.contrib.miglayout ;; ;; scgilardi (gmail) ;; Created 13 October 2008 (ns clojure.contrib.miglayout.internal (:import (clojure.lang RT Reflector) java.awt.Component javax.swing.JComponent) (:use (clojure.contrib [core :only (new-by-name)] [except :only (throwf)] [fcase :only (fcase)] [string :only (as-str)]))) (def MigLayout "net.miginfocom.swing.MigLayout") (def LayoutCallback "net.miginfocom.layout.LayoutCallback") (def ConstraintParser "net.miginfocom.layout.ConstraintParser") (declare format-constraints) (defn format-constraint "Returns a vector of vectors representing one or more constraints separated by commas. Constraints may be specified in Clojure using strings, keywords, vectors, maps, and/or sets." [c] [[", "] (fcase #(%1 %2) c string? [c] keyword? [c] vector? (interpose " " c) map? (apply concat (interpose [", "] (map #(interpose " " %) c))) set? (apply concat (interpose [", "] (map format-constraints c))) (throwf IllegalArgumentException "unrecognized constraint: %s (%s)" c (class c)))]) (defn format-constraints "Returns a string representing all the constraints for one keyword-item or component formatted for miglayout." [& constraints] (let [formatted (apply str (map as-str (rest (reduce concat [] (mapcat format-constraint constraints)))))] ;; (prn formatted) formatted)) (defn component? "Returns true if x is a java.awt.Component" [x] (instance? Component x)) (defn constraint? "Returns true if x is not a keyword-item or component" [x] (not (or (component? x) (#{:layout :column :row} x)))) (defn parse-item-constraints "Iterates over args and builds a map containing values associated with :keywords and :components. The value for :keywords is a map from keyword items to constraints strings. The value for :components is a vector of vectors each associating a component with its constraints string." [& args] (loop [[item & args] args item-constraints {:keywords {} :components []}] (if item (let [[constraints args] (split-with constraint? args)] (recur args (update-in item-constraints [(if (component? item) :components :keywords)] conj [item (apply format-constraints constraints)]))) item-constraints))) (defn parse-component-constraint "Parses a component constraint string returning a CC object" [constraint] (Reflector/invokeStaticMethod ConstraintParser "parseComponentConstraint" (into-array [constraint]))) (defn add-components "Adds components with constraints to a container" [^JComponent container components] (loop [[[^Component component constraint] & components] components id-map nil] (if component (let [cc (parse-component-constraint constraint)] (.add container component cc) (recur components (if-let [id (.getId cc)] (assoc id-map (keyword id) component) id-map))) (doto container (.putClientProperty ::components id-map))))) (defn get-components "Returns a map from id to component for all components with an id" [^JComponent container] (.getClientProperty container ::components)) (defn do-layout "Attaches a MigLayout layout manager to container and adds components with constraints" [^JComponent container layout column row components] (doto container (.setLayout (new-by-name MigLayout layout column row)) (add-components components))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/mmap.clj000066400000000000000000000061461161102570000255410ustar00rootroot00000000000000; Copyright (c) Chris Houser, April 2008. 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. ; Functions for memory-mapping files, plus some functions that use a ; mmaped file for "normal" activies -- slurp, load-file, etc. (ns ^{:author "Chris Houser", :doc "Functions for memory-mapping files, plus some functions that use a mmaped file for \"normal\" activies -- slurp, load-file, etc."} clojure.contrib.mmap (:refer-clojure :exclude (slurp load-file)) (:import (java.nio ByteBuffer CharBuffer) (java.io PushbackReader InputStream InputStreamReader FileInputStream))) ;(set! *warn-on-reflection* true) (def READ_ONLY ^{:private true} (java.nio.channels.FileChannel$MapMode/READ_ONLY)) (defn mmap "Memory-map the file named f. Returns a ByteBuffer." [f] (let [channel (.getChannel (FileInputStream. f))] (.map channel READ_ONLY 0 (.size channel)))) (defn slurp "Reads the file named by f and returns it as a string." [^String f] (.. java.nio.charset.Charset (forName "UTF-8") (newDecoder) (decode (mmap f)))) (defn buffer-stream "Returns an InputStream for a ByteBuffer, such as returned by mmap." [^ByteBuffer buf] (proxy [InputStream] [] (available [] (.remaining buf)) (read ([] (if (.hasRemaining buf) (.get buf) -1)) ([dst offset len] (let [actlen (min (.remaining buf) len)] (.get buf dst offset actlen) (if (< actlen 1) -1 actlen)))))) (defn load-file [f] "Like clojure.lang/load-file, but uses mmap internally." (with-open [rdr (-> f mmap buffer-stream InputStreamReader. PushbackReader.)] (load-reader rdr))) (comment (alias 'mmap 'clojure.contrib.mmap) (alias 'core 'clojure.core) ;--- ; zip_filter.clj is 95KB (def tf "/home/chouser/build/clojure/src/clj/clojure/core.clj") (println "\nload-file" tf) (time (dotimes [_ 5] (core/load-file tf))) ; 5420.177813 msecs (time (dotimes [_ 5] (mmap/load-file tf))) ; 7946.854434 msecs -- not so good ;--- ; kern.log.0 is 961KB (def tf "/var/log/kern.log.0") (println "\nslurp" tf) (time (dotimes [_ 10] (.length (core/slurp tf)))) ; 435.767226 msecs (time (dotimes [_ 10] (.length (mmap/slurp tf)))) ; 93.176858 msecs ;--- ; kern.log.0 is 961KB (def tf "/var/log/kern.log.0") (println "\nregex slurp large" tf) (time (dotimes [_ 10] (count (re-seq #"EXT3.*" (core/slurp tf))))) ; 416 (time (dotimes [_ 10] (count (re-seq #"EXT3.*" (mmap/slurp tf))))) ; 101 ;--- ; mmap.clj is about 3.1KB (def tf "/home/chouser/proj/clojure-contrib/src/clojure/contrib/mmap.clj") (println "\nregex slurp small" tf) (time (dotimes [_ 1000] (count (re-seq #"defn \S*" (core/slurp tf))))) ; 308 (time (dotimes [_ 1000] (count (re-seq #"defn \S*" (mmap/slurp tf))))) ; 198 ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/mock.clj000066400000000000000000000266441161102570000255450ustar00rootroot00000000000000;;; clojure.contrib.mock.clj: mocking/expectation framework for Clojure ;; by Matt Clark ;; Copyright (c) Matt Clark, 2009. 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). ;; 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. ;;------------------------------------------------------------------------------ (comment ;; This is a simple function mocking library I accidentally wrote as a side ;; effect of trying to write an opengl library in clojure. This is loosely ;; based on various ruby and java mocking frameworks I have used in the past ;; such as mockito, easymock, and whatever rspec uses. ;; ;; expect uses bindings to wrap the functions that are being tested and ;; then validates the invocation count at the end. The expect macro is the ;; main entry point and it is given a vector of binding pairs. ;; The first of each pair names the dependent function you want to override, ;; while the second is a hashmap containing the mock description, usually ;; created via the simple helper methods described below. ;; ;; Usage: ;; ;; there are one or more dependent functions: (defn dep-fn1 [] "time consuming calculation in 3rd party library") (defn dep-fn2 [x] "function with undesirable side effects while testing") ;; then we have the code under test that calls these other functions: (defn my-code-under-test [] (dep-fn1) (dep-fn2 "a") (+ 2 2)) ;; to test this code, we simply surround it with an expect macro within ;; the test: (expect [dep-fn1 (times 1) dep-fn2 (times 1 (has-args [#(= "a" %)]))] (my-code-under-test)) ;; When an expectation fails during execution of the function under test, ;; an error condition function is called with the name of the function ;; being mocked, the expected form and the actual value. These ;; error functions can be overridden to allow easy integration into ;; test frameworks such as test-is by reporting errors in the function ;; overrides. ) ;; end comment (ns clojure.contrib.mock ^{:author "Matt Clark", :doc "function mocking/expectations for Clojure" } (:use [clojure.contrib.seq :only (positions)] [clojure.contrib.def :only (defmacro-)])) ;;------------------------------------------------------------------------------ ;; These are the error condition functions. Override them to integrate into ;; the test framework of your choice, or to simply customize error handling. (defn report-problem {:dynamic true} ([function expected actual] (report-problem function expected actual "Expectation not met.")) ([function expected actual message] (prn (str message " Function name: " function " expected: " expected " actual: " actual)))) (defn no-matching-function-signature {:dynamic true} [function expected actual] (report-problem function expected actual "No matching real function signature for given argument count.")) (defn unexpected-args {:dynamic true} [function expected actual i] (report-problem function expected actual (str "Argument " i " has an unexpected value for function."))) (defn incorrect-invocation-count {:dynamic true} [function expected actual] (report-problem function expected actual "Unexpected invocation count.")) ;;------------------------------------------------------------------------------ ;; Internal Functions - ignore these (defn- has-arg-count-match? "Given the sequence of accepted argument vectors for a function, returns true if at least one matches the given-count value." [arg-lists given-count] (some #(let [[ind] (positions #{'&} %)] (if ind (>= given-count ind) (= (count %) given-count))) arg-lists)) (defn has-matching-signature? "Calls no-matching-function-signature if no match is found for the given function. If no argslist meta data is available for the function, it is not called." [fn-name args] (let [arg-count (count args) arg-lists (:arglists (meta (resolve fn-name)))] (if (and arg-lists (not (has-arg-count-match? arg-lists arg-count))) (no-matching-function-signature fn-name arg-lists args)))) (defn make-arg-checker "Creates the argument verifying function for a replaced dependency within the expectation bound scope. These functions take the additional argument of the name of the replaced function, then the rest of their args. It is designed to be called from the mock function generated in the first argument of the mock info object created by make-mock." [arg-preds arg-pred-forms] (let [sanitized-preds (map (fn [v] (if (fn? v) v #(= v %))) arg-preds)] (fn [fn-name & args] (every? true? (map (fn [pred arg pred-form i] (if (pred arg) true (unexpected-args fn-name pred-form arg i))) sanitized-preds args arg-pred-forms (iterate inc 0)))))) (defn make-count-checker "creates the count checker that is invoked at the end of an expectation, after the code under test has all been executed. The function returned takes the name of the associated dependency and the invocation count as arguments." [pred pred-form] (let [pred-fn (if (integer? pred) #(= pred %) pred)] (fn [fn-name v] (if (pred-fn v) true (incorrect-invocation-count fn-name pred-form v))))) ; Borrowed from clojure core. Remove if this ever becomes public there. (defmacro- assert-args [fnname & pairs] `(do (when-not ~(first pairs) (throw (IllegalArgumentException. ~(str fnname " requires " (second pairs))))) ~(let [more (nnext pairs)] (when more (list* `assert-args fnname more))))) (defn make-mock "creates a vector containing the following information for the named function: 1. dependent function replacement - verifies signature, calls arg checker, increases count, returns return value. 2. an atom containing the invocation count 3. the invocation count checker function 4. a symbol of the name of the function being replaced." [fn-name expectation-hash] (assert-args make-mock (map? expectation-hash) "a map of expectations") (let [arg-checker (or (expectation-hash :has-args) (fn [& args] true)) count-atom (atom 0) ret-fn (or (expectation-hash :calls) (fn [& args] (expectation-hash :returns)))] [(fn [& args] (has-matching-signature? fn-name args) (apply arg-checker fn-name args) (swap! count-atom inc) (apply ret-fn args)) count-atom (or (expectation-hash :times) (fn [fn-name v] true)) fn-name])) (defn validate-counts "given the sequence of all mock data for the expectation, simply calls the count checker for each dependency." [mock-data] (doseq [[mfn i checker fn-name] mock-data] (checker fn-name @i))) (defn ^{:private true} make-bindings [expect-bindings mock-data-sym] `[~@(interleave (map #(first %) (partition 2 expect-bindings)) (map (fn [i] `(nth (nth ~mock-data-sym ~i) 0)) (range (quot (count expect-bindings) 2))))]) ;;------------------------------------------------------------------------------ ;; These are convenience functions to improve the readability and use of this ;; library. Useful in expressions such as: ;; (expect [dep-fn1 (times (more-than 1) (returns 15)) etc) (defn once [x] (= 1 x)) (defn never [x] (zero? x)) (defn more-than [x] #(< x %)) (defn less-than [x] #(> x %)) (defn between [x y] #(and (< x %) (> y %))) ;;------------------------------------------------------------------------------ ;; The following functions can be used to build up the expectation hash. (defn returns "Creates or associates to an existing expectation hash the :returns key with a value to be returned by the expectation after a successful invocation matching its expected arguments (if applicable). Usage: (returns ret-value expectation-hash?)" ([val] (returns val {})) ([val expectation-hash] (assoc expectation-hash :returns val))) (defn calls "Creates or associates to an existing expectation hash the :calls key with a function that will be called with the given arguments. The return value from this function will be returned returned by the expected function. If both this and returns are specified, the return value of \"calls\" will have precedence. Usage: (calls some-fn expectation-hash?)" ([val] (calls val {})) ([val expectation-hash] (assoc expectation-hash :calls val))) (defmacro has-args "Creates or associates to an existing expectation hash the :has-args key with a value corresponding to a function that will either return true if its argument expectations are met or throw an exception with the details of the first failed argument it encounters. Only specify as many predicates as you are interested in verifying. The rest of the values are safely ignored. Usage: (has-args [arg-pred-1 arg-pred-2 ... arg-pred-n] expectation-hash?)" ([arg-pred-forms] `(has-args ~arg-pred-forms {})) ([arg-pred-forms expect-hash-form] (assert-args has-args (vector? arg-pred-forms) "a vector of argument predicates") `(assoc ~expect-hash-form :has-args (make-arg-checker ~arg-pred-forms '~arg-pred-forms)))) (defmacro times "Creates or associates to an existing expectation hash the :times key with a value corresponding to a predicate function which expects an integer value. This function can either be specified as the first argument to times or can be the result of calling times with an integer argument, in which case the predicate will default to being an exact match. This predicate is called at the end of an expect expression to validate that an expected dependency function was called the expected number of times. Usage: (times n) (times #(> n %)) (times n expectation-hash)" ([times-fn] `(times ~times-fn {})) ([times-fn expectation-hash] `(assoc ~expectation-hash :times (make-count-checker ~times-fn '~times-fn)))) ;------------------------------------------------------------------------------- ; The main expect macro. (defmacro expect "Use expect to redirect calls to dependent functions that are made within the code under test. Instead of calling the functions that would normally be used, temporary stubs are used, which can verify function parameters and call counts. Return values can also be specified as needed. Usage: (expect [dep-fn (has-args [arg-pred1] (times n (returns x)))] (function-under-test a b c))" [expect-bindings & body] (assert-args expect (vector? expect-bindings) "a vector of expectation bindings" (even? (count expect-bindings)) "an even number of forms in expectation bindings") (let [mock-data (gensym "mock-data_")] `(let [~mock-data (map (fn [args#] (apply clojure.contrib.mock/make-mock args#)) ~(cons 'list (map (fn [[n m]] (vector (list 'quote n) m)) (partition 2 expect-bindings))))] (binding ~(make-bindings expect-bindings mock-data) ~@body) (clojure.contrib.mock/validate-counts ~mock-data) true))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/mock/000077500000000000000000000000001161102570000250375ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/mock/test_adapter.clj000066400000000000000000000024241161102570000302120ustar00rootroot00000000000000;;; test_adapter.clj: clojure.test adapter for mocking/expectation framework for Clojure ;; by Matt Clark ;; Copyright (c) Matt Clark, 2009. 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). ;; 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.contrib.mock.test-adapter (:require [clojure.contrib.mock :as mock]) (:use clojure.test clojure.contrib.ns-utils)) (immigrate 'clojure.contrib.mock) (defn report-problem "This function is designed to be used in a binding macro to override the report-problem function in clojure.contrib.mock. Instead of printing the error to the console, the error is logged via clojure.test." {:dynamic true} [fn-name expected actual msg] (report {:type :fail, :message (str msg " Function name: " fn-name), :expected expected, :actual actual})) (defmacro expect [& body] "Use this macro instead of the standard c.c.mock expect macro to have failures reported through clojure.test." `(binding [mock/report-problem report-problem] (mock/expect ~@body))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/monadic_io_streams.clj000066400000000000000000000112111161102570000304330ustar00rootroot00000000000000;; Monadic I/O ;; by Konrad Hinsen ;; last updated June 24, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Monadic I/O with Java input/output streams Defines monadic I/O statements to be used in a state monad with an input or output stream as the state. The macro monadic-io creates a stream, runs a monadic I/O statement on it, and closes the stream. This structure permits the definition of purely functional compound I/O statements which are applied to streams that can never escape from the monadic statement sequence."} clojure.contrib.monadic-io-streams (:refer-clojure :exclude (read-line print println flush)) (:use [clojure.contrib.monads :only (with-monad domonad state-m state-m-until)]) (:use [clojure.contrib.generic.functor :only (fmap)]) (:use [clojure.java.io :only (reader writer)])) ; ; Wrap the state into a closure to make sure that "evil" code ; can't obtain the stream using fetch-state and manipulate it. ; (let [key (Object.) lock (fn [state] (fn [x] (if (identical? x key) state nil))) unlock (fn [state] (state key))] ; ; Basic stream I/O statements as provided by Java ; (defn read-char "Read a single character" [] (fn [s] [(.read (unlock s)) s])) (defn read-line "Read a single line" [] (fn [s] [(.readLine (unlock s)) s])) (defn skip-chars "Skip n characters" [n] (fn [s] [(.skip (unlock s) n) s])) (defn write "Write text (a string)" [^String text] (fn [s] [(.write (unlock s) text) s])) (defn flush "Flush" [] (fn [s] [(.flush (unlock s)) s])) (defn print "Print obj" [obj] (fn [s] [(.print (unlock s) obj) s])) (defn println "Print obj followed by a newline" ([] (fn [s] [(.println (unlock s)) s])) ([obj] (fn [s] [(.println (unlock s) obj) s]))) ; ; Inject I/O streams into monadic I/O statements ; (defn with-reader "Create a reader from reader-spec, run the monadic I/O statement on it, and close the reader. reader-spec can be any object accepted by clojure.contrib.io/reader." [reader-spec statement] (with-open [r (reader reader-spec)] (first (statement (lock r))))) (defn with-writer "Create a writer from writer-spec, run the monadic I/O statement on it, and close the writer. writer-spec can be any object accepted by clojure.contrib.io/writer." [writer-spec statement] (with-open [w (writer writer-spec)] (first (statement (lock w))))) (defn with-io-streams "Open one or more streams as specified by io-spec, run a monadic I/O statement on them, and close the streams. io-spec is a binding-like vector in which each stream is specified by three element: a keyword by which the stream can be referred to, the stream mode (:read or :write), and a stream specification as accepted by clojure.contrib.io/reader (mode :read) or clojure.contrib.io/writer (mode :write). The statement is run on a state which is a map from keywords to corresponding streams. Single-stream monadic I/O statements must be wrapped with clojure.contrib.monads/with-state-field." [io-specs statement] (letfn [(run-io [io-specs state statement] (if (zero? (count io-specs)) (first (statement state)) (let [[[key mode stream-spec] & r] io-specs opener (cond (= mode :read) reader (= mode :write) writer :else (throw (Exception. "Mode must be :read or :write")))] (with-open [stream (opener stream-spec)] (run-io r (assoc state key (lock stream)) statement)))))] (run-io (partition 3 io-specs) {} statement)))) ; ; Compound I/O statements ; (with-monad state-m (defn- add-line "Read one line and add it to the end of the vector lines. Return [lines eof], where eof is an end-of-file flag. The input eof argument is not used." [[lines eof]] (domonad [line (read-line)] (if (nil? line) [lines true] [(conj lines line) false]))) (defn read-lines "Read all lines and return them in a vector" [] (domonad [[lines eof] (state-m-until second add-line [[] false])] lines))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/monads.clj000066400000000000000000000465131161102570000260720ustar00rootroot00000000000000;; Monads in Clojure ;; by Konrad Hinsen ;; last updated June 30, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :see-also [["http://onclojure.com/2009/03/05/a-monad-tutorial-for-clojure-programmers-part-1/" "Monad tutorial part 1"] ["http://onclojure.com/2009/03/06/a-monad-tutorial-for-clojure-programmers-part-2/" "Monad tutorial part 2"] ["http://onclojure.com/2009/03/23/a-monad-tutorial-for-clojure-programmers-part-3/" "Monad tutorial part 3"] ["http://onclojure.com/2009/04/24/a-monad-tutorial-for-clojure-programmers-part-4/" "Monad tutorial part 4"] ["http://intensivesystems.net/tutorials/monads_101.html" "Monads in Clojure part 1"] ["http://intensivesystems.net/tutorials/monads_201.html" "Monads in Clojure part 2"]] :doc "This library contains the most commonly used monads as well as macros for defining and using monads and useful monadic functions."} clojure.contrib.monads (:require [clojure.contrib.accumulators]) (:use [clojure.contrib.macro-utils :only (with-symbol-macros defsymbolmacro)]) (:use [clojure.contrib.def :only (name-with-attributes)])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Defining monads ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro monad "Define a monad by defining the monad operations. The definitions are written like bindings to the monad operations m-bind and m-result (required) and m-zero and m-plus (optional)." [operations] `(let [~'m-bind ::undefined ~'m-result ::undefined ~'m-zero ::undefined ~'m-plus ::undefined ~@operations] {:m-result ~'m-result :m-bind ~'m-bind :m-zero ~'m-zero :m-plus ~'m-plus})) (defmacro defmonad "Define a named monad by defining the monad operations. The definitions are written like bindings to the monad operations m-bind and m-result (required) and m-zero and m-plus (optional)." ([name doc-string operations] (let [doc-name (with-meta name {:doc doc-string})] `(defmonad ~doc-name ~operations))) ([name operations] `(def ~name (monad ~operations)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Using monads ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- add-monad-step "Add a monad comprehension step before the already transformed monad comprehension expression mexpr." [mexpr step] (let [[bform expr] step] (cond (identical? bform :when) `(if ~expr ~mexpr ~'m-zero) (identical? bform :let) `(let ~expr ~mexpr) :else (list 'm-bind expr (list 'fn [bform] mexpr))))) (defn- monad-expr "Transforms a monad comprehension, consisting of a list of steps and an expression defining the final value, into an expression chaining together the steps using :bind and returning the final value using :result. The steps are given as a vector of binding-variable/monadic-expression pairs." [steps expr] (when (odd? (count steps)) (throw (Exception. "Odd number of elements in monad comprehension steps"))) (let [rsteps (reverse (partition 2 steps)) [lr ls] (first rsteps)] (if (= lr expr) ; Optimization: if the result expression is equal to the result ; of the last computation step, we can eliminate an m-bind to ; m-result. (reduce add-monad-step ls (rest rsteps)) ; The general case. (reduce add-monad-step (list 'm-result expr) rsteps)))) (defmacro with-monad "Evaluates an expression after replacing the keywords defining the monad operations by the functions associated with these keywords in the monad definition given by name." [monad & exprs] `(let [name# ~monad ~'m-bind (:m-bind name#) ~'m-result (:m-result name#) ~'m-zero (:m-zero name#) ~'m-plus (:m-plus name#)] (with-symbol-macros ~@exprs))) (defmacro domonad "Monad comprehension. Takes the name of a monad, a vector of steps given as binding-form/monadic-expression pairs, and a result value specified by expr. The monadic-expression terms can use the binding variables of the previous steps. If the monad contains a definition of m-zero, the step list can also contain conditions of the form :when p, where the predicate p can contain the binding variables from all previous steps. A clause of the form :let [binding-form expr ...], where the bindings are given as a vector as for the use in let, establishes additional bindings that can be used in the following steps." ([steps expr] (monad-expr steps expr)) ([name steps expr] (let [mexpr (monad-expr steps expr)] `(with-monad ~name ~mexpr)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Defining functions used with monads ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro defmonadfn "Like defn, but for functions that use monad operations and are used inside a with-monad block." {:arglists '([name docstring? attr-map? args expr] [name docstring? attr-map? (args expr) ...])} [name & options] (let [[name options] (name-with-attributes name options) fn-name (symbol (str *ns*) (format "m+%s+m" (str name))) make-fn-body (fn [args expr] (list (vec (concat ['m-bind 'm-result 'm-zero 'm-plus] args)) (list `with-symbol-macros expr)))] (if (list? (first options)) ; multiple arities (let [arglists (map first options) exprs (map second options) ] `(do (defsymbolmacro ~name (partial ~fn-name ~'m-bind ~'m-result ~'m-zero ~'m-plus)) (defn ~fn-name ~@(map make-fn-body arglists exprs)))) ; single arity (let [[args expr] options] `(do (defsymbolmacro ~name (partial ~fn-name ~'m-bind ~'m-result ~'m-zero ~'m-plus)) (defn ~fn-name ~@(make-fn-body args expr))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Commonly used monad functions ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Define the four basic monad operations as symbol macros that ; expand to their unqualified symbol equivalents. This makes it possible ; to use them inside macro templates without having to quote them. (defsymbolmacro m-result m-result) (defsymbolmacro m-bind m-bind) (defsymbolmacro m-zero m-zero) (defsymbolmacro m-plus m-plus) (defmacro m-lift "Converts a function f of n arguments into a function of n monadic arguments returning a monadic value." [n f] (let [expr (take n (repeatedly #(gensym "x_"))) vars (vec (take n (repeatedly #(gensym "mv_")))) steps (vec (interleave expr vars))] (list `fn vars (monad-expr steps (cons f expr))))) (defmonadfn m-join "Converts a monadic value containing a monadic value into a 'simple' monadic value." [m] (m-bind m identity)) (defmonadfn m-fmap "Bind the monadic value m to the function returning (f x) for argument x" [f m] (m-bind m (fn [x] (m-result (f x))))) (defmonadfn m-seq "'Executes' the monadic values in ms and returns a sequence of the basic values contained in them." [ms] (reduce (fn [q p] (m-bind p (fn [x] (m-bind q (fn [y] (m-result (cons x y)))) ))) (m-result '()) (reverse ms))) (defmonadfn m-map "'Executes' the sequence of monadic values resulting from mapping f onto the values xs. f must return a monadic value." [f xs] (m-seq (map f xs))) (defmonadfn m-chain "Chains together monadic computation steps that are each functions of one parameter. Each step is called with the result of the previous step as its argument. (m-chain (step1 step2)) is equivalent to (fn [x] (domonad [r1 (step1 x) r2 (step2 r1)] r2))." [steps] (reduce (fn m-chain-link [chain-expr step] (fn [v] (m-bind (chain-expr v) step))) m-result steps)) (defmonadfn m-reduce "Return the reduction of (m-lift 2 f) over the list of monadic values mvs with initial value (m-result val)." ([f mvs] (if (empty? mvs) (m-result (f)) (let [m-f (m-lift 2 f)] (reduce m-f mvs)))) ([f val mvs] (let [m-f (m-lift 2 f) m-val (m-result val)] (reduce m-f m-val mvs)))) (defmonadfn m-until "While (p x) is false, replace x by the value returned by the monadic computation (f x). Return (m-result x) for the first x for which (p x) is true." [p f x] (if (p x) (m-result x) (domonad [y (f x) z (m-until p f y)] z))) (defmacro m-when "If test is logical true, return monadic value m-expr, else return (m-result nil)." [test m-expr] `(if ~test ~m-expr (~'m-result nil))) (defmacro m-when-not "If test if logical false, return monadic value m-expr, else return (m-result nil)." [test m-expr] `(if ~test (~'m-result nil) ~m-expr)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Utility functions used in monad definitions ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- flatten* "Like #(apply concat %), but fully lazy: it evaluates each sublist only when it is needed." [ss] (lazy-seq (when-let [s (seq ss)] (concat (first s) (flatten* (rest s)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Commonly used monads ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Identity monad (defmonad identity-m "Monad describing plain computations. This monad does in fact nothing at all. It is useful for testing, for combination with monad transformers, and for code that is parameterized with a monad." [m-result identity m-bind (fn m-result-id [mv f] (f mv)) ]) ; Maybe monad (defmonad maybe-m "Monad describing computations with possible failures. Failure is represented by nil, any other value is considered valid. As soon as a step returns nil, the whole computation will yield nil as well." [m-zero nil m-result (fn m-result-maybe [v] v) m-bind (fn m-bind-maybe [mv f] (if (nil? mv) nil (f mv))) m-plus (fn m-plus-maybe [& mvs] (first (drop-while nil? mvs))) ]) ; Sequence monad (called "list monad" in Haskell) (defmonad sequence-m "Monad describing multi-valued computations, i.e. computations that can yield multiple values. Any object implementing the seq protocol can be used as a monadic value." [m-result (fn m-result-sequence [v] (list v)) m-bind (fn m-bind-sequence [mv f] (flatten* (map f mv))) m-zero (list) m-plus (fn m-plus-sequence [& mvs] (flatten* mvs)) ]) ; Set monad (defmonad set-m "Monad describing multi-valued computations, like sequence-m, but returning sets of results instead of sequences of results." [m-result (fn m-result-set [v] #{v}) m-bind (fn m-bind-set [mv f] (apply clojure.set/union (map f mv))) m-zero #{} m-plus (fn m-plus-set [& mvs] (apply clojure.set/union mvs)) ]) ; State monad (defmonad state-m "Monad describing stateful computations. The monadic values have the structure (fn [old-state] [result new-state])." [m-result (fn m-result-state [v] (fn [s] [v s])) m-bind (fn m-bind-state [mv f] (fn [s] (let [[v ss] (mv s)] ((f v) ss)))) ]) (defn update-state "Return a state-monad function that replaces the current state by the result of f applied to the current state and that returns the old state." [f] (fn [s] [s (f s)])) (defn set-state "Return a state-monad function that replaces the current state by s and returns the previous state." [s] (update-state (fn [_] s))) (defn fetch-state "Return a state-monad function that returns the current state and does not modify it." [] (update-state identity)) (defn fetch-val "Return a state-monad function that assumes the state to be a map and returns the value corresponding to the given key. The state is not modified." [key] (domonad state-m [s (fetch-state)] (key s))) (defn update-val "Return a state-monad function that assumes the state to be a map and replaces the value associated with the given key by the return value of f applied to the old value. The old value is returned." [key f] (fn [s] (let [old-val (get s key) new-s (assoc s key (f old-val))] [old-val new-s]))) (defn set-val "Return a state-monad function that assumes the state to be a map and replaces the value associated with key by val. The old value is returned." [key val] (update-val key (fn [_] val))) (defn with-state-field "Returns a state-monad function that expects a map as its state and runs statement (another state-monad function) on the state defined by the map entry corresponding to key. The map entry is updated with the new state returned by statement." [key statement] (fn [s] (let [substate (get s key nil) [result new-substate] (statement substate) new-state (assoc s key new-substate)] [result new-state]))) (defn state-m-until "An optimized implementation of m-until for the state monad that replaces recursion by a loop." [p f x] (letfn [(until [p f x s] (if (p x) [x s] (let [[x s] ((f x) s)] (recur p f x s))))] (fn [s] (until p f x s)))) ; Writer monad (defn writer-m "Monad describing computations that accumulate data on the side, e.g. for logging. The monadic values have the structure [value log]. Any of the accumulators from clojure.contrib.accumulators can be used for storing the log data. Its empty value is passed as a parameter." [empty-accumulator] (monad [m-result (fn m-result-writer [v] [v empty-accumulator]) m-bind (fn m-bind-writer [mv f] (let [[v1 a1] mv [v2 a2] (f v1)] [v2 (clojure.contrib.accumulators/combine a1 a2)])) ])) (defmonadfn write [v] (let [[_ a] (m-result nil)] [nil (clojure.contrib.accumulators/add a v)])) (defn listen [mv] (let [[v a] mv] [[v a] a])) (defn censor [f mv] (let [[v a] mv] [v (f a)])) ; Continuation monad (defmonad cont-m "Monad describing computations in continuation-passing style. The monadic values are functions that are called with a single argument representing the continuation of the computation, to which they pass their result." [m-result (fn m-result-cont [v] (fn [c] (c v))) m-bind (fn m-bind-cont [mv f] (fn [c] (mv (fn [v] ((f v) c))))) ]) (defn run-cont "Execute the computation c in the cont monad and return its result." [c] (c identity)) (defn call-cc "A computation in the cont monad that calls function f with a single argument representing the current continuation. The function f should return a continuation (which becomes the return value of call-cc), or call the passed-in current continuation to terminate." [f] (fn [c] (let [cc (fn cc [a] (fn [_] (c a))) rc (f cc)] (rc c)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Monad transformers ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro monad-transformer "Define a monad transforer in terms of the monad operations and the base monad. The argument which-m-plus chooses if m-zero and m-plus are taken from the base monad or from the transformer." [base which-m-plus operations] `(let [which-m-plus# (cond (= ~which-m-plus :m-plus-default) (if (= ::undefined (with-monad ~base ~'m-plus)) :m-plus-from-transformer :m-plus-from-base) (or (= ~which-m-plus :m-plus-from-base) (= ~which-m-plus :m-plus-from-transformer)) ~which-m-plus :else (throw (java.lang.IllegalArgumentException. "undefined m-plus choice"))) combined-monad# (monad ~operations)] (if (= which-m-plus# :m-plus-from-base) (assoc combined-monad# :m-zero (with-monad ~base ~'m-zero) :m-plus (with-monad ~base ~'m-plus)) combined-monad#))) (defn maybe-t "Monad transformer that transforms a monad m into a monad in which the base values can be invalid (represented by nothing, which defaults to nil). The third argument chooses if m-zero and m-plus are inherited from the base monad (use :m-plus-from-base) or adopt maybe-like behaviour (use :m-plus-from-transformer). The default is :m-plus-from-base if the base monad m has a definition for m-plus, and :m-plus-from-transformer otherwise." ([m] (maybe-t m nil :m-plus-default)) ([m nothing] (maybe-t m nothing :m-plus-default)) ([m nothing which-m-plus] (monad-transformer m which-m-plus [m-result (with-monad m m-result) m-bind (with-monad m (fn m-bind-maybe-t [mv f] (m-bind mv (fn [x] (if (identical? x nothing) (m-result nothing) (f x)))))) m-zero (with-monad m (m-result nothing)) m-plus (with-monad m (fn m-plus-maybe-t [& mvs] (if (empty? mvs) (m-result nothing) (m-bind (first mvs) (fn [v] (if (= v nothing) (apply m-plus-maybe-t (rest mvs)) (m-result v))))))) ]))) (defn sequence-t "Monad transformer that transforms a monad m into a monad in which the base values are sequences. The argument which-m-plus chooses if m-zero and m-plus are inherited from the base monad (use :m-plus-from-base) or adopt sequence-like behaviour (use :m-plus-from-transformer). The default is :m-plus-from-base if the base monad m has a definition for m-plus, and :m-plus-from-transformer otherwise." ([m] (sequence-t m :m-plus-default)) ([m which-m-plus] (monad-transformer m which-m-plus [m-result (with-monad m (fn m-result-sequence-t [v] (m-result (list v)))) m-bind (with-monad m (fn m-bind-sequence-t [mv f] (m-bind mv (fn [xs] (m-fmap flatten* (m-map f xs)))))) m-zero (with-monad m (m-result (list))) m-plus (with-monad m (fn m-plus-sequence-t [& mvs] (m-reduce concat (list) mvs))) ]))) ;; Contributed by Jim Duey (defn state-t "Monad transformer that transforms a monad m into a monad of stateful computations that have the base monad type as their result." [m] (monad [m-result (with-monad m (fn m-result-state-t [v] (fn [s] (m-result [v s])))) m-bind (with-monad m (fn m-bind-state-t [stm f] (fn [s] (m-bind (stm s) (fn [[v ss]] ((f v) ss)))))) m-zero (with-monad m (if (= ::undefined m-zero) ::undefined (fn [s] m-zero))) m-plus (with-monad m (if (= ::undefined m-plus) ::undefined (fn [& stms] (fn [s] (apply m-plus (map #(% s) stms)))))) ])) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/ns_utils.clj000066400000000000000000000057231161102570000264470ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; scgilardi (gmail) ;; 23 April 2008 ;; DEPRECATED in 1.2: dir and print-dir. Use dir and dir-fn in ;; clojure.repl. (ns ^{:author "Stephen C. Gilardi", :doc "Namespace utilities get-ns returns the namespace named by a symbol or throws if the namespace does not exist ns-vars returns a sorted seq of symbols naming public vars in a namespace print-docs prints documentation for the public vars in a namespace immigrate Create a public var in this namespace for each public var in the namespaces named by ns-names. From James Reeves vars returns a sorted seq of symbols naming public vars in a namespace (macro) docs prints documentation for the public vars in a namespace (macro)"} clojure.contrib.ns-utils (:use clojure.contrib.except)) ;; Namespace Utilities (defn get-ns "Returns the namespace named by ns-sym or throws if the namespace does not exist" [ns-sym] (let [ns (find-ns ns-sym)] (throw-if (not ns) "Unable to find namespace: %s" ns-sym) ns)) (defn ns-vars "Returns a sorted seq of symbols naming public vars in a namespace" [ns] (sort (map first (ns-publics ns)))) (defn print-dir "Prints a sorted directory of public vars in a namespace" {:deprecated "1.2"} [ns] (doseq [item (ns-vars ns)] (println item))) (defn print-docs "Prints documentation for the public vars in a namespace" [ns] (doseq [item (ns-vars ns)] (print-doc (ns-resolve ns item)))) ;; Convenience (defmacro vars "Returns a sorted seq of symbols naming public vars in a namespace" [nsname] `(ns-vars (get-ns '~nsname))) (defmacro dir "Prints a sorted directory of public vars in a namespace" {:deprecated "1.2"} [nsname] `(print-dir (get-ns '~nsname))) (defmacro docs "Prints documentation for the public vars in a namespace" [nsname] `(print-docs (get-ns '~nsname))) (defn immigrate "Create a public var in this namespace for each public var in the namespaces named by ns-names. The created vars have the same name, root binding, and metadata as the original except that their :ns metadata value is this namespace." [& ns-names] (doseq [ns ns-names] (require ns) (doseq [[sym var] (ns-publics ns)] (let [sym (with-meta sym (assoc (meta var) :ns *ns*))] (if (.hasRoot var) (intern *ns* sym (.getRoot var)) (intern *ns* sym)))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint.clj000066400000000000000000000026331161102570000261200ustar00rootroot00000000000000;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ;; Copyright (c) Tom Faulhaber, April 2009. 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. ;; DEPRECATED in 1.2. Promoted to clojure.pprint (ns ^{:author "Tom Faulhaber", :deprecated "1.2" :doc "This module comprises two elements: 1) A pretty printer for Clojure data structures, implemented in the function \"pprint\" 2) A Common Lisp compatible format function, implemented as \"cl-format\" because Clojure is using the name \"format\" for its Java-based format function. See documentation for those functions for more information or complete documentation on the the clojure-contrib web site on github.", } clojure.contrib.pprint (:use clojure.contrib.pprint.utilities) (:use clojure.contrib.pprint.pretty-writer clojure.contrib.pprint.column-writer)) (load "pprint/pprint_base") (load "pprint/cl_format") (load "pprint/dispatch") nil clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/000077500000000000000000000000001161102570000254225ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/cl_format.clj000066400000000000000000002154751161102570000301000ustar00rootroot00000000000000;;; cl_format.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This module implements the Common Lisp compatible format function as documented ;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at: ;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) (in-ns 'clojure.contrib.pprint) ;;; Forward references (declare compile-format) (declare execute-format) (declare init-navigator) ;;; End forward references (defn cl-format "An implementation of a Common Lisp compatible format function. cl-format formats its arguments to an output stream or string based on the format control string given. It supports sophisticated formatting of structured data. Writer is an instance of java.io.Writer, true to output to *out* or nil to output to a string, format-in is the format control string and the remaining arguments are the data to be formatted. The format control string is a string to be output with embedded 'format directives' describing how to format the various arguments passed in. If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format returns nil. For example: (let [results [46 38 22]] (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" (count results) results)) Prints to *out*: There are 3 results: 46, 38, 22 Detailed documentation on format control strings is available in the \"Common Lisp the Language, 2nd edition\", Chapter 22 (available online at: http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) and in the Common Lisp HyperSpec at http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm " {:see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" "Common Lisp the Language"] ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" "Common Lisp HyperSpec"]]} [writer format-in & args] (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) navigator (init-navigator args)] (execute-format writer compiled-format navigator))) (def ^{:private true} *format-str* nil) (defn- format-error [message offset] (let [full-message (str message \newline *format-str* \newline (apply str (repeat offset \space)) "^" \newline)] (throw (RuntimeException. full-message)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Argument navigators manage the argument list ;;; as the format statement moves through the list ;;; (possibly going forwards and backwards as it does so) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct ^{:private true} arg-navigator :seq :rest :pos ) (defn init-navigator "Create a new arg-navigator from the sequence with the position set to 0" {:skip-wiki true} [s] (let [s (seq s)] (struct arg-navigator s s 0))) ;; TODO call format-error with offset (defn- next-arg [ navigator ] (let [ rst (:rest navigator) ] (if rst [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] (throw (new Exception "Not enough arguments for format definition"))))) (defn- next-arg-or-nil [navigator] (let [rst (:rest navigator)] (if rst [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] [nil navigator]))) ;; Get an argument off the arg list and compile it if it's not already compiled (defn- get-format-arg [navigator] (let [[raw-format navigator] (next-arg navigator) compiled-format (if (instance? String raw-format) (compile-format raw-format) raw-format)] [compiled-format navigator])) (declare relative-reposition) (defn- absolute-reposition [navigator position] (if (>= position (:pos navigator)) (relative-reposition navigator (- (:pos navigator) position)) (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position))) (defn- relative-reposition [navigator position] (let [newpos (+ (:pos navigator) position)] (if (neg? position) (absolute-reposition navigator newpos) (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos)))) (defstruct ^{:private true} compiled-directive :func :def :params :offset) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; When looking at the parameter list, we may need to manipulate ;;; the argument list as well (for 'V' and '#' parameter types). ;;; We hide all of this behind a function, but clients need to ;;; manage changing arg navigator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO: validate parameters when they come from arg list (defn- realize-parameter [[param [raw-val offset]] navigator] (let [[real-param new-navigator] (cond (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary [raw-val navigator] (= raw-val :parameter-from-args) (next-arg navigator) (= raw-val :remaining-arg-count) [(count (:rest navigator)) navigator] true [raw-val navigator])] [[param [real-param offset]] new-navigator])) (defn- realize-parameter-list [parameter-map navigator] (let [[pairs new-navigator] (map-passing-context realize-parameter navigator parameter-map)] [(into {} pairs) new-navigator])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions that support individual directives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Common handling code for ~A and ~S ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare opt-base-str) (def ^{:private true} special-radix-markers {2 "#b" 8 "#o", 16 "#x"}) (defn- format-simple-number [n] (cond (integer? n) (if (= *print-base* 10) (str n (if *print-radix* ".")) (str (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) (opt-base-str *print-base* n))) (ratio? n) (str (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) (opt-base-str *print-base* (.numerator n)) "/" (opt-base-str *print-base* (.denominator n))) :else nil)) (defn- format-ascii [print-func params arg-navigator offsets] (let [ [arg arg-navigator] (next-arg arg-navigator) ^String base-output (or (format-simple-number arg) (print-func arg)) base-width (.length base-output) min-width (+ base-width (:minpad params)) width (if (>= min-width (:mincol params)) min-width (+ min-width (* (+ (quot (- (:mincol params) min-width 1) (:colinc params) ) 1) (:colinc params)))) chars (apply str (repeat (- width base-width) (:padchar params)))] (if (:at params) (print (str chars base-output)) (print (str base-output chars))) arg-navigator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for the integer directives ~D, ~X, ~O, ~B and some ;;; of ~R ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- integral? "returns true if a number is actually an integer (that is, has no fractional part)" [x] (cond (integer? x) true (decimal? x) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part (float? x) (= x (Math/floor x)) (ratio? x) (let [^clojure.lang.Ratio r x] (= 0 (rem (.numerator r) (.denominator r)))) :else false)) (defn- remainders "Return the list of remainders (essentially the 'digits') of val in the given base" [base val] (reverse (first (consume #(if (pos? %) [(rem % base) (quot % base)] [nil nil]) val)))) ;;; TODO: xlated-val does not seem to be used here. (defn- base-str "Return val as a string in the given base" [base val] (if (zero? val) "0" (let [xlated-val (cond (float? val) (bigdec val) (ratio? val) (let [^clojure.lang.Ratio r val] (/ (.numerator r) (.denominator r))) :else val)] (apply str (map #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) (remainders base val)))))) (def ^{:private true} java-base-formats {8 "%o", 10 "%d", 16 "%x"}) (defn- opt-base-str "Return val as a string in the given base, using clojure.core/format if supported for improved performance" [base val] (let [format-str (get java-base-formats base)] (if (and format-str (integer? val) (-> val class .getName (.startsWith "java."))) (clojure.core/format format-str val) (base-str base val)))) (defn- group-by* [unit lis] (reverse (first (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis))))) (defn- format-integer [base params arg-navigator offsets] (let [[arg arg-navigator] (next-arg arg-navigator)] (if (integral? arg) (let [neg (neg? arg) pos-arg (if neg (- arg) arg) raw-str (opt-base-str base pos-arg) group-str (if (:colon params) (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str)) commas (repeat (count groups) (:commachar params))] (apply str (next (interleave commas groups)))) raw-str) ^String signed-str (cond neg (str "-" group-str) (:at params) (str "+" group-str) true group-str) padded-str (if (< (.length signed-str) (:mincol params)) (str (apply str (repeat (- (:mincol params) (.length signed-str)) (:padchar params))) signed-str) signed-str)] (print padded-str)) (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 :padchar (:padchar params) :at true} (init-navigator [arg]) nil)) arg-navigator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for english formats (~R and ~:R) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def ^{:private true} english-cardinal-units ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"]) (def ^{:private true} english-ordinal-units ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"]) (def ^{:private true} english-cardinal-tens ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"]) (def ^{:private true} english-ordinal-tens ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"]) ;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales) ;; Number names from http://www.jimloy.com/math/billion.htm ;; We follow the rules for writing numbers from the Blue Book ;; (http://www.grammarbook.com/numbers/numbers.asp) (def ^{:private true} english-scale-numbers ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" "sextillion" "septillion" "octillion" "nonillion" "decillion" "undecillion" "duodecillion" "tredecillion" "quattuordecillion" "quindecillion" "sexdecillion" "septendecillion" "octodecillion" "novemdecillion" "vigintillion"]) (defn- format-simple-cardinal "Convert a number less than 1000 to a cardinal english string" [num] (let [hundreds (quot num 100) tens (rem num 100)] (str (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) (if (and (pos? hundreds) (pos? tens)) " ") (if (pos? tens) (if (< tens 20) (nth english-cardinal-units tens) (let [ten-digit (quot tens 10) unit-digit (rem tens 10)] (str (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) (if (and (pos? ten-digit) (pos? unit-digit)) "-") (if (pos? unit-digit) (nth english-cardinal-units unit-digit))))))))) (defn- add-english-scales "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string offset is a factor of 10^3 to multiply by" [parts offset] (let [cnt (count parts)] (loop [acc [] pos (dec cnt) this (first parts) remainder (next parts)] (if (nil? remainder) (str (apply str (interpose ", " acc)) (if (and (not (empty? this)) (not (empty? acc))) ", ") this (if (and (not (empty? this)) (pos? (+ pos offset))) (str " " (nth english-scale-numbers (+ pos offset))))) (recur (if (empty? this) acc (conj acc (str this " " (nth english-scale-numbers (+ pos offset))))) (dec pos) (first remainder) (next remainder)))))) (defn- format-cardinal-english [params navigator offsets] (let [[arg navigator] (next-arg navigator)] (if (= 0 arg) (print "zero") (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs parts (remainders 1000 abs-arg)] (if (<= (count parts) (count english-scale-numbers)) (let [parts-strs (map format-simple-cardinal parts) full-str (add-english-scales parts-strs 0)] (print (str (if (neg? arg) "minus ") full-str))) (format-integer ;; for numbers > 10^63, we fall back on ~D 10 { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} (init-navigator [arg]) { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})))) navigator)) (defn- format-simple-ordinal "Convert a number less than 1000 to a ordinal english string Note this should only be used for the last one in the sequence" [num] (let [hundreds (quot num 100) tens (rem num 100)] (str (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) (if (and (pos? hundreds) (pos? tens)) " ") (if (pos? tens) (if (< tens 20) (nth english-ordinal-units tens) (let [ten-digit (quot tens 10) unit-digit (rem tens 10)] (if (and (pos? ten-digit) (not (pos? unit-digit))) (nth english-ordinal-tens ten-digit) (str (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) (if (and (pos? ten-digit) (pos? unit-digit)) "-") (if (pos? unit-digit) (nth english-ordinal-units unit-digit)))))) (if (pos? hundreds) "th"))))) (defn- format-ordinal-english [params navigator offsets] (let [[arg navigator] (next-arg navigator)] (if (= 0 arg) (print "zeroth") (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs parts (remainders 1000 abs-arg)] (if (<= (count parts) (count english-scale-numbers)) (let [parts-strs (map format-simple-cardinal (drop-last parts)) head-str (add-english-scales parts-strs 1) tail-str (format-simple-ordinal (last parts))] (print (str (if (neg? arg) "minus ") (cond (and (not (empty? head-str)) (not (empty? tail-str))) (str head-str ", " tail-str) (not (empty? head-str)) (str head-str "th") :else tail-str)))) (do (format-integer ;; for numbers > 10^63, we fall back on ~D 10 { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} (init-navigator [arg]) { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}) (let [low-two-digits (rem arg 100) not-teens (or (< 11 low-two-digits) (> 19 low-two-digits)) low-digit (rem low-two-digits 10)] (print (cond (and (== low-digit 1) not-teens) "st" (and (== low-digit 2) not-teens) "nd" (and (== low-digit 3) not-teens) "rd" :else "th"))))))) navigator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for roman numeral formats (~@R and ~@:R) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def ^{:private true} old-roman-table [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"] [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"] [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"] [ "M" "MM" "MMM"]]) (def ^{:private true} new-roman-table [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"] [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"] [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"] [ "M" "MM" "MMM"]]) (defn- format-roman "Format a roman numeral using the specified look-up table" [table params navigator offsets] (let [[arg navigator] (next-arg navigator)] (if (and (number? arg) (> arg 0) (< arg 4000)) (let [digits (remainders 10 arg)] (loop [acc [] pos (dec (count digits)) digits digits] (if (empty? digits) (print (apply str acc)) (let [digit (first digits)] (recur (if (= 0 digit) acc (conj acc (nth (nth table pos) (dec digit)))) (dec pos) (next digits)))))) (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D 10 { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} (init-navigator [arg]) { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})) navigator)) (defn- format-old-roman [params navigator offsets] (format-roman old-roman-table params navigator offsets)) (defn- format-new-roman [params navigator offsets] (format-roman new-roman-table params navigator offsets)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for character formats (~C) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def ^{:private true} special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"}) (defn- pretty-character [params navigator offsets] (let [[c navigator] (next-arg navigator) as-int (int c) base-char (bit-and as-int 127) meta (bit-and as-int 128) special (get special-chars base-char)] (if (> meta 0) (print "Meta-")) (print (cond special special (< base-char 32) (str "Control-" (char (+ base-char 64))) (= base-char 127) "Control-?" :else (char base-char))) navigator)) (defn- readable-character [params navigator offsets] (let [[c navigator] (next-arg navigator)] (condp = (:char-format params) \o (cl-format true "\\o~3,'0o" (int c)) \u (cl-format true "\\u~4,'0x" (int c)) nil (pr c)) navigator)) (defn- plain-character [params navigator offsets] (let [[char navigator] (next-arg navigator)] (print char) navigator)) ;; Check to see if a result is an abort (~^) construct ;; TODO: move these funcs somewhere more appropriate (defn- abort? [context] (let [token (first context)] (or (= :up-arrow token) (= :colon-up-arrow token)))) ;; Handle the execution of "sub-clauses" in bracket constructions (defn- execute-sub-format [format args base-args] (second (map-passing-context (fn [element context] (if (abort? context) [nil context] ; just keep passing it along (let [[params args] (realize-parameter-list (:params element) context) [params offsets] (unzip-map params) params (assoc params :base-args base-args)] [nil (apply (:func element) [params args offsets])]))) args format))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for real number formats ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO - return exponent as int to eliminate double conversion (defn- float-parts-base "Produce string parts for the mantissa (normalized 1-9) and exponent" [^Object f] (let [^String s (.toLowerCase (.toString f)) exploc (.indexOf s (int \e))] (if (neg? exploc) (let [dotloc (.indexOf s (int \.))] (if (neg? dotloc) [s (str (dec (count s)))] [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))])) [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))]))) (defn- float-parts "Take care of leading and trailing zeros in decomposed floats" [f] (let [[m ^String e] (float-parts-base f) m1 (rtrim m \0) m2 (ltrim m1 \0) delta (- (count m1) (count m2)) ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)] (if (empty? m2) ["0" 0] [m2 (- (Integer/valueOf e) delta)]))) (defn- round-str [m e d w] (if (or d w) (let [len (count m) round-pos (if d (+ e d 1)) round-pos (if (and w (< (inc e) (dec w)) (or (nil? round-pos) (< (dec w) round-pos))) (dec w) round-pos) [m1 e1 round-pos len] (if (= round-pos 0) [(str "0" m) (inc e) 1 (inc len)] [m e round-pos len])] (if round-pos (if (neg? round-pos) ["0" 0 false] (if (> len round-pos) (let [round-char (nth m1 round-pos) ^String result (subs m1 0 round-pos)] (if (>= (int round-char) (int \5)) (let [result-val (Integer/valueOf result) leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1))) round-up-result (str leading-zeros (String/valueOf (+ result-val (if (neg? result-val) -1 1)))) expanded (> (count round-up-result) (count result))] [round-up-result e1 expanded]) [result e1 false])) [m e false])) [m e false])) [m e false])) (defn- expand-fixed [m e d] (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m) len (count m1) target-len (if d (+ e d 1) (inc e))] (if (< len target-len) (str m1 (apply str (repeat (- target-len len) \0))) m1))) (defn- insert-decimal "Insert the decimal point at the right spot in the number to match an exponent" [m e] (if (neg? e) (str "." m) (let [loc (inc e)] (str (subs m 0 loc) "." (subs m loc))))) (defn- get-fixed [m e d] (insert-decimal (expand-fixed m e d) e)) (defn- insert-scaled-decimal "Insert the decimal point at the right spot in the number to match an exponent" [m k] (if (neg? k) (str "." m) (str (subs m 0 k) "." (subs m k)))) ;; the function to render ~F directives ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases (defn- fixed-float [params navigator offsets] (let [w (:w params) d (:d params) [arg navigator] (next-arg navigator) [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg]) [mantissa exp] (float-parts abs) scaled-exp (+ exp (:k params)) add-sign (or (:at params) (neg? arg)) append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp d (if w (- w (if add-sign 1 0)))) fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) prepend-zero (= (first fixed-repr) \.)] (if w (let [len (count fixed-repr) signed-len (if add-sign (inc len) len) prepend-zero (and prepend-zero (not (>= signed-len w))) append-zero (and append-zero (not (>= signed-len w))) full-len (if (or prepend-zero append-zero) (inc signed-len) signed-len)] (if (and (> full-len w) (:overflowchar params)) (print (apply str (repeat w (:overflowchar params)))) (print (str (apply str (repeat (- w full-len) (:padchar params))) (if add-sign sign) (if prepend-zero "0") fixed-repr (if append-zero "0"))))) (print (str (if add-sign sign) (if prepend-zero "0") fixed-repr (if append-zero "0")))) navigator)) ;; the function to render ~E directives ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases ;; TODO: define ~E representation for Infinity (defn- exponential-float [params navigator offsets] (let [[arg navigator] (next-arg navigator)] (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))] (let [w (:w params) d (:d params) e (:e params) k (:k params) expchar (or (:exponentchar params) \E) add-sign (or (:at params) (neg? arg)) prepend-zero (<= k 0) ^Integer scaled-exp (- exp (dec k)) scaled-exp-str (str (Math/abs scaled-exp)) scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) (if e (apply str (repeat (- e (count scaled-exp-str)) \0))) scaled-exp-str) exp-width (count scaled-exp-str) base-mantissa-width (count mantissa) scaled-mantissa (str (apply str (repeat (- k) \0)) mantissa (if d (apply str (repeat (- d (dec base-mantissa-width) (if (neg? k) (- k) 0)) \0)))) w-mantissa (if w (- w exp-width)) [rounded-mantissa _ incr-exp] (round-str scaled-mantissa 0 (cond (= k 0) (dec d) (pos? k) d (neg? k) (dec d)) (if w-mantissa (- w-mantissa (if add-sign 1 0)))) full-mantissa (insert-scaled-decimal rounded-mantissa k) append-zero (and (= k (count rounded-mantissa)) (nil? d))] (if (not incr-exp) (if w (let [len (+ (count full-mantissa) exp-width) signed-len (if add-sign (inc len) len) prepend-zero (and prepend-zero (not (= signed-len w))) full-len (if prepend-zero (inc signed-len) signed-len) append-zero (and append-zero (< full-len w))] (if (and (or (> full-len w) (and e (> (- exp-width 2) e))) (:overflowchar params)) (print (apply str (repeat w (:overflowchar params)))) (print (str (apply str (repeat (- w full-len (if append-zero 1 0) ) (:padchar params))) (if add-sign (if (neg? arg) \- \+)) (if prepend-zero "0") full-mantissa (if append-zero "0") scaled-exp-str)))) (print (str (if add-sign (if (neg? arg) \- \+)) (if prepend-zero "0") full-mantissa (if append-zero "0") scaled-exp-str))) (recur [rounded-mantissa (inc exp)])))) navigator)) ;; the function to render ~G directives ;; This just figures out whether to pass the request off to ~F or ~E based ;; on the algorithm in CLtL. ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases ;; TODO: refactor so that float-parts isn't called twice (defn- general-float [params navigator offsets] (let [[arg _] (next-arg navigator) [mantissa exp] (float-parts (if (neg? arg) (- arg) arg)) w (:w params) d (:d params) e (:e params) n (if (= arg 0.0) 0 (inc exp)) ee (if e (+ e 2) 4) ww (if w (- w ee)) d (if d d (max (count mantissa) (min n 7))) dd (- d n)] (if (<= 0 dd d) (let [navigator (fixed-float {:w ww, :d dd, :k 0, :overflowchar (:overflowchar params), :padchar (:padchar params), :at (:at params)} navigator offsets)] (print (apply str (repeat ee \space))) navigator) (exponential-float params navigator offsets)))) ;; the function to render ~$ directives ;; TODO: support rationals. Back off to ~D/~A is the appropriate cases (defn- dollar-float [params navigator offsets] (let [[^Double arg navigator] (next-arg navigator) [mantissa exp] (float-parts (Math/abs arg)) d (:d params) ; digits after the decimal n (:n params) ; minimum digits before the decimal w (:w params) ; minimum field width add-sign (or (:at params) (neg? arg)) [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil) ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) full-repr (str (apply str (repeat (- n (.indexOf fixed-repr (int \.))) \0)) fixed-repr) full-len (+ (count full-repr) (if add-sign 1 0))] (print (str (if (and (:colon params) add-sign) (if (neg? arg) \- \+)) (apply str (repeat (- w full-len) (:padchar params))) (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+)) full-repr)) navigator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for the '~[...~]' conditional construct in its ;;; different flavors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ~[...~] without any modifiers chooses one of the clauses based on the param or ;; next argument ;; TODO check arg is positive int (defn- choice-conditional [params arg-navigator offsets] (let [arg (:selector params) [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator)) clauses (:clauses params) clause (if (or (neg? arg) (>= arg (count clauses))) (first (:else params)) (nth clauses arg))] (if clause (execute-sub-format clause navigator (:base-args params)) navigator))) ;; ~:[...~] with the colon reads the next argument treating it as a truth value (defn- boolean-conditional [params arg-navigator offsets] (let [[arg navigator] (next-arg arg-navigator) clauses (:clauses params) clause (if arg (second clauses) (first clauses))] (if clause (execute-sub-format clause navigator (:base-args params)) navigator))) ;; ~@[...~] with the at sign executes the conditional if the next arg is not ;; nil/false without consuming the arg (defn- check-arg-conditional [params arg-navigator offsets] (let [[arg navigator] (next-arg arg-navigator) clauses (:clauses params) clause (if arg (first clauses))] (if arg (if clause (execute-sub-format clause arg-navigator (:base-args params)) arg-navigator) navigator))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for the '~{...~}' iteration construct in its ;;; different flavors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ~{...~} without any modifiers uses the next argument as an argument list that ;; is consumed by all the iterations (defn- iterate-sublist [params navigator offsets] (let [max-count (:max-iterations params) param-clause (first (:clauses params)) [clause navigator] (if (empty? param-clause) (get-format-arg navigator) [param-clause navigator]) [arg-list navigator] (next-arg navigator) args (init-navigator arg-list)] (loop [count 0 args args last-pos (num -1)] (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) ;; TODO get the offset in here and call format exception (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!"))) (if (or (and (empty? (:rest args)) (or (not (:colon (:right-params params))) (> count 0))) (and max-count (>= count max-count))) navigator (let [iter-result (execute-sub-format clause args (:base-args params))] (if (= :up-arrow (first iter-result)) navigator (recur (inc count) iter-result (:pos args)))))))) ;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the ;; sublists is used as the arglist for a single iteration. (defn- iterate-list-of-sublists [params navigator offsets] (let [max-count (:max-iterations params) param-clause (first (:clauses params)) [clause navigator] (if (empty? param-clause) (get-format-arg navigator) [param-clause navigator]) [arg-list navigator] (next-arg navigator)] (loop [count 0 arg-list arg-list] (if (or (and (empty? arg-list) (or (not (:colon (:right-params params))) (> count 0))) (and max-count (>= count max-count))) navigator (let [iter-result (execute-sub-format clause (init-navigator (first arg-list)) (init-navigator (next arg-list)))] (if (= :colon-up-arrow (first iter-result)) navigator (recur (inc count) (next arg-list)))))))) ;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations ;; is consumed by all the iterations (defn- iterate-main-list [params navigator offsets] (let [max-count (:max-iterations params) param-clause (first (:clauses params)) [clause navigator] (if (empty? param-clause) (get-format-arg navigator) [param-clause navigator])] (loop [count 0 navigator navigator last-pos (num -1)] (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) ;; TODO get the offset in here and call format exception (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!"))) (if (or (and (empty? (:rest navigator)) (or (not (:colon (:right-params params))) (> count 0))) (and max-count (>= count max-count))) navigator (let [iter-result (execute-sub-format clause navigator (:base-args params))] (if (= :up-arrow (first iter-result)) (second iter-result) (recur (inc count) iter-result (:pos navigator)))))))) ;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one ;; of which is consumed with each iteration (defn- iterate-main-sublists [params navigator offsets] (let [max-count (:max-iterations params) param-clause (first (:clauses params)) [clause navigator] (if (empty? param-clause) (get-format-arg navigator) [param-clause navigator]) ] (loop [count 0 navigator navigator] (if (or (and (empty? (:rest navigator)) (or (not (:colon (:right-params params))) (> count 0))) (and max-count (>= count max-count))) navigator (let [[sublist navigator] (next-arg-or-nil navigator) iter-result (execute-sub-format clause (init-navigator sublist) navigator)] (if (= :colon-up-arrow (first iter-result)) navigator (recur (inc count) navigator))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The '~< directive has two completely different meanings ;;; in the '~<...~>' form it does justification, but with ;;; ~<...~:>' it represents the logical block operation of the ;;; pretty printer. ;;; ;;; Unfortunately, the current architecture decides what function ;;; to call at form parsing time before the sub-clauses have been ;;; folded, so it is left to run-time to make the decision. ;;; ;;; TODO: make it possible to make these decisions at compile-time. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare format-logical-block) (declare justify-clauses) (defn- logical-block-or-justify [params navigator offsets] (if (:colon (:right-params params)) (format-logical-block params navigator offsets) (justify-clauses params navigator offsets))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for the '~<...~>' justification directive ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- render-clauses [clauses navigator base-navigator] (loop [clauses clauses acc [] navigator navigator] (if (empty? clauses) [acc navigator] (let [clause (first clauses) [iter-result result-str] (binding [*out* (java.io.StringWriter.)] [(execute-sub-format clause navigator base-navigator) (.toString *out*)])] (if (= :up-arrow (first iter-result)) [acc (second iter-result)] (recur (next clauses) (conj acc result-str) iter-result)))))) ;; TODO support for ~:; constructions (defn- justify-clauses [params navigator offsets] (let [[[eol-str] new-navigator] (when-let [else (:else params)] (render-clauses else navigator (:base-args params))) navigator (or new-navigator navigator) [else-params new-navigator] (when-let [p (:else-params params)] (realize-parameter-list p navigator)) navigator (or new-navigator navigator) min-remaining (or (first (:min-remaining else-params)) 0) max-columns (or (first (:max-columns else-params)) (get-max-column *out*)) clauses (:clauses params) [strs navigator] (render-clauses clauses navigator (:base-args params)) slots (max 1 (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0))) chars (reduce + (map count strs)) mincol (:mincol params) minpad (:minpad params) colinc (:colinc params) minout (+ chars (* slots minpad)) result-columns (if (<= minout mincol) mincol (+ mincol (* colinc (+ 1 (quot (- minout mincol 1) colinc))))) total-pad (- result-columns chars) pad (max minpad (quot total-pad slots)) extra-pad (- total-pad (* pad slots)) pad-str (apply str (repeat pad (:padchar params)))] (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) max-columns)) (print eol-str)) (loop [slots slots extra-pad extra-pad strs strs pad-only (or (:colon params) (and (= (count strs) 1) (not (:at params))))] (if (seq strs) (do (print (str (if (not pad-only) (first strs)) (if (or pad-only (next strs) (:at params)) pad-str) (if (pos? extra-pad) (:padchar params)))) (recur (dec slots) (dec extra-pad) (if pad-only strs (next strs)) false)))) navigator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for case modification with ~(...~). ;;; We do this by wrapping the underlying writer with ;;; a special writer to do the appropriate modification. This ;;; allows us to support arbitrary-sized output and sources ;;; that may block. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- downcase-writer "Returns a proxy that wraps writer, converting all characters to lower case" [^java.io.Writer writer] (proxy [java.io.Writer] [] (close [] (.close writer)) (flush [] (.flush writer)) (write ([^chars cbuf ^Integer off ^Integer len] (.write writer cbuf off len)) ([x] (condp = (class x) String (let [s ^String x] (.write writer (.toLowerCase s))) Integer (let [c ^Character x] (.write writer (int (Character/toLowerCase (char c)))))))))) (defn- upcase-writer "Returns a proxy that wraps writer, converting all characters to upper case" [^java.io.Writer writer] (proxy [java.io.Writer] [] (close [] (.close writer)) (flush [] (.flush writer)) (write ([^chars cbuf ^Integer off ^Integer len] (.write writer cbuf off len)) ([x] (condp = (class x) String (let [s ^String x] (.write writer (.toUpperCase s))) Integer (let [c ^Character x] (.write writer (int (Character/toUpperCase (char c)))))))))) (defn- capitalize-string "Capitalizes the words in a string. If first? is false, don't capitalize the first character of the string even if it's a letter." [s first?] (let [^Character f (first s) s (if (and first? f (Character/isLetter f)) (str (Character/toUpperCase f) (subs s 1)) s)] (apply str (first (consume (fn [s] (if (empty? s) [nil nil] (let [m (re-matcher #"\W\w" s) match (re-find m) offset (and match (inc (.start m)))] (if offset [(str (subs s 0 offset) (Character/toUpperCase ^Character (nth s offset))) (subs s (inc offset))] [s nil])))) s))))) (defn- capitalize-word-writer "Returns a proxy that wraps writer, captializing all words" [^java.io.Writer writer] (let [last-was-whitespace? (ref true)] (proxy [java.io.Writer] [] (close [] (.close writer)) (flush [] (.flush writer)) (write ([^chars cbuf ^Integer off ^Integer len] (.write writer cbuf off len)) ([x] (condp = (class x) String (let [s ^String x] (.write writer ^String (capitalize-string (.toLowerCase s) @last-was-whitespace?)) (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (nth s (dec (count s))))))) Integer (let [c (char x)] (let [mod-c (if @last-was-whitespace? (Character/toUpperCase ^Character (char x)) c)] (.write writer (int mod-c)) (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (char x)))))))))))) (defn- init-cap-writer "Returns a proxy that wraps writer, capitalizing the first word" [^java.io.Writer writer] (let [capped (ref false)] (proxy [java.io.Writer] [] (close [] (.close writer)) (flush [] (.flush writer)) (write ([^chars cbuf ^Integer off ^Integer len] (.write writer cbuf off len)) ([x] (condp = (class x) String (let [s (.toLowerCase ^String x)] (if (not @capped) (let [m (re-matcher #"\S" s) match (re-find m) offset (and match (.start m))] (if offset (do (.write writer (str (subs s 0 offset) (Character/toUpperCase ^Character (nth s offset)) (.toLowerCase ^String (subs s (inc offset))))) (dosync (ref-set capped true))) (.write writer s))) (.write writer (.toLowerCase s)))) Integer (let [c ^Character (char x)] (if (and (not @capped) (Character/isLetter c)) (do (dosync (ref-set capped true)) (.write writer (int (Character/toUpperCase c)))) (.write writer (int (Character/toLowerCase c))))))))))) (defn- modify-case [make-writer params navigator offsets] (let [clause (first (:clauses params))] (binding [*out* (make-writer *out*)] (execute-sub-format clause navigator (:base-args params))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; If necessary, wrap the writer in a PrettyWriter object ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn get-pretty-writer [writer] (if (pretty-writer? writer) writer (pretty-writer writer *print-right-margin* *print-miser-width*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for column-aware operations ~&, ~T ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO: make an automatic newline for non-ColumnWriters (defn fresh-line "Make a newline if the Writer is not already at the beginning of the line. N.B. Only works on ColumnWriters right now." [] (if (not (= 0 (get-column (:base @@*out*)))) (prn))) (defn- absolute-tabulation [params navigator offsets] (let [colnum (:colnum params) colinc (:colinc params) current (get-column (:base @@*out*)) space-count (cond (< current colnum) (- colnum current) (= colinc 0) 0 :else (- colinc (rem (- current colnum) colinc)))] (print (apply str (repeat space-count \space)))) navigator) (defn- relative-tabulation [params navigator offsets] (let [colrel (:colnum params) colinc (:colinc params) start-col (+ colrel (get-column (:base @@*out*))) offset (if (pos? colinc) (rem start-col colinc) 0) space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))] (print (apply str (repeat space-count \space)))) navigator) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Support for accessing the pretty printer from a format ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO: support ~@; per-line-prefix separator ;; TODO: get the whole format wrapped so we can start the lb at any column (defn- format-logical-block [params navigator offsets] (let [clauses (:clauses params) clause-count (count clauses) prefix (cond (> clause-count 1) (:string (:params (first (first clauses)))) (:colon params) "(") body (nth clauses (if (> clause-count 1) 1 0)) suffix (cond (> clause-count 2) (:string (:params (first (nth clauses 2)))) (:colon params) ")") [arg navigator] (next-arg navigator)] (pprint-logical-block :prefix prefix :suffix suffix (execute-sub-format body (init-navigator arg) (:base-args params))) navigator)) (defn- set-indent [params navigator offsets] (let [relative-to (if (:colon params) :current :block)] (pprint-indent relative-to (:n params)) navigator)) ;;; TODO: support ~:T section options for ~T (defn- conditional-newline [params navigator offsets] (let [kind (if (:colon params) (if (:at params) :mandatory :fill) (if (:at params) :miser :linear))] (pprint-newline kind) navigator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The table of directives we support, each with its params, ;;; properties, and the compilation function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; We start with a couple of helpers (defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ] [char, {:directive char, :params `(array-map ~@params), :flags flags, :bracket-info bracket-info, :generator-fn (concat '(fn [ params offset]) generator-fn) }]) (defmacro ^{:private true} defdirectives [ & directives ] `(def ^{:private true} directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) (defdirectives (\A [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] #{ :at :colon :both} {} #(format-ascii print-str %1 %2 %3)) (\S [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] #{ :at :colon :both} {} #(format-ascii pr-str %1 %2 %3)) (\D [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] :commainterval [ 3 Integer]] #{ :at :colon :both } {} #(format-integer 10 %1 %2 %3)) (\B [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] :commainterval [ 3 Integer]] #{ :at :colon :both } {} #(format-integer 2 %1 %2 %3)) (\O [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] :commainterval [ 3 Integer]] #{ :at :colon :both } {} #(format-integer 8 %1 %2 %3)) (\X [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] :commainterval [ 3 Integer]] #{ :at :colon :both } {} #(format-integer 16 %1 %2 %3)) (\R [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] :commainterval [ 3 Integer]] #{ :at :colon :both } {} (do (cond ; ~R is overloaded with bizareness (first (:base params)) #(format-integer (:base %1) %1 %2 %3) (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3) (:at params) #(format-new-roman %1 %2 %3) (:colon params) #(format-ordinal-english %1 %2 %3) true #(format-cardinal-english %1 %2 %3)))) (\P [ ] #{ :at :colon :both } {} (fn [params navigator offsets] (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator) strs (if (:at params) ["y" "ies"] ["" "s"]) [arg navigator] (next-arg navigator)] (print (if (= arg 1) (first strs) (second strs))) navigator))) (\C [:char-format [nil Character]] #{ :at :colon :both } {} (cond (:colon params) pretty-character (:at params) readable-character :else plain-character)) (\F [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] :padchar [\space Character] ] #{ :at } {} fixed-float) (\E [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] :overflowchar [nil Character] :padchar [\space Character] :exponentchar [nil Character] ] #{ :at } {} exponential-float) (\G [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] :overflowchar [nil Character] :padchar [\space Character] :exponentchar [nil Character] ] #{ :at } {} general-float) (\$ [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]] #{ :at :colon :both} {} dollar-float) (\% [ :count [1 Integer] ] #{ } {} (fn [params arg-navigator offsets] (dotimes [i (:count params)] (prn)) arg-navigator)) (\& [ :count [1 Integer] ] #{ :pretty } {} (fn [params arg-navigator offsets] (let [cnt (:count params)] (if (pos? cnt) (fresh-line)) (dotimes [i (dec cnt)] (prn))) arg-navigator)) (\| [ :count [1 Integer] ] #{ } {} (fn [params arg-navigator offsets] (dotimes [i (:count params)] (print \formfeed)) arg-navigator)) (\~ [ :n [1 Integer] ] #{ } {} (fn [params arg-navigator offsets] (let [n (:n params)] (print (apply str (repeat n \~))) arg-navigator))) (\newline ;; Whitespace supression is handled in the compilation loop [ ] #{:colon :at} {} (fn [params arg-navigator offsets] (if (:at params) (prn)) arg-navigator)) (\T [ :colnum [1 Integer] :colinc [1 Integer] ] #{ :at :pretty } {} (if (:at params) #(relative-tabulation %1 %2 %3) #(absolute-tabulation %1 %2 %3))) (\* [ :n [1 Integer] ] #{ :colon :at } {} (fn [params navigator offsets] (let [n (:n params)] (if (:at params) (absolute-reposition navigator n) (relative-reposition navigator (if (:colon params) (- n) n))) ))) (\? [ ] #{ :at } {} (if (:at params) (fn [params navigator offsets] ; args from main arg list (let [[subformat navigator] (get-format-arg navigator)] (execute-sub-format subformat navigator (:base-args params)))) (fn [params navigator offsets] ; args from sub-list (let [[subformat navigator] (get-format-arg navigator) [subargs navigator] (next-arg navigator) sub-navigator (init-navigator subargs)] (execute-sub-format subformat sub-navigator (:base-args params)) navigator)))) (\( [ ] #{ :colon :at :both} { :right \), :allows-separator nil, :else nil } (let [mod-case-writer (cond (and (:at params) (:colon params)) upcase-writer (:colon params) capitalize-word-writer (:at params) init-cap-writer :else downcase-writer)] #(modify-case mod-case-writer %1 %2 %3))) (\) [] #{} {} nil) (\[ [ :selector [nil Integer] ] #{ :colon :at } { :right \], :allows-separator true, :else :last } (cond (:colon params) boolean-conditional (:at params) check-arg-conditional true choice-conditional)) (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] #{ :colon } { :separator true } nil) (\] [] #{} {} nil) (\{ [ :max-iterations [nil Integer] ] #{ :colon :at :both} { :right \}, :allows-separator false } (cond (and (:at params) (:colon params)) iterate-main-sublists (:colon params) iterate-list-of-sublists (:at params) iterate-main-list true iterate-sublist)) (\} [] #{:colon} {} nil) (\< [:mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]] #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first } logical-block-or-justify) (\> [] #{:colon} {} nil) ;; TODO: detect errors in cases where colon not allowed (\^ [:arg1 [nil Integer] :arg2 [nil Integer] :arg3 [nil Integer]] #{:colon} {} (fn [params navigator offsets] (let [arg1 (:arg1 params) arg2 (:arg2 params) arg3 (:arg3 params) exit (if (:colon params) :colon-up-arrow :up-arrow)] (cond (and arg1 arg2 arg3) (if (<= arg1 arg2 arg3) [exit navigator] navigator) (and arg1 arg2) (if (= arg1 arg2) [exit navigator] navigator) arg1 (if (= arg1 0) [exit navigator] navigator) true ; TODO: handle looking up the arglist stack for info (if (if (:colon params) (empty? (:rest (:base-args params))) (empty? (:rest navigator))) [exit navigator] navigator))))) (\W [] #{:at :colon :both} {} (if (or (:at params) (:colon params)) (let [bindings (concat (if (:at params) [:level nil :length nil] []) (if (:colon params) [:pretty true] []))] (fn [params navigator offsets] (let [[arg navigator] (next-arg navigator)] (if (apply write arg bindings) [:up-arrow navigator] navigator)))) (fn [params navigator offsets] (let [[arg navigator] (next-arg navigator)] (if (write-out arg) [:up-arrow navigator] navigator))))) (\_ [] #{:at :colon :both} {} conditional-newline) (\I [:n [0 Integer]] #{:colon} {} set-indent) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code to manage the parameters and flags associated with each ;;; directive in the format string. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def ^{:private true} param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))") (def ^{:private true} special-params #{ :parameter-from-args :remaining-arg-count }) (defn- extract-param [[s offset saw-comma]] (let [m (re-matcher param-pattern s) param (re-find m)] (if param (let [token-str (first (re-groups m)) remainder (subs s (.end m)) new-offset (+ offset (.end m))] (if (not (= \, (nth remainder 0))) [ [token-str offset] [remainder new-offset false]] [ [token-str offset] [(subs remainder 1) (inc new-offset) true]])) (if saw-comma (format-error "Badly formed parameters in format directive" offset) [ nil [s offset]])))) (defn- extract-params [s offset] (consume extract-param [s offset false])) (defn- translate-param "Translate the string representation of a param to the internalized representation" [[^String p offset]] [(cond (= (.length p) 0) nil (and (= (.length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1) true (new Integer p)) offset]) (def ^{:private true} flag-defs { \: :colon, \@ :at }) (defn- extract-flags [s offset] (consume (fn [[s offset flags]] (if (empty? s) [nil [s offset flags]] (let [flag (get flag-defs (first s))] (if flag (if (contains? flags flag) (format-error (str "Flag \"" (first s) "\" appears more than once in a directive") offset) [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]]) [nil [s offset flags]])))) [s offset {}])) (defn- check-flags [def flags] (let [allowed (:flags def)] (if (and (not (:at allowed)) (:at flags)) (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"") (nth (:at flags) 1))) (if (and (not (:colon allowed)) (:colon flags)) (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"") (nth (:colon flags) 1))) (if (and (not (:both allowed)) (:at flags) (:colon flags)) (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" (:directive def) "\"") (min (nth (:colon flags) 1) (nth (:at flags) 1)))))) (defn- map-params "Takes a directive definition and the list of actual parameters and a map of flags and returns a map of the parameters and flags with defaults filled in. We check to make sure that there are the right types and number of parameters as well." [def params flags offset] (check-flags def flags) (if (> (count params) (count (:params def))) (format-error (cl-format nil "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed" (:directive def) (count params) (count (:params def))) (second (first params)))) (doall (map #(let [val (first %1)] (if (not (or (nil? val) (contains? special-params val) (instance? (second (second %2)) val))) (format-error (str "Parameter " (name (first %2)) " has bad type in directive \"" (:directive def) "\": " (class val)) (second %1))) ) params (:params def))) (merge ; create the result map (into (array-map) ; start with the default values, make sure the order is right (reverse (for [[name [default]] (:params def)] [name [default offset]]))) (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils flags)) ; and finally add the flags (defn- compile-directive [s offset] (let [[raw-params [rest offset]] (extract-params s offset) [_ [rest offset flags]] (extract-flags rest offset) directive (first rest) def (get directive-table (Character/toUpperCase ^Character directive)) params (if def (map-params def (map translate-param raw-params) flags offset))] (if (not directive) (format-error "Format string ended in the middle of a directive" offset)) (if (not def) (format-error (str "Directive \"" directive "\" is undefined") offset)) [(struct compiled-directive ((:generator-fn def) params offset) def params offset) (let [remainder (subs rest 1) offset (inc offset) trim? (and (= \newline (:directive def)) (not (:colon params))) trim-count (if trim? (prefix-count remainder [\space \tab]) 0) remainder (subs remainder trim-count) offset (+ offset trim-count)] [remainder offset])])) (defn- compile-raw-string [s offset] (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset)) (defn- right-bracket [this] (:right (:bracket-info (:def this)))) (defn- separator? [this] (:separator (:bracket-info (:def this)))) (defn- else-separator? [this] (and (:separator (:bracket-info (:def this))) (:colon (:params this)))) (declare collect-clauses) (defn- process-bracket [this remainder] (let [[subex remainder] (collect-clauses (:bracket-info (:def this)) (:offset this) remainder)] [(struct compiled-directive (:func this) (:def this) (merge (:params this) (tuple-map subex (:offset this))) (:offset this)) remainder])) (defn- process-clause [bracket-info offset remainder] (consume (fn [remainder] (if (empty? remainder) (format-error "No closing bracket found." offset) (let [this (first remainder) remainder (next remainder)] (cond (right-bracket this) (process-bracket this remainder) (= (:right bracket-info) (:directive (:def this))) [ nil [:right-bracket (:params this) nil remainder]] (else-separator? this) [nil [:else nil (:params this) remainder]] (separator? this) [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~; true [this remainder])))) remainder)) (defn- collect-clauses [bracket-info offset remainder] (second (consume (fn [[clause-map saw-else remainder]] (let [[clause [type right-params else-params remainder]] (process-clause bracket-info offset remainder)] (cond (= type :right-bracket) [nil [(merge-with concat clause-map {(if saw-else :else :clauses) [clause] :right-params right-params}) remainder]] (= type :else) (cond (:else clause-map) (format-error "Two else clauses (\"~:;\") inside bracket construction." offset) (not (:else bracket-info)) (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." offset) (and (= :first (:else bracket-info)) (seq (:clauses clause-map))) (format-error "The else clause (\"~:;\") is only allowed in the first position for this directive." offset) true ; if the ~:; is in the last position, the else clause ; is next, this was a regular clause (if (= :first (:else bracket-info)) [true [(merge-with concat clause-map { :else [clause] :else-params else-params}) false remainder]] [true [(merge-with concat clause-map { :clauses [clause] }) true remainder]])) (= type :separator) (cond saw-else (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset) (not (:allows-separator bracket-info)) (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." offset) true [true [(merge-with concat clause-map { :clauses [clause] }) false remainder]])))) [{ :clauses [] } false remainder]))) (defn- process-nesting "Take a linearly compiled format and process the bracket directives to give it the appropriate tree structure" [format] (first (consume (fn [remainder] (let [this (first remainder) remainder (next remainder) bracket (:bracket-info (:def this))] (if (:right bracket) (process-bracket this remainder) [this remainder]))) format))) (defn compile-format "Compiles format-str into a compiled format which can be used as an argument to cl-format just like a plain format string. Use this function for improved performance when you're using the same format string repeatedly" [ format-str ] ; (prlabel compiling format-str) (binding [*format-str* format-str] (process-nesting (first (consume (fn [[^String s offset]] (if (empty? s) [nil s] (let [tilde (.indexOf s (int \~))] (cond (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]] (zero? tilde) (compile-directive (subs s 1) (inc offset)) true [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]])))) [format-str 0]))))) (defn- needs-pretty "determine whether a given compiled format has any directives that depend on the column number or pretty printing" [format] (loop [format format] (if (empty? format) false (if (or (:pretty (:flags (:def (first format)))) (some needs-pretty (first (:clauses (:params (first format))))) (some needs-pretty (first (:else (:params (first format)))))) true (recur (next format)))))) (defn execute-format "Executes the format with the arguments. This should never be used directly, but is public because the formatter macro uses it." {:skip-wiki true} ([stream format args] (let [^java.io.Writer real-stream (cond (not stream) (java.io.StringWriter.) (true? stream) *out* :else stream) ^java.io.Writer wrapped-stream (if (and (needs-pretty format) (not (pretty-writer? real-stream))) (get-pretty-writer real-stream) real-stream)] (binding [*out* wrapped-stream] (try (execute-format format args) (finally (if-not (identical? real-stream wrapped-stream) (.flush wrapped-stream)))) (if (not stream) (.toString real-stream))))) ([format args] (map-passing-context (fn [element context] (if (abort? context) [nil context] (let [[params args] (realize-parameter-list (:params element) context) [params offsets] (unzip-map params) params (assoc params :base-args args)] [nil (apply (:func element) [params args offsets])]))) args format))) (defmacro formatter "Makes a function which can directly run format-in. The function is fn [stream & args] ... and returns nil unless the stream is nil (meaning output to a string) in which case it returns the resulting string. format-in can be either a control string or a previously compiled format." [format-in] (let [cf (gensym "compiled-format")] `(let [format-in# ~format-in] (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) (fn [stream# & args#] (let [navigator# (init-navigator args#)] (execute-format stream# ~cf navigator#))))))) (defmacro formatter-out "Makes a function which can directly run format-in. The function is fn [& args] ... and returns nil. This version of the formatter macro is designed to be used with *out* set to an appropriate Writer. In particular, this is meant to be used as part of a pretty printer dispatch method. format-in can be either a control string or a previously compiled format." [format-in] (let [cf (gensym "compiled-format")] `(let [format-in# ~format-in] (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) (fn [& args#] (let [navigator# (init-navigator args#)] (execute-format ~cf navigator#))))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/column_writer.clj000066400000000000000000000052401161102570000310060ustar00rootroot00000000000000;;; column_writer.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ;; Revised to use proxy instead of gen-class April 2010 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This module implements a column-aware wrapper around an instance of java.io.Writer (ns clojure.contrib.pprint.column-writer (:import [clojure.lang IDeref] [java.io Writer])) (def *default-page-width* 72) (defn- get-field [^Writer this sym] (sym @@this)) (defn- set-field [^Writer this sym new-val] (alter @this assoc sym new-val)) (defn get-column [this] (get-field this :cur)) (defn get-line [this] (get-field this :line)) (defn get-max-column [this] (get-field this :max)) (defn set-max-column [this new-max] (dosync (set-field this :max new-max)) nil) (defn get-writer [this] (get-field this :base)) (defn- write-char [^Writer this ^Integer c] (dosync (if (= c (int \newline)) (do (set-field this :cur 0) (set-field this :line (inc (get-field this :line)))) (set-field this :cur (inc (get-field this :cur))))) (.write ^Writer (get-field this :base) c)) (defn column-writer ([writer] (column-writer writer *default-page-width*)) ([writer max-columns] (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})] (proxy [Writer IDeref] [] (deref [] fields) (write ([^chars cbuf ^Integer off ^Integer len] (let [^Writer writer (get-field this :base)] (.write writer cbuf off len))) ([x] (condp = (class x) String (let [^String s x nl (.lastIndexOf s (int \newline))] (dosync (if (neg? nl) (set-field this :cur (+ (get-field this :cur) (count s))) (do (set-field this :cur (- (count s) nl 1)) (set-field this :line (+ (get-field this :line) (count (filter #(= % \newline) s))))))) (.write ^Writer (get-field this :base) s)) Integer (write-char this x) Long (write-char this x)))))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/dispatch.clj000066400000000000000000000414111161102570000277140ustar00rootroot00000000000000;; dispatch.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Feb 2009. 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. ;; This module implements the default dispatch tables for pretty printing code and ;; data. (in-ns 'clojure.contrib.pprint) (defn use-method "Installs a function as a new method of multimethod associated with dispatch-value. " [multifn dispatch-val func] (. multifn addMethod dispatch-val func)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementations of specific dispatch table entries ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Handle forms that can be "back-translated" to reader macros ;;; Not all reader macros can be dealt with this way or at all. ;;; Macros that we can't deal with at all are: ;;; ; - The comment character is aborbed by the reader and never is part of the form ;;; ` - Is fully processed at read time into a lisp expression (which will contain concats ;;; and regular quotes). ;;; ~@ - Also fully eaten by the processing of ` and can't be used outside. ;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas ;;; where they deem them useful to help readability. ;;; ^ - Adding metadata completely disappears at read time and the data appears to be ;;; completely lost. ;;; ;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{}) ;;; or directly by printing the objects using Clojure's built-in print functions (like ;;; :keyword, \char, or ""). The notable exception is #() which is special-cased. (def reader-macros {'quote "'", 'clojure.core/deref "@", 'var "#'", 'clojure.core/unquote "~"}) (defn pprint-reader-macro [alis] (let [^String macro-char (reader-macros (first alis))] (when (and macro-char (= 2 (count alis))) (.write ^java.io.Writer *out* macro-char) (write-out (second alis)) true))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Dispatch for the basic data types when interpreted ;; as data (as opposed to code). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; TODO: inline these formatter statements into funcs so that we ;;; are a little easier on the stack. (Or, do "real" compilation, a ;;; la Common Lisp) ;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>")) (defn pprint-simple-list [alis] (pprint-logical-block :prefix "(" :suffix ")" (loop [alis (seq alis)] (when alis (write-out (first alis)) (when (next alis) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (recur (next alis))))))) (defn pprint-list [alis] (if-not (pprint-reader-macro alis) (pprint-simple-list alis))) ;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>")) (defn pprint-vector [avec] (pprint-logical-block :prefix "[" :suffix "]" (loop [aseq (seq avec)] (when aseq (write-out (first aseq)) (when (next aseq) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (recur (next aseq))))))) (def pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>")) ;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>")) (defn pprint-map [amap] (pprint-logical-block :prefix "{" :suffix "}" (loop [aseq (seq amap)] (when aseq (pprint-logical-block (write-out (ffirst aseq)) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (write-out (fnext (first aseq)))) (when (next aseq) (.write ^java.io.Writer *out* ", ") (pprint-newline :linear) (recur (next aseq))))))) (def pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>")) (defn pprint-ref [ref] (pprint-logical-block :prefix "#" (write-out @ref))) (defn pprint-atom [ref] (pprint-logical-block :prefix "#" (write-out @ref))) (defn pprint-agent [ref] (pprint-logical-block :prefix "#" (write-out @ref))) (defn pprint-simple-default [obj] (cond (.isArray (class obj)) (pprint-array obj) (and *print-suppress-namespaces* (symbol? obj)) (print (name obj)) :else (pr obj))) (defmulti *simple-dispatch* "The pretty print dispatch function for simple data structure format." {:arglists '[[object]]} class) (use-method *simple-dispatch* clojure.lang.ISeq pprint-list) (use-method *simple-dispatch* clojure.lang.IPersistentVector pprint-vector) (use-method *simple-dispatch* clojure.lang.IPersistentMap pprint-map) (use-method *simple-dispatch* clojure.lang.IPersistentSet pprint-set) (use-method *simple-dispatch* clojure.lang.Ref pprint-ref) (use-method *simple-dispatch* clojure.lang.Atom pprint-atom) (use-method *simple-dispatch* clojure.lang.Agent pprint-agent) (use-method *simple-dispatch* nil pr) (use-method *simple-dispatch* :default pprint-simple-default) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Dispatch for the code table ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare pprint-simple-code-list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Format something that looks like a simple def (sans metadata, since the reader ;;; won't give it to us now). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Format something that looks like a defn or defmacro ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Format the params and body of a defn with a single arity (defn- single-defn [alis has-doc-str?] (if (seq alis) (do (if has-doc-str? ((formatter-out " ~_")) ((formatter-out " ~@_"))) ((formatter-out "~{~w~^ ~_~}") alis)))) ;;; Format the param and body sublists of a defn with multiple arities (defn- multi-defn [alis has-doc-str?] (if (seq alis) ((formatter-out " ~_~{~w~^ ~_~}") alis))) ;;; TODO: figure out how to support capturing metadata in defns (we might need a ;;; special reader) (defn pprint-defn [alis] (if (next alis) (let [[defn-sym defn-name & stuff] alis [doc-str stuff] (if (string? (first stuff)) [(first stuff) (next stuff)] [nil stuff]) [attr-map stuff] (if (map? (first stuff)) [(first stuff) (next stuff)] [nil stuff])] (pprint-logical-block :prefix "(" :suffix ")" ((formatter-out "~w ~1I~@_~w") defn-sym defn-name) (if doc-str ((formatter-out " ~_~w") doc-str)) (if attr-map ((formatter-out " ~_~w") attr-map)) ;; Note: the multi-defn case will work OK for malformed defns too (cond (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) :else (multi-defn stuff (or doc-str attr-map))))) (pprint-simple-code-list alis))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Format something with a binding form ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn pprint-binding-form [binding-vec] (pprint-logical-block :prefix "[" :suffix "]" (loop [binding binding-vec] (when (seq binding) (pprint-logical-block binding (write-out (first binding)) (when (next binding) (.write ^java.io.Writer *out* " ") (pprint-newline :miser) (write-out (second binding)))) (when (next (rest binding)) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (recur (next (rest binding)))))))) (defn pprint-let [alis] (let [base-sym (first alis)] (pprint-logical-block :prefix "(" :suffix ")" (if (and (next alis) (vector? (second alis))) (do ((formatter-out "~w ~1I~@_") base-sym) (pprint-binding-form (second alis)) ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis)))) (pprint-simple-code-list alis))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Format something that looks like "if" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>")) (defn pprint-cond [alis] (pprint-logical-block :prefix "(" :suffix ")" (pprint-indent :block 1) (write-out (first alis)) (when (next alis) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (loop [alis (next alis)] (when alis (pprint-logical-block alis (write-out (first alis)) (when (next alis) (.write ^java.io.Writer *out* " ") (pprint-newline :miser) (write-out (second alis)))) (when (next (rest alis)) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (recur (next (rest alis))))))))) (defn pprint-condp [alis] (if (> (count alis) 3) (pprint-logical-block :prefix "(" :suffix ")" (pprint-indent :block 1) (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis) (loop [alis (seq (drop 3 alis))] (when alis (pprint-logical-block alis (write-out (first alis)) (when (next alis) (.write ^java.io.Writer *out* " ") (pprint-newline :miser) (write-out (second alis)))) (when (next (rest alis)) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (recur (next (rest alis))))))) (pprint-simple-code-list alis))) ;;; The map of symbols that are defined in an enclosing #() anonymous function (def *symbol-map* {}) (defn pprint-anon-func [alis] (let [args (second alis) nlis (first (rest (rest alis)))] (if (vector? args) (binding [*symbol-map* (if (= 1 (count args)) {(first args) "%"} (into {} (map #(vector %1 (str \% %2)) args (range 1 (inc (count args))))))] ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis)) (pprint-simple-code-list alis)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The master definitions for formatting lists in code (that is, (fn args...) or ;;; special forms). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is ;;; easier on the stack. (defn pprint-simple-code-list [alis] (pprint-logical-block :prefix "(" :suffix ")" (pprint-indent :block 1) (loop [alis (seq alis)] (when alis (write-out (first alis)) (when (next alis) (.write ^java.io.Writer *out* " ") (pprint-newline :linear) (recur (next alis))))))) ;;; Take a map with symbols as keys and add versions with no namespace. ;;; That is, if ns/sym->val is in the map, add sym->val to the result. (defn two-forms [amap] (into {} (mapcat identity (for [x amap] [x [(symbol (name (first x))) (second x)]])))) (defn add-core-ns [amap] (let [core "clojure.core"] (into {} (map #(let [[s f] %] (if (not (or (namespace s) (special-symbol? s))) [(symbol core (name s)) f] %)) amap)))) (def *code-table* (two-forms (add-core-ns {'def pprint-hold-first, 'defonce pprint-hold-first, 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn, 'let pprint-let, 'loop pprint-let, 'binding pprint-let, 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let, 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let, 'when-first pprint-let, 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if, 'cond pprint-cond, 'condp pprint-condp, 'fn* pprint-anon-func, '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first, 'locking pprint-hold-first, 'struct pprint-hold-first, 'struct-map pprint-hold-first, }))) (defn pprint-code-list [alis] (if-not (pprint-reader-macro alis) (if-let [special-form (*code-table* (first alis))] (special-form alis) (pprint-simple-code-list alis)))) (defn pprint-code-symbol [sym] (if-let [arg-num (sym *symbol-map*)] (print arg-num) (if *print-suppress-namespaces* (print (name sym)) (pr sym)))) (defmulti *code-dispatch* "The pretty print dispatch function for pretty printing Clojure code." {:arglists '[[object]]} class) (use-method *code-dispatch* clojure.lang.ISeq pprint-code-list) (use-method *code-dispatch* clojure.lang.Symbol pprint-code-symbol) ;; The following are all exact copies of *simple-dispatch* (use-method *code-dispatch* clojure.lang.IPersistentVector pprint-vector) (use-method *code-dispatch* clojure.lang.IPersistentMap pprint-map) (use-method *code-dispatch* clojure.lang.IPersistentSet pprint-set) (use-method *code-dispatch* clojure.lang.Ref pprint-ref) (use-method *code-dispatch* clojure.lang.Atom pprint-atom) (use-method *code-dispatch* clojure.lang.Agent pprint-agent) (use-method *code-dispatch* nil pr) (use-method *code-dispatch* :default pprint-simple-default) (set-pprint-dispatch *simple-dispatch*) ;;; For testing (comment (with-pprint-dispatch *code-dispatch* (pprint '(defn cl-format "An implementation of a Common Lisp compatible format function" [stream format-in & args] (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) navigator (init-navigator args)] (execute-format stream compiled-format navigator))))) (with-pprint-dispatch *code-dispatch* (pprint '(defn cl-format [stream format-in & args] (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) navigator (init-navigator args)] (execute-format stream compiled-format navigator))))) (with-pprint-dispatch *code-dispatch* (pprint '(defn- -write ([this x] (condp = (class x) String (let [s0 (write-initial-lines this x) s (.replaceFirst s0 "\\s+$" "") white-space (.substring s0 (count s)) mode (getf :mode)] (if (= mode :writing) (dosync (write-white-space this) (.col_write this s) (setf :trailing-white-space white-space)) (add-to-buffer this (make-buffer-blob s white-space)))) Integer (let [c ^Character x] (if (= (getf :mode) :writing) (do (write-white-space this) (.col_write this x)) (if (= c (int \newline)) (write-initial-lines this "\n") (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))))))) (with-pprint-dispatch *code-dispatch* (pprint '(defn pprint-defn [writer alis] (if (next alis) (let [[defn-sym defn-name & stuff] alis [doc-str stuff] (if (string? (first stuff)) [(first stuff) (next stuff)] [nil stuff]) [attr-map stuff] (if (map? (first stuff)) [(first stuff) (next stuff)] [nil stuff])] (pprint-logical-block writer :prefix "(" :suffix ")" (cl-format true "~w ~1I~@_~w" defn-sym defn-name) (if doc-str (cl-format true " ~_~w" doc-str)) (if attr-map (cl-format true " ~_~w" attr-map)) ;; Note: the multi-defn case will work OK for malformed defns too (cond (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) :else (multi-defn stuff (or doc-str attr-map))))) (pprint-simple-code-list writer alis))))) ) nil clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/pprint_base.clj000066400000000000000000000325121161102570000304250ustar00rootroot00000000000000;;; pprint_base.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Jan 2009. 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. ;; This module implements the generic pretty print functions and special variables (in-ns 'clojure.contrib.pprint) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables that control the pretty printer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core ;;; TODO: use *print-dup* here (or is it supplanted by other variables?) ;;; TODO: make dispatch items like "(let..." get counted in *print-length* ;;; constructs (def ^{ :doc "Bind to true if you want write to use pretty printing"} *print-pretty* true) (defonce ; If folks have added stuff here, don't overwrite ^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch to modify."} *print-pprint-dispatch* nil) (def ^{ :doc "Pretty printing will try to avoid anything going beyond this column. Set it to nil to have pprint let the line be arbitrarily long. This will ignore all non-mandatory newlines."} *print-right-margin* 72) (def ^{ :doc "The column at which to enter miser style. Depending on the dispatch table, miser style add newlines in more places to try to keep lines short allowing for further levels of nesting."} *print-miser-width* 40) ;;; TODO implement output limiting (def ^{ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"} *print-lines* nil) ;;; TODO: implement circle and shared (def ^{ :doc "Mark circular structures (N.B. This is not yet used)"} *print-circle* nil) ;;; TODO: should we just use *print-dup* here? (def ^{ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"} *print-shared* nil) (def ^{ :doc "Don't print namespaces with symbols. This is particularly useful when pretty printing the results of macro expansions"} *print-suppress-namespaces* nil) ;;; TODO: support print-base and print-radix in cl-format ;;; TODO: support print-base and print-radix in rationals (def ^{ :doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the radix specifier is in the form #XXr where XX is the decimal value of *print-base* "} *print-radix* nil) (def ^{ :doc "The base to use for printing integers and rationals."} *print-base* 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal variables that keep track of where we are in the ;; structure ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def ^{ :private true } *current-level* 0) (def ^{ :private true } *current-length* nil) ;; TODO: add variables for length, lines. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Support for the write function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare format-simple-number) (def ^{:private true} orig-pr pr) (defn- pr-with-base [x] (if-let [s (format-simple-number x)] (print s) (orig-pr x))) (def ^{:private true} write-option-table {;:array *print-array* :base 'clojure.contrib.pprint/*print-base*, ;;:case *print-case*, :circle 'clojure.contrib.pprint/*print-circle*, ;;:escape *print-escape*, ;;:gensym *print-gensym*, :length 'clojure.core/*print-length*, :level 'clojure.core/*print-level*, :lines 'clojure.contrib.pprint/*print-lines*, :miser-width 'clojure.contrib.pprint/*print-miser-width*, :dispatch 'clojure.contrib.pprint/*print-pprint-dispatch*, :pretty 'clojure.contrib.pprint/*print-pretty*, :radix 'clojure.contrib.pprint/*print-radix*, :readably 'clojure.core/*print-readably*, :right-margin 'clojure.contrib.pprint/*print-right-margin*, :suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*}) (defmacro ^{:private true} binding-map [amap & body] (let [] `(do (. clojure.lang.Var (pushThreadBindings ~amap)) (try ~@body (finally (. clojure.lang.Var (popThreadBindings))))))) (defn- table-ize [t m] (apply hash-map (mapcat #(when-let [v (get t (key %))] [(find-var v) (val %)]) m))) (defn- pretty-writer? "Return true iff x is a PrettyWriter" [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x))) (defn- make-pretty-writer "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width" [base-writer right-margin miser-width] (pretty-writer base-writer right-margin miser-width)) (defmacro ^{:private true} with-pretty-writer [base-writer & body] `(let [base-writer# ~base-writer new-writer# (not (pretty-writer? base-writer#))] (binding [*out* (if new-writer# (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*) base-writer#)] ~@body (.flush *out*)))) ;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc. (defn write-out "Write an object to *out* subject to the current bindings of the printer control variables. Use the kw-args argument to override individual variables for this call (and any recursive calls). *out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility of the caller. This method is primarily intended for use by pretty print dispatch functions that already know that the pretty printer will have set up their environment appropriately. Normal library clients should use the standard \"write\" interface. " [object] (let [length-reached (and *current-length* *print-length* (>= *current-length* *print-length*))] (if-not *print-pretty* (pr object) (if length-reached (print "...") (do (if *current-length* (set! *current-length* (inc *current-length*))) (*print-pprint-dispatch* object)))) length-reached)) (defn write "Write an object subject to the current bindings of the printer control variables. Use the kw-args argument to override individual variables for this call (and any recursive calls). Returns the string result if :stream is nil or nil otherwise. The following keyword arguments can be passed with values: Keyword Meaning Default value :stream Writer for output or nil true (indicates *out*) :base Base to use for writing rationals Current value of *print-base* :circle* If true, mark circular structures Current value of *print-circle* :length Maximum elements to show in sublists Current value of *print-length* :level Maximum depth Current value of *print-level* :lines* Maximum lines of output Current value of *print-lines* :miser-width Width to enter miser mode Current value of *print-miser-width* :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch* :pretty If true, do pretty printing Current value of *print-pretty* :radix If true, prepend a radix specifier Current value of *print-radix* :readably* If true, print readably Current value of *print-readably* :right-margin The column for the right margin Current value of *print-right-margin* :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces* * = not yet supported " [object & kw-args] (let [options (merge {:stream true} (apply hash-map kw-args))] (binding-map (table-ize write-option-table options) (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) (let [optval (if (contains? options :stream) (:stream options) true) base-writer (condp = optval nil (java.io.StringWriter.) true *out* optval)] (if *print-pretty* (with-pretty-writer base-writer (write-out object)) (binding [*out* base-writer] (pr object))) (if (nil? optval) (.toString ^java.io.StringWriter base-writer))))))) (defn pprint "Pretty print object to the optional output writer. If the writer is not provided, print the object to the currently bound value of *out*." ([object] (pprint object *out*)) ([object writer] (with-pretty-writer writer (binding [*print-pretty* true] (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) (write-out object))) (if (not (= 0 (get-column *out*))) (.write *out* (int \newline)))))) (defmacro pp "A convenience macro that pretty prints the last thing output. This is exactly equivalent to (pprint *1)." [] `(pprint *1)) (defn set-pprint-dispatch "Set the pretty print dispatch function to a function matching (fn [obj] ...) where obj is the object to pretty print. That function will be called with *out* set to a pretty printing writer to which it should do its printing. For example functions, see *simple-dispatch* and *code-dispatch* in clojure.contrib.pprint.dispatch.clj." [function] (let [old-meta (meta #'*print-pprint-dispatch*)] (alter-var-root #'*print-pprint-dispatch* (constantly function)) (alter-meta! #'*print-pprint-dispatch* (constantly old-meta))) nil) (defmacro with-pprint-dispatch "Execute body with the pretty print dispatch function bound to function." [function & body] `(binding [*print-pprint-dispatch* ~function] ~@body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Support for the functional interface to the pretty printer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- parse-lb-options [opts body] (loop [body body acc []] (if (opts (first body)) (recur (drop 2 body) (concat acc (take 2 body))) [(apply hash-map acc) body]))) (defn- check-enumerated-arg [arg choices] (if-not (choices arg) (throw (IllegalArgumentException. ;; TODO clean up choices string (str "Bad argument: " arg ". It must be one of " choices))))) (defn level-exceeded [] (and *print-level* (>= *current-level* *print-level*))) (defmacro pprint-logical-block "Execute the body as a pretty printing logical block with output to *out* which must be a pretty printing writer. When used from pprint or cl-format, this can be assumed. Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, and :suffix." {:arglists '[[options* body]]} [& args] (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)] `(do (if (level-exceeded) (.write ^java.io.Writer *out* "#") (binding [*current-level* (inc *current-level*) *current-length* 0] (start-block *out* ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) ~@body (end-block *out*))) nil))) (defn pprint-newline "Print a conditional newline to a pretty printing stream. kind specifies if the newline is :linear, :miser, :fill, or :mandatory. Output is sent to *out* which must be a pretty printing writer." [kind] (check-enumerated-arg kind #{:linear :miser :fill :mandatory}) (nl *out* kind)) (defn pprint-indent "Create an indent at this point in the pretty printing stream. This defines how following lines are indented. relative-to can be either :block or :current depending whether the indent should be computed relative to the start of the logical block or the current column position. n is an offset. Output is sent to *out* which must be a pretty printing writer." [relative-to n] (check-enumerated-arg relative-to #{:block :current}) (indent *out* relative-to n)) ;; TODO a real implementation for pprint-tab (defn pprint-tab "Tab at this point in the pretty printing stream. kind specifies whether the tab is :line, :section, :line-relative, or :section-relative. Colnum and colinc specify the target column and the increment to move the target forward if the output is already past the original target. Output is sent to *out* which must be a pretty printing writer. THIS FUNCTION IS NOT YET IMPLEMENTED." [kind colnum colinc] (check-enumerated-arg kind #{:line :section :line-relative :section-relative}) (throw (UnsupportedOperationException. "pprint-tab is not yet implemented"))) nil clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/pretty_writer.clj000066400000000000000000000413111161102570000310370ustar00rootroot00000000000000;;; pretty_writer.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ;; Revised to use proxy instead of gen-class April 2010 ; Copyright (c) Tom Faulhaber, Jan 2009. 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. ;; This module implements a wrapper around a java.io.Writer which implements the ;; core of the XP algorithm. (ns clojure.contrib.pprint.pretty-writer (:refer-clojure :exclude (deftype)) (:use clojure.contrib.pprint.utilities) (:use [clojure.contrib.pprint.column-writer :only (column-writer get-column get-max-column)]) (:import [clojure.lang IDeref] [java.io Writer])) ;; TODO: Support for tab directives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Forward declarations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare get-miser-width) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Macros to simplify dealing with types and classes. These are ;;; really utilities, but I'm experimenting with them here. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro ^{:private true} getf "Get the value of the field a named by the argument (which should be a keyword)." [sym] `(~sym @@~'this)) (defmacro ^{:private true} setf [sym new-val] "Set the value of the field SYM to NEW-VAL" `(alter @~'this assoc ~sym ~new-val)) (defmacro ^{:private true} deftype [type-name & fields] (let [name-str (name type-name)] `(do (defstruct ~type-name :type-tag ~@fields) (defn- ~(symbol (str "make-" name-str)) [& vals#] (apply struct ~type-name ~(keyword name-str) vals#)) (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The data structures used by pretty-writer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct ^{:private true} logical-block :parent :section :start-col :indent :done-nl :intra-block-nl :prefix :per-line-prefix :suffix :logical-block-callback) (defn ancestor? [parent child] (loop [child (:parent child)] (cond (nil? child) false (identical? parent child) true :else (recur (:parent child))))) (defstruct ^{:private true} section :parent) (defn buffer-length [l] (let [l (seq l)] (if l (- (:end-pos (last l)) (:start-pos (first l))) 0))) ; A blob of characters (aka a string) (deftype buffer-blob :data :trailing-white-space :start-pos :end-pos) ; A newline (deftype nl-t :type :logical-block :start-pos :end-pos) (deftype start-block-t :logical-block :start-pos :end-pos) (deftype end-block-t :logical-block :start-pos :end-pos) (deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to write tokens in the output buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare emit-nl) (defmulti write-token #(:type-tag %2)) (defmethod write-token :start-block-t [^Writer this token] (when-let [cb (getf :logical-block-callback)] (cb :start)) (let [lb (:logical-block token)] (dosync (when-let [^String prefix (:prefix lb)] (.write (getf :base) prefix)) (let [col (get-column (getf :base))] (ref-set (:start-col lb) col) (ref-set (:indent lb) col))))) (defmethod write-token :end-block-t [^Writer this token] (when-let [cb (getf :logical-block-callback)] (cb :end)) (when-let [^String suffix (:suffix (:logical-block token))] (.write (getf :base) suffix))) (defmethod write-token :indent-t [^Writer this token] (let [lb (:logical-block token)] (ref-set (:indent lb) (+ (:offset token) (condp = (:relative-to token) :block @(:start-col lb) :current (get-column (getf :base))))))) (defmethod write-token :buffer-blob [^Writer this token] (.write (getf :base) ^String (:data token))) (defmethod write-token :nl-t [^Writer this token] ; (prlabel wt @(:done-nl (:logical-block token))) ; (prlabel wt (:type token) (= (:type token) :mandatory)) (if (or (= (:type token) :mandatory) (and (not (= (:type token) :fill)) @(:done-nl (:logical-block token)))) (emit-nl this token) (if-let [^String tws (getf :trailing-white-space)] (.write (getf :base) tws))) (dosync (setf :trailing-white-space nil))) (defn- write-tokens [^Writer this tokens force-trailing-whitespace] (doseq [token tokens] (if-not (= (:type-tag token) :nl-t) (if-let [^String tws (getf :trailing-white-space)] (.write (getf :base) tws))) (write-token this token) (setf :trailing-white-space (:trailing-white-space token))) (let [^String tws (getf :trailing-white-space)] (when (and force-trailing-whitespace tws) (.write (getf :base) tws) (setf :trailing-white-space nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; emit-nl? method defs for each type of new line. This makes ;;; the decision about whether to print this type of new line. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- tokens-fit? [^Writer this tokens] ;;; (prlabel tf? (get-column (getf :base) (buffer-length tokens)) (let [maxcol (get-max-column (getf :base))] (or (nil? maxcol) (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol)))) (defn- linear-nl? [this lb section] ; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section)) (or @(:done-nl lb) (not (tokens-fit? this section)))) (defn- miser-nl? [^Writer this lb section] (let [miser-width (get-miser-width this) maxcol (get-max-column (getf :base))] (and miser-width maxcol (>= @(:start-col lb) (- maxcol miser-width)) (linear-nl? this lb section)))) (defmulti emit-nl? (fn [t _ _ _] (:type t))) (defmethod emit-nl? :linear [newl this section _] (let [lb (:logical-block newl)] (linear-nl? this lb section))) (defmethod emit-nl? :miser [newl this section _] (let [lb (:logical-block newl)] (miser-nl? this lb section))) (defmethod emit-nl? :fill [newl this section subsection] (let [lb (:logical-block newl)] (or @(:intra-block-nl lb) (not (tokens-fit? this subsection)) (miser-nl? this lb section)))) (defmethod emit-nl? :mandatory [_ _ _ _] true) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Various support functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn- get-section [buffer] (let [nl (first buffer) lb (:logical-block nl) section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb))) (next buffer)))] [section (seq (drop (inc (count section)) buffer))])) (defn- get-sub-section [buffer] (let [nl (first buffer) lb (:logical-block nl) section (seq (take-while #(let [nl-lb (:logical-block %)] (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb))))) (next buffer)))] section)) (defn- update-nl-state [lb] (dosync (ref-set (:intra-block-nl lb) false) (ref-set (:done-nl lb) true) (loop [lb (:parent lb)] (if lb (do (ref-set (:done-nl lb) true) (ref-set (:intra-block-nl lb) true) (recur (:parent lb))))))) (defn emit-nl [^Writer this nl] (.write (getf :base) (int \newline)) (dosync (setf :trailing-white-space nil)) (let [lb (:logical-block nl) ^String prefix (:per-line-prefix lb)] (if prefix (.write (getf :base) prefix)) (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) \space))] (.write (getf :base) istr)) (update-nl-state lb))) (defn- split-at-newline [tokens] (let [pre (seq (take-while #(not (nl-t? %)) tokens))] [pre (seq (drop (count pre) tokens))])) ;;; Methods for showing token strings for debugging (defmulti tok :type-tag) (defmethod tok :nl-t [token] (:type token)) (defmethod tok :buffer-blob [token] (str \" (:data token) (:trailing-white-space token) \")) (defmethod tok :default [token] (:type-tag token)) (defn toks [toks] (map tok toks)) ;;; write-token-string is called when the set of tokens in the buffer ;;; is longer than the available space on the line (defn- write-token-string [this tokens] (let [[a b] (split-at-newline tokens)] ;; (prlabel wts (toks a) (toks b)) (if a (write-tokens this a false)) (if b (let [[section remainder] (get-section b) newl (first b)] ;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) (let [do-nl (emit-nl? newl this section (get-sub-section b)) result (if do-nl (do ;; (prlabel emit-nl (:type newl)) (emit-nl this newl) (next b)) b) long-section (not (tokens-fit? this result)) result (if long-section (let [rem2 (write-token-string this section)] ;;; (prlabel recurse (toks rem2)) (if (= rem2 section) (do ; If that didn't produce any output, it has no nls ; so we'll force it (write-tokens this section false) remainder) (into [] (concat rem2 remainder)))) result) ;; ff (prlabel wts (toks result)) ] result))))) (defn- write-line [^Writer this] (dosync (loop [buffer (getf :buffer)] ;; (prlabel wl1 (toks buffer)) (setf :buffer (into [] buffer)) (if (not (tokens-fit? this buffer)) (let [new-buffer (write-token-string this buffer)] ;; (prlabel wl new-buffer) (if-not (identical? buffer new-buffer) (recur new-buffer))))))) ;;; Add a buffer token to the buffer and see if it's time to start ;;; writing (defn- add-to-buffer [^Writer this token] ; (prlabel a2b token) (dosync (setf :buffer (conj (getf :buffer) token)) (if (not (tokens-fit? this (getf :buffer))) (write-line this)))) ;;; Write all the tokens that have been buffered (defn- write-buffered-output [^Writer this] (write-line this) (if-let [buf (getf :buffer)] (do (write-tokens this buf true) (setf :buffer [])))) ;;; If there are newlines in the string, print the lines up until the last newline, ;;; making the appropriate adjustments. Return the remainder of the string (defn- write-initial-lines [^Writer this ^String s] (let [lines (.split s "\n" -1)] (if (= (count lines) 1) s (dosync (let [^String prefix (:per-line-prefix (first (getf :logical-blocks))) ^String l (first lines)] (if (= :buffering (getf :mode)) (let [oldpos (getf :pos) newpos (+ oldpos (count l))] (setf :pos newpos) (add-to-buffer this (make-buffer-blob l nil oldpos newpos)) (write-buffered-output this)) (.write (getf :base) l)) (.write (getf :base) (int \newline)) (doseq [^String l (next (butlast lines))] (.write (getf :base) l) (.write (getf :base) (int \newline)) (if prefix (.write (getf :base) prefix))) (setf :buffering :writing) (last lines)))))) (defn write-white-space [^Writer this] (if-let [^String tws (getf :trailing-white-space)] (dosync (.write (getf :base) tws) (setf :trailing-white-space nil)))) (defn- write-char [^Writer this ^Integer c] (if (= (getf :mode) :writing) (do (write-white-space this) (.write (getf :base) c)) (if (= c \newline) (write-initial-lines this "\n") (let [oldpos (getf :pos) newpos (inc oldpos)] (dosync (setf :pos newpos) (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initialize the pretty-writer instance ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn pretty-writer [writer max-columns miser-width] (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false)) fields (ref {:pretty-writer true :base (column-writer writer max-columns) :logical-blocks lb :sections nil :mode :writing :buffer [] :buffer-block lb :buffer-level 1 :miser-width miser-width :trailing-white-space nil :pos 0})] (proxy [Writer IDeref] [] (deref [] fields) (write ([x] ;; (prlabel write x (getf :mode)) (condp = (class x) String (let [^String s0 (write-initial-lines this x) ^String s (.replaceFirst s0 "\\s+$" "") white-space (.substring s0 (count s)) mode (getf :mode)] (dosync (if (= mode :writing) (do (write-white-space this) (.write (getf :base) s) (setf :trailing-white-space white-space)) (let [oldpos (getf :pos) newpos (+ oldpos (count s0))] (setf :pos newpos) (add-to-buffer this (make-buffer-blob s white-space oldpos newpos)))))) Integer (write-char this x) Long (write-char this x)))) (flush [] (if (= (getf :mode) :buffering) (dosync (write-tokens this (getf :buffer) true) (setf :buffer [])) (write-white-space this))) (close [] (.flush this))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for pretty-writer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn start-block [^Writer this ^String prefix ^String per-line-prefix ^String suffix] (dosync (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0) (ref false) (ref false) prefix per-line-prefix suffix)] (setf :logical-blocks lb) (if (= (getf :mode) :writing) (do (write-white-space this) (when-let [cb (getf :logical-block-callback)] (cb :start)) (if prefix (.write (getf :base) prefix)) (let [col (get-column (getf :base))] (ref-set (:start-col lb) col) (ref-set (:indent lb) col))) (let [oldpos (getf :pos) newpos (+ oldpos (if prefix (count prefix) 0))] (setf :pos newpos) (add-to-buffer this (make-start-block-t lb oldpos newpos))))))) (defn end-block [^Writer this] (dosync (let [lb (getf :logical-blocks) ^String suffix (:suffix lb)] (if (= (getf :mode) :writing) (do (write-white-space this) (if suffix (.write (getf :base) suffix)) (when-let [cb (getf :logical-block-callback)] (cb :end))) (let [oldpos (getf :pos) newpos (+ oldpos (if suffix (count suffix) 0))] (setf :pos newpos) (add-to-buffer this (make-end-block-t lb oldpos newpos)))) (setf :logical-blocks (:parent lb))))) (defn nl [^Writer this type] (dosync (setf :mode :buffering) (let [pos (getf :pos)] (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))) (defn indent [^Writer this relative-to offset] (dosync (let [lb (getf :logical-blocks)] (if (= (getf :mode) :writing) (do (write-white-space this) (ref-set (:indent lb) (+ offset (condp = relative-to :block @(:start-col lb) :current (get-column (getf :base)))))) (let [pos (getf :pos)] (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))) (defn get-miser-width [^Writer this] (getf :miser-width)) (defn set-miser-width [^Writer this new-miser-width] (dosync (setf :miser-width new-miser-width))) (defn set-logical-block-callback [^Writer this f] (dosync (setf :logical-block-callback f))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/pprint/utilities.clj000066400000000000000000000070371161102570000301360ustar00rootroot00000000000000;;; utilities.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Jan 2009. 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. ;; This module implements some utility function used in formatting and pretty ;; printing. The functions here could go in a more general purpose library, ;; perhaps. (ns clojure.contrib.pprint.utilities) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Helper functions for digesting formats in the various ;;; phases of their lives. ;;; These functions are actually pretty general. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn map-passing-context [func initial-context lis] (loop [context initial-context lis lis acc []] (if (empty? lis) [acc context] (let [this (first lis) remainder (next lis) [result new-context] (apply func [this context])] (recur new-context remainder (conj acc result)))))) (defn consume [func initial-context] (loop [context initial-context acc []] (let [[result new-context] (apply func [context])] (if (not result) [acc new-context] (recur new-context (conj acc result)))))) (defn consume-while [func initial-context] (loop [context initial-context acc []] (let [[result continue new-context] (apply func [context])] (if (not continue) [acc context] (recur new-context (conj acc result)))))) (defn unzip-map [m] "Take a map that has pairs in the value slots and produce a pair of maps, the first having all the first elements of the pairs and the second all the second elements of the pairs" [(into {} (for [[k [v1 v2]] m] [k v1])) (into {} (for [[k [v1 v2]] m] [k v2]))]) (defn tuple-map [m v1] "For all the values, v, in the map, replace them with [v v1]" (into {} (for [[k v] m] [k [v v1]]))) (defn rtrim [s c] "Trim all instances of c from the end of sequence s" (let [len (count s)] (if (and (pos? len) (= (nth s (dec (count s))) c)) (loop [n (dec len)] (cond (neg? n) "" (not (= (nth s n) c)) (subs s 0 (inc n)) true (recur (dec n)))) s))) (defn ltrim [s c] "Trim all instances of c from the beginning of sequence s" (let [len (count s)] (if (and (pos? len) (= (nth s 0) c)) (loop [n 0] (if (or (= n len) (not (= (nth s n) c))) (subs s n) (recur (inc n)))) s))) (defn prefix-count [aseq val] "Return the number of times that val occurs at the start of sequence aseq, if val is a seq itself, count the number of times any element of val occurs at the beginning of aseq" (let [test (if (coll? val) (set val) #{val})] (loop [pos 0] (if (or (= pos (count aseq)) (not (test (nth aseq pos)))) pos (recur (inc pos)))))) (defn prerr [& args] "Println to *err*" (binding [*out* *err*] (apply println args))) (defmacro prlabel [prefix arg & more-args] "Print args to *err* in name = value format" `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) (cons arg (seq more-args)))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/probabilities/000077500000000000000000000000001161102570000267365ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/probabilities/finite_distributions.clj000066400000000000000000000145211161102570000336730ustar00rootroot00000000000000;; Finite probability distributions ;; by Konrad Hinsen ;; last updated January 8, 2010 ;; Copyright (c) Konrad Hinsen, 2009-2010. 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 ^{:author "Konrad Hinsen" :doc "Finite probability distributions This library defines a monad for combining finite probability distributions."} clojure.contrib.probabilities.finite-distributions (:use [clojure.contrib.monads :only (defmonad domonad with-monad maybe-t m-lift m-chain)] [clojure.contrib.def :only (defvar)])) ; The probability distribution monad. It is limited to finite probability ; distributions (e.g. there is a finite number of possible value), which ; are represented as maps from values to probabilities. (defmonad dist-m "Monad describing computations on fuzzy quantities, represented by a finite probability distribution for the possible values. A distribution is represented by a map from values to probabilities." [m-result (fn m-result-dist [v] {v 1}) m-bind (fn m-bind-dist [mv f] (reduce (partial merge-with +) (for [[x p] mv [y q] (f x)] {y (* q p)}))) ]) ; Applying the monad transformer maybe-t to the basic dist monad results ; in the cond-dist monad that can handle invalid values. The total probability ; for invalid values ends up as the probability of m-zero (which is nil). ; The function normalize takes this probability out of the distribution and ; re-distributes its weight over the valid values. (defvar cond-dist-m (maybe-t dist-m) "Variant of the dist monad that can handle undefined values.") ; Normalization (defn- scale-by "Multiply each entry in dist by the scale factor s and remove zero entries." [dist s] (into {} (for [[val p] dist :when (> p 0)] [val (* p s)]))) (defn normalize-cond [cdist] "Normalize a probability distribution resulting from a computation in the cond-dist monad by re-distributing the weight of the invalid values over the valid ones." (let [missing (get cdist nil 0) dist (dissoc cdist nil)] (cond (zero? missing) dist (= 1 missing) {} :else (let [scale (/ 1 (- 1 missing))] (scale-by dist scale))))) (defn normalize "Convert a weight map (e.g. a map of counter values) to a distribution by multiplying with a normalization factor. If the map has a key :total, its value is assumed to be the sum over all the other values and it is used for normalization. Otherwise, the sum is calculated explicitly. The :total key is removed from the resulting distribution." [weights] (let [total (:total weights) w (dissoc weights :total) s (/ 1 (if (nil? total) (reduce + (vals w)) total))] (scale-by w s))) ; Functions that construct distributions (defn uniform "Return a distribution in which each of the elements of coll has the same probability." [coll] (let [n (count coll) p (/ 1 n)] (into {} (for [x (seq coll)] [x p])))) (defn choose "Construct a distribution from an explicit list of probabilities and values. They are given in the form of a vector of probability-value pairs. In the last pair, the probability can be given by the keyword :else, which stands for 1 minus the total of the other probabilities." [& choices] (letfn [(add-choice [dist [p v]] (cond (nil? p) dist (= p :else) (let [total-p (reduce + (vals dist))] (assoc dist v (- 1 total-p))) :else (assoc dist v p)))] (reduce add-choice {} (partition 2 choices)))) (defn bernoulli [p] "Returns the Bernoulli distribution for probability p." (choose p 1 :else 0)) (defn- bc [n] "Returns the binomial coefficients for a given n." (let [r (inc n)] (loop [c 1 f (list 1)] (if (> c n) f (recur (inc c) (cons (* (/ (- r c) c) (first f)) f)))))) (defn binomial [n p] "Returns the binomial distribution, which is the distribution of the number of successes in a series of n experiments whose individual success probability is p." (let [q (- 1 p) n1 (inc n) k (range n1) pk (take n1 (iterate #(* p %) 1)) ql (reverse (take n1 (iterate #(* q %) 1))) f (bc n)] (into {} (map vector k (map * f pk ql))))) (defn make-distribution "Returns the distribution in which each element x of the collection has a probability proportional to (f x)" [coll f] (normalize (into {} (for [k coll] [k (f k)])))) (defn zipf "Returns the Zipf distribution in which the numbers k=1..n have probabilities proportional to 1/k^s." [s n] (make-distribution (range 1 (inc n)) #(/ (java.lang.Math/pow % s)))) (defn certainly "Returns a distribution in which the single value v has probability 1." [v] {v 1}) (with-monad dist-m (defn join-with "Returns the distribution of (f x y) with x from dist1 and y from dist2." [f dist1 dist2] ((m-lift 2 f) dist1 dist2)) ) (with-monad cond-dist-m (defn cond-prob "Returns the conditional probability for the values in dist that satisfy the predicate pred." [pred dist] (normalize-cond (domonad [v dist :when (pred v)] v)))) ; Select (with equal probability) N items from a sequence (defn- nth-and-rest [n xs] "Return a list containing the n-th value of xs and the sequence obtained by removing the n-th value from xs." (let [[h t] (split-at n xs)] (list (first t) (concat h (rest t))))) (with-monad dist-m (defn- select-n [n xs] (letfn [(select-1 [[s xs]] (uniform (for [i (range (count xs))] (let [[nth rest] (nth-and-rest i xs)] (list (cons nth s) rest)))))] ((m-chain (replicate n select-1)) (list '() xs)))) (defn select [n xs] "Return the distribution for all possible ordered selections of n elements out of xs." ((m-lift 1 first) (select-n n xs))) ) ; Find the probability that a given predicate is satisfied (defn prob "Return the probability that the predicate pred is satisfied in the distribution dist, i.e. the sum of the probabilities of the values that satisfy pred." [pred dist] (apply + (for [[x p] dist :when (pred x)] p))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/probabilities/monte_carlo.clj000066400000000000000000000207721161102570000317420ustar00rootroot00000000000000;; Monte-Carlo algorithms ;; by Konrad Hinsen ;; last updated May 3, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Monte-Carlo method support Monte-Carlo methods transform an input random number stream (usually having a continuous uniform distribution in the interval [0, 1)) into a random number stream whose distribution satisfies certain conditions (usually the expectation value is equal to some desired quantity). They are thus transformations from one probability distribution to another one. This library represents a Monte-Carlo method by a function that takes as input the state of a random number stream with uniform distribution (see clojure.contrib.probabilities.random-numbers) and returns a vector containing one sample value of the desired output distribution and the final state of the input random number stream. Such functions are state monad values and can be composed using operations defined in clojure.contrib.monads."} clojure.contrib.probabilities.monte-carlo (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.macros :only (const)]) (:use [clojure.contrib.types :only (deftype)]) (:use [clojure.contrib.stream-utils :only (defstream stream-next)]) (:use [clojure.contrib.monads :only (with-monad state-m m-lift m-seq m-fmap)]) (:require [clojure.contrib.generic.arithmetic :as ga]) (:require [clojure.contrib.accumulators :as acc])) ;; Random number transformers and random streams ;; ;; A random number transformer is a function that takes a random stream ;; state as input and returns the next value from the transformed stream ;; plus the new state of the input stream. Random number transformers ;; are thus state monad values. ;; ;; Distributions are implemented as random number transformers that ;; transform a uniform distribution in the interval [0, 1) to the ;; desired distribution. Composition of such distributions allows ;; the realization of any kind of Monte-Carlo algorithm. The result ;; of such a composition is always again a distribution. ;; ;; Random streams are defined by a random number transformer and an ;; input random number stream. If the randon number transformer represents ;; a distribution, the input stream must have a uniform distribution ;; in the interval [0, 1). ; Random stream definition (deftype ::random-stream random-stream "Define a random stream by a distribution and the state of a random number stream with uniform distribution in [0, 1)." {:arglists '([distribution random-stream-state])} (fn [d rs] (list d rs))) (defstream ::random-stream [[d rs]] (let [[r nrs] (d rs)] [r (random-stream d nrs)])) ; Rejection of values is used in the construction of distributions (defn reject "Return the distribution that results from rejecting the values from dist that do not satisfy predicate p." [p dist] (fn [rs] (let [[r nrs] (dist rs)] (if (p r) (recur nrs) [r nrs])))) ; Draw a value from a discrete distribution given as a map from ; values to probabilities. ; (see clojure.contrib.probabilities.finite-distributions) (with-monad state-m (defn discrete "A discrete distribution, defined by a map dist mapping values to probabilities. The sum of probabilities must be one." [dist] (letfn [(pick-at-level [l dist-items] (let [[[x p] & rest-dist] dist-items] (if (> p l) x (recur (- l p) rest-dist))))] (m-fmap #(pick-at-level % (seq dist)) stream-next)))) ; Uniform distribution in an finite half-open interval (with-monad state-m (defn interval [a b] "Transform a sequence of uniform random numbers in the interval [0, 1) into a sequence of uniform random numbers in the interval [a, b)." (let [d (- b a) f (if (zero? a) (if (= d 1) identity (fn [r] (* d r))) (if (= d 1) (fn [r] (+ a r)) (fn [r] (+ a (* d r)))))] (m-fmap f stream-next)))) ; Normal (Gaussian) distribution (defn normal "Transform a sequence urs of uniform random number in the interval [0, 1) into a sequence of normal random numbers with mean mu and standard deviation sigma." [mu sigma] ; This function implements the Kinderman-Monahan ratio method: ; A.J. Kinderman & J.F. Monahan ; Computer Generation of Random Variables Using the Ratio of Uniform Deviates ; ACM Transactions on Mathematical Software 3(3) 257-260, 1977 (fn [rs] (let [[u1 rs] (stream-next rs) [u2* rs] (stream-next rs) u2 (- 1. u2*) s (const (* 4 (/ (. Math exp (- 0.5)) (. Math sqrt 2.)))) z (* s (/ (- u1 0.5) u2)) zz (+ (* 0.25 z z) (. Math log u2))] (if (> zz 0) (recur rs) [(+ mu (* sigma z)) rs])))) ; Lognormal distribution (with-monad state-m (defn lognormal "Transform a sequence of uniform random numbesr in the interval [0, 1) into a sequence of lognormal random numbers with mean mu and standard deviation sigma." [mu sigma] (m-fmap #(. Math exp %) (normal mu sigma)))) ; Exponential distribution (with-monad state-m (defn exponential "Transform a sequence of uniform random numbers in the interval [0, 1) into a sequence of exponential random numbers with parameter lambda." [lambda] (when (<= lambda 0) (throw (IllegalArgumentException. "exponential distribution requires a positive argument"))) (let [neg-inv-lambda (- (/ lambda)) ; remove very small numbers to prevent log from returning -Infinity not-too-small (reject #(< % 1e-323) stream-next)] (m-fmap #(* (. Math log %) neg-inv-lambda) not-too-small)))) ; Another implementation of the normal distribution. It uses the ; Box-Muller transform, but discards one of the two result values ; at each cycle because the random number transformer interface cannot ; handle two outputs at the same time. (defn normal-box-muller "Transform a sequence of uniform random numbers in the interval [0, 1) into a sequence of normal random numbers with mean mu and standard deviation sigma." [mu sigma] (fn [rs] (let [[u1 rs] (stream-next rs) [u2 rs] (stream-next rs) v1 (- (* 2.0 u1) 1.0) v2 (- (* 2.0 u2) 1.0) s (+ (* v1 v1) (* v2 v2)) ls (. Math sqrt (/ (* -2.0 (. Math log s)) s)) x1 (* v1 ls) x2 (* v2 ls)] (if (or (>= s 1) (= s 0)) (recur rs) [x1 rs])))) ; Finite samples from a distribution (with-monad state-m (defn sample "Return the distribution of samples of length n from the distribution dist" [n dist] (m-seq (replicate n dist))) (defn sample-reduce "Returns the distribution of the reduction of f over n samples from the distribution dist." ([f n dist] (if (zero? n) (m-result (f)) (let [m-f (m-lift 2 f) sample (replicate n dist)] (reduce m-f sample)))) ([f val n dist] (let [m-f (m-lift 2 f) m-val (m-result val) sample (replicate n dist)] (reduce m-f m-val sample)))) (defn sample-sum "Return the distribution of the sum over n samples from the distribution dist." [n dist] (sample-reduce ga/+ n dist)) (defn sample-mean "Return the distribution of the mean over n samples from the distribution dist" [n dist] (let [div-by-n (m-lift 1 #(ga/* % (/ n)))] (div-by-n (sample-sum n dist)))) (defn sample-mean-variance "Return the distribution of the mean-and-variance (a vector containing the mean and the variance) over n samples from the distribution dist" [n dist] (let [extract (m-lift 1 (fn [mv] [(:mean mv) (:variance mv)]))] (extract (sample-reduce acc/add acc/empty-mean-variance n dist)))) ) ; Uniform distribution inside an n-sphere (with-monad state-m (defn n-sphere "Return a uniform distribution of n-dimensional vectors inside an n-sphere of radius r." [n r] (let [box-dist (sample n (interval (- r) r)) sq #(* % %) r-sq (sq r) vec-sq #(apply + (map sq %)) sphere-dist (reject #(> (vec-sq %) r-sq) box-dist) as-vectors (m-lift 1 vec)] (as-vectors sphere-dist)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/probabilities/random_numbers.clj000066400000000000000000000046121161102570000324460ustar00rootroot00000000000000;; Random number generators ;; by Konrad Hinsen ;; last updated May 3, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Random number streams This library provides random number generators with a common stream interface. They all produce pseudo-random numbers that are uniformly distributed in the interval [0, 1), i.e. 0 is a possible value but 1 isn't. For transformations to other distributions, see clojure.contrib.probabilities.monte-carlo. At the moment, the only generator provided is a rather simple linear congruential generator."} clojure.contrib.probabilities.random-numbers (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.types :only (deftype)]) (:use [clojure.contrib.stream-utils :only (defstream)]) (:use [clojure.contrib.def :only (defvar)])) ;; Linear congruential generator ;; http://en.wikipedia.org/wiki/Linear_congruential_generator (deftype ::lcg lcg "Create a linear congruential generator" {:arglists '([modulus multiplier increment seed])} (fn [modulus multiplier increment seed] {:m modulus :a multiplier :c increment :seed seed}) (fn [s] (map s (list :m :a :c :seed)))) (defstream ::lcg [lcg-state] (let [{m :m a :a c :c seed :seed} lcg-state value (/ (float seed) (float m)) new-seed (rem (+ c (* a seed)) m)] [value (assoc lcg-state :seed new-seed)])) ;; A generator based on Clojure's built-in rand function ;; (and thus random from java.lang.Math) ;; Note that this generator uses an internal mutable state. ;; ;; The state is *not* stored in the stream object and can thus ;; *not* be restored! (defvar rand-stream (with-meta 'rand {:type ::rand-stream}) "A random number stream based on clojure.core/rand. Note that this generator uses an internal mutable state. The state is thus not stored in the stream object and cannot be restored.") (defstream ::rand-stream [dummy-state] [(rand) dummy-state]) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/profile.clj000066400000000000000000000077161161102570000262530ustar00rootroot00000000000000;;; profile.clj: simple code profiling & timing ;; by Stuart Sierra, http://stuartsierra.com/ ;; May 9, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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 ^{:author "Stuart Sierra" :doc "Simple code profiling & timing measurement. Wrap any section of code in the prof macro, giving it a name, like this: (defn my-function [x y] (let [sum (prof :addition (+ x y)) product (prof :multiplication (* x y))] [sum product])) The run your code in the profile macro, like this: (profile (dotimes [i 10000] (my-function 3 4))) Which prints a report for each named section of code: Name mean min max count sum addition 265 0 37000 10000 2655000 multiplication 274 0 53000 10000 2747000 Times are measured in nanoseconds, to the maximum precision available under the JVM. See the function documentation for more details. "} clojure.contrib.profile) (def *profile-data* nil) (def ^{:doc "Set this to false before loading/compiling to omit profiling code."} *enable-profiling* true) (defmacro prof "If *enable-profiling* is true, wraps body in profiling code. Returns the result of body. Profile timings will be stored in *profile-data* using name, which must be a keyword, as the key. Timings are measured with System/nanoTime." [name & body] (assert (keyword? name)) (if *enable-profiling* `(if *profile-data* (let [start-time# (System/nanoTime) value# (do ~@body) elapsed# (- (System/nanoTime) start-time#)] (swap! *profile-data* assoc ~name (conj (get @*profile-data* ~name) elapsed#)) value#) ~@body) `(do ~@body))) (defmacro with-profile-data "Executes body with *profile-data* bound to an atom of a new map. Returns the raw profile data as a map. Keys in the map are profile names (keywords), and values are lists of elapsed time, in nanoseconds." [& body] `(binding [*profile-data* (atom {})] ~@body @*profile-data*)) (defn summarize "Takes the raw data returned by with-profile-data and returns a map from names to summary statistics. Each value in the map will look like: {:mean ..., :min ..., :max ..., :count ..., :sum ...} :mean, :min, and :max are how long the profiled section took to run, in nanoseconds. :count is the total number of times the profiled section was executed. :sum is the total amount of time spent in the profiled section, in nanoseconds." [profile-data] (reduce (fn [m [k v]] (let [cnt (count v) sum (reduce + v)] (assoc m k {:mean (int (/ sum cnt)) :min (apply min v) :max (apply max v) :count cnt :sum sum}))) {} profile-data)) (defn print-summary "Prints a table of the results returned by summarize." [profile-summary] (let [name-width (apply max 1 (map (comp count name) (keys profile-summary))) fmt-string (str "%" name-width "s %8d %8d %8d %8d %8d%n")] (printf (.replace fmt-string \d \s) "Name" "mean" "min" "max" "count" "sum") (doseq [k (sort (keys profile-summary))] (let [v (get profile-summary k)] (printf fmt-string (name k) (:mean v) (:min v) (:max v) (:count v) (:sum v)))))) (defmacro profile "Runs body with profiling enabled, then prints a summary of results. Returns nil." [& body] `(print-summary (summarize (with-profile-data (do ~@body))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/properties.clj000066400000000000000000000050511161102570000267750ustar00rootroot00000000000000; Copyright (c) Stuart Halloway & Contributors, April 2009. 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. ;; DEPRECATED in 1.2. Moved to c.c.java-utils (ns ^{:deprecated "1.2"} clojure.contrib.properties (:use [clojure.contrib.string :only (as-str)] [clojure.contrib.io :only (file)]) (:import (java.util Properties) (java.io FileInputStream FileOutputStream))) (defn get-system-property "Get a system property." ([stringable] (System/getProperty (as-str stringable))) ([stringable default] (System/getProperty (as-str stringable) default))) (defn set-system-properties "Set some system properties. Nil clears a property." [settings] (doseq [[name val] settings] (if val (System/setProperty (as-str name) (as-str val)) (System/clearProperty (as-str name))))) (defmacro with-system-properties "setting => property-name value Sets the system properties to the supplied values, executes the body, and sets the properties back to their original values. Values of nil are translated to a clearing of the property." [settings & body] `(let [settings# ~settings current# (reduce (fn [coll# k#] (assoc coll# k# (get-system-property k#))) {} (keys settings#))] (set-system-properties settings#) (try ~@body (finally (set-system-properties current#))))) ; Not there is no corresponding props->map. Just destructure! (defn ^Properties as-properties "Convert any seq of pairs to a java.utils.Properties instance. Uses as-str to convert both keys and values into strings." {:tag Properties} [m] (let [p (Properties.)] (doseq [[k v] m] (.setProperty p (as-str k) (as-str v))) p)) (defn read-properties "Read properties from file-able." [file-able] (with-open [f (java.io.FileInputStream. (file file-able))] (doto (Properties.) (.load f)))) (defn write-properties "Write properties to file-able." {:tag Properties} ([m file-able] (write-properties m file-able nil)) ([m file-able comments] (with-open [^FileOutputStream f (FileOutputStream. (file file-able))] (doto (as-properties m) (.store f ^String comments))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/prxml.clj000066400000000000000000000117611161102570000257500ustar00rootroot00000000000000;;; prxml.clj -- compact syntax for generating XML ;; by Stuart Sierra, http://stuartsierra.com/ ;; March 29, 2009 ;; Copyright (c) 2009 Stuart Sierra. 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. ;; Change Log ;; ;; March 29, 2009: added *prxml-indent* ;; ;; January 4, 2009: initial version ;; See function "prxml" at the bottom of this file for documentation. (ns ^{:author "Stuart Sierra", :doc "Compact syntax for generating XML. See the documentation of \"prxml\" for details."} clojure.contrib.prxml (:use [clojure.contrib.string :only (escape as-str)])) (def ^{:doc "If true, empty tags will have a space before the closing />"} *html-compatible* false) (def ^{:doc "The number of spaces to indent sub-tags. nil for no indent and no extra line-breaks."} *prxml-indent* nil) (def ^{:private true} *prxml-tag-depth* 0) (def ^{:private true} print-xml) ; forward declaration (defn- escape-xml [s] (escape {\< "<" \> ">" \& "&" \' "'" \" """} s)) (defn- prxml-attribute [name value] (print " ") (print (as-str name)) (print "=\"") (print (escape-xml (str value))) (print "\"")) (defmulti ^{:private true} print-xml-tag (fn [tag attrs content] tag)) (defmethod print-xml-tag :raw! [tag attrs contents] (doseq [c contents] (print c))) (defmethod print-xml-tag :comment! [tag attrs contents] (print "")) (defmethod print-xml-tag :decl! [tag attrs contents] (let [attrs (merge {:version "1.0" :encoding "UTF-8"} attrs)] ;; Must enforce ordering of pseudo-attributes: (print ""))) (defmethod print-xml-tag :cdata! [tag attrs contents] (print "")) (defmethod print-xml-tag :doctype! [tag attrs contents] (print "")) (defmethod print-xml-tag :default [tag attrs contents] (let [tag-name (as-str tag)] (when *prxml-indent* (newline) (dotimes [n (* *prxml-tag-depth* *prxml-indent*)] (print " "))) (print "<") (print tag-name) (doseq [[name value] attrs] (prxml-attribute name value)) (if (seq contents) (do ;; not an empty tag (print ">") (if (every? string? contents) ;; tag only contains strings: (do (doseq [c contents] (print-xml c)) (print "")) ;; tag contains sub-tags: (do (binding [*prxml-tag-depth* (inc *prxml-tag-depth*)] (doseq [c contents] (print-xml c))) (when *prxml-indent* (newline) (dotimes [n (* *prxml-tag-depth* *prxml-indent*)] (print " "))) (print "")))) ;; empty tag: (print (if *html-compatible* " />" "/>"))))) (defmulti ^{:private true} print-xml class) (defmethod print-xml clojure.lang.IPersistentVector [x] (let [[tag & contents] x [attrs content] (if (map? (first contents)) [(first contents) (rest contents)] [{} contents])] (print-xml-tag tag attrs content))) (defmethod print-xml clojure.lang.ISeq [x] ;; Recurse into sequences, so we can use (map ...) inside prxml. (doseq [c x] (print-xml c))) (defmethod print-xml clojure.lang.Keyword [x] (print-xml-tag x {} nil)) (defmethod print-xml String [x] (print (escape-xml x))) (defmethod print-xml nil [x]) (defmethod print-xml :default [x] (print x)) (defn prxml "Print XML to *out*. Vectors become XML tags: the first item is the tag name; optional second item is a map of attributes. Sequences are processed recursively, so you can use map and other sequence functions inside prxml. (prxml [:p {:class \"greet\"} [:i \"Ladies & gentlemen\"]]) ; =>

Ladies & gentlemen

PSEUDO-TAGS: some keywords have special meaning: :raw! do not XML-escape contents :comment! create an XML comment :decl! create an XML declaration, with attributes :cdata! create a CDATA section :doctype! create a DOCTYPE! (prxml [:p [:raw! \"here & gone\"]]) ; =>

here & gone

(prxml [:decl! {:version \"1.1\"}]) ; => " [& args] (doseq [arg args] (print-xml arg))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/reflect.clj000066400000000000000000000023601161102570000262250ustar00rootroot00000000000000; Copyright (c) 2010 Stuart Halloway & Contributors. 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.contrib.reflect) (defn call-method "Calls a private or protected method. params is a vector of classes which correspond to the arguments to the method e obj is nil for static methods, the instance object otherwise. The method-name is given a symbol or a keyword (something Named)." [klass method-name params obj & args] (-> klass (.getDeclaredMethod (name method-name) (into-array Class params)) (doto (.setAccessible true)) (.invoke obj (into-array Object args)))) (defn get-field "Access to private or protected field. field-name is a symbol or keyword." [klass field-name obj] (-> klass (.getDeclaredField (name field-name)) (doto (.setAccessible true)) (.get obj))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/repl_ln.clj000066400000000000000000000210721161102570000262350ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; A repl with that provides support for lines and line numbers in the ;; input stream. ;; ;; scgilardi (gmail) ;; Created 28 November 2008 (ns ^{:author "Stephen C. Gilardi", :doc "A repl with that provides support for lines and line numbers in the input stream."} clojure.contrib.repl-ln (:gen-class) (:import (clojure.lang Compiler LineNumberingPushbackReader RT Var) (java.io InputStreamReader OutputStreamWriter PrintWriter) java.util.Date) (:require clojure.main) (:use [clojure.contrib.def :only (defmacro- defonce- defstruct- defvar-)])) ;; Private (declare repl) (defstruct- repl-info :name :started :name-fmt :prompt-fmt :serial :thread :depth) (defvar- +name-formats+ {"%S" "%1$d" "%T" "%2$d" "%D" "%3$d"} "For set-name, maps our dynamic value codes to arg positions in the call to format in repl-name") (defvar- +prompt-formats+ {"%S" "%1$d" "%T" "%2$d" "%D" "%3$d" "%L" "%4$d" "%N" "%5$s"} "For set-prompt, maps our dynamic value codes to arg positions in the call to format in repl-prompt") (defvar- +info-format+ ["Name: %s" "Started: %s" "Name-fmt: \"%s\"" "Prompt-fmt: \"%s\"" "Serial: %d" "Thread: %d" "Depth: %d" "Line: %d"]) (defvar- +info-defaults+ (struct-map repl-info :name-fmt "repl-%S" :prompt-fmt "%S:%L %N=> " :depth 0) "Default/root values for repl info") (defonce- *serial-number* (atom 0) "Serial number counter") (defonce- *info* +info-defaults+ "Public info for this repl") (defonce- *private* {} "Private info for this repl") (defmacro- update "Replaces the map thread-locally bound to map-var with a copy that includes updated and/or new values from keys and vals." [map-var & key-vals] `(set! ~map-var (assoc ~map-var ~@key-vals))) (defn- repl-name "Returns the repl name based on this repl's name-fmt" [] (let [{:keys [name-fmt]} *private* {:keys [serial thread depth]} *info*] (format name-fmt serial thread depth))) (defn- prompt-hook [] (let [prompt (*private* :prompt)] (var-set Compiler/LINE (.getLineNumber *in*)) (prompt))) (defn- process-inits "Processes initial pairs of args of the form: -i filepath, or --init filepath by loading the referenced files, then accepts an optional terminating arg of the form: -r, or --repl Returns a seq of any remaining args." [args] (loop [[init filename & more :as args] args] (if (#{"-i" "--init"} init) (do (clojure.main/load-script filename) (recur more)) (if (#{"-r" "--repl"} init) (rest args) args)))) (defn- process-command-line "Args are strings passed in from the command line. Loads any requested init files and binds *command-line-args* to a seq of the remaining args" [args] (set! *command-line-args* (process-inits args))) (defn stream-repl "Repl entry point that provides convenient overriding of input, output, and err streams via sequential keyword-value pairs. Default values for :in, :out, and :err are streams associated with System/in, System/out, and System/err using UTF-8 encoding. Also supports all the options provided by clojure.contrib.repl-ln/repl." [& options] (let [enc RT/UTF8 {:keys [in out err] :or {in (LineNumberingPushbackReader. (InputStreamReader. System/in enc)) out (OutputStreamWriter. System/out enc) err (PrintWriter. (OutputStreamWriter. System/err enc))}} (apply hash-map options)] (binding [*in* in *out* out *err* err] (apply repl options)))) (defn- -main "Main entry point, starts a repl enters the user namespace and processes command line args." [& args] (repl :init (fn [] (println "Clojure" (clojure-version)) (in-ns 'user) (process-command-line args)))) ;; Public (defn repl-prompt "Returns the current repl prompt based on this repl's prompt-fmt" [] (let [{:keys [prompt-fmt]} *private* {:keys [serial thread depth]} *info* line (.getLineNumber *in*) namespace (ns-name *ns*)] (format prompt-fmt serial thread depth line namespace))) (defn set-repl-name "Sets the repl name format to the string name-fmt. Include the following codes in the name to make the corresponding dynamic values part of it: %S - repl serial number %T - thread id %D - nesting depth in this thread With no arguments, resets the repl name to its default: \"repl-%S\"" ([] (set-repl-name (+info-defaults+ :name-fmt))) ([name-fmt] (update *info* :name-fmt name-fmt) (loop [[[code fmt] & more] (seq +name-formats+) name-fmt name-fmt] (if code (recur more (.replace name-fmt code fmt)) (update *private* :name-fmt name-fmt))) (let [name (repl-name)] (update *info* :name name) (var-set Compiler/SOURCE name)) nil)) (defn set-repl-prompt "Sets the repl prompt. Include the following codes in the prompt to make the corresponding dynamic values part of it: %S - repl serial number %T - thread id %D - nesting depth in this thread %L - input line number %N - namespace name With no arguments, resets the repl pompt to its default: \"%S:%L %N=> \"" ([] (set-repl-prompt (+info-defaults+ :prompt-fmt))) ([prompt-fmt] (update *info* :prompt-fmt prompt-fmt) (loop [[[code fmt] & more] (seq +prompt-formats+) prompt-fmt prompt-fmt] (if code (recur more (.replace prompt-fmt code fmt)) (update *private* :prompt-fmt prompt-fmt))) nil)) (defn repl-info "Returns a map of info about the current repl" [] (let [line (.getLineNumber *in*)] (assoc *info* :line line))) (defn print-repl-info "Prints info about the current repl" [] (let [{:keys [name started name-fmt prompt-fmt serial thread depth line]} (repl-info)] (printf (apply str (interleave +info-format+ (repeat "\n"))) name started name-fmt prompt-fmt serial thread depth line))) (defn repl "A repl that supports line numbers. For definitions and evaluations made at the repl, the repl-name and line number will be reported as the origin. Use set-repl-name and set-repl-prompt to customize the repl name and prompt. This repl supports all of the keyword arguments documented for clojure.main/repl with the following change and additions: - :prompt has a new default default: #(clojure.core/print (repl-prompt)) - :name-fmt, Name format string default: the name-fmt of the parent repl, or \"repl-%S\" - :prompt-fmt, Prompt format string default: the prompt-fmt of the parent repl, or \"%S:%L %N=> \"" [& options] (let [{:keys [init need-prompt prompt flush read eval print caught name-fmt prompt-fmt] :or {init #() need-prompt (if (instance? LineNumberingPushbackReader *in*) #(.atLineStart *in*) #(identity true)) prompt #(clojure.core/print (repl-prompt)) flush flush read clojure.main/repl-read eval eval print prn caught clojure.main/repl-caught name-fmt (*info* :name-fmt) prompt-fmt (*info* :prompt-fmt)}} (apply hash-map options)] (try (Var/pushThreadBindings {Compiler/SOURCE (var-get Compiler/SOURCE) Compiler/LINE (var-get Compiler/LINE) (var *info*) *info* (var *private*) {}}) (update *info* :started (Date.) :serial (swap! *serial-number* inc) :thread (.getId (Thread/currentThread)) :depth (inc (*info* :depth))) (update *private* :prompt prompt) (set-repl-name name-fmt) (set-repl-prompt prompt-fmt) (clojure.main/repl :init init :need-prompt need-prompt :prompt prompt-hook :flush flush :read read :eval eval :print print :caught caught) (finally (Var/popThreadBindings) (prn))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/repl_utils.clj000066400000000000000000000206731161102570000267720ustar00rootroot00000000000000; Copyright (c) Chris Houser, Dec 2008. 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. ; Utilities meant to be used interactively at the REPL ;; Deprecated in 1.2: source, get-source, and apropos. These are ;; available in clojure.repl as source, source-fn, and apropos, respectively. (ns ^{:author "Chris Houser, Christophe Grand, Stephen Gilardi, Michel Salim", :doc "Utilities meant to be used interactively at the REPL"} clojure.contrib.repl-utils (:import (java.io File LineNumberReader InputStreamReader PushbackReader) (java.lang.reflect Modifier Method Constructor) (clojure.lang RT Compiler Compiler$C)) (:require [clojure.contrib.string :as s]) (:use [clojure.contrib.seq :only (indexed)] [clojure.contrib.javadoc.browse :only (browse-url)])) ;; ---------------------------------------------------------------------- ;; Examine Java classes (defn- sortable [t] (apply str (map (fn [[a b]] (str a (format "%04d" (Integer. b)))) (partition 2 (concat (s/partition #"\d+" t) [0]))))) (defn- param-str [m] (str " (" (s/join "," (map (fn [[c i]] (if (> i 3) (str (.getSimpleName c) "*" i) (s/join "," (replicate i (.getSimpleName c))))) (reduce (fn [pairs y] (let [[x i] (peek pairs)] (if (= x y) (conj (pop pairs) [y (inc i)]) (conj pairs [y 1])))) [] (.getParameterTypes m)))) ")")) (defn- member-details [m] (let [static? (Modifier/isStatic (.getModifiers m)) method? (instance? Method m) ctor? (instance? Constructor m) text (if ctor? (str "" (param-str m)) (str (when static? "static ") (.getName m) " : " (if method? (str (.getSimpleName (.getReturnType m)) (param-str m)) (str (.getSimpleName (.getType m))))))] (assoc (bean m) :sort-val [(not static?) method? (sortable text)] :text text :member m))) (defn show "With one arg prints all static and instance members of x or (class x). Each member is listed with a number which can be given as 'selector' to return the member object -- the REPL will print more details for that member. The selector also may be a string or regex, in which case only members whose names match 'selector' as a case-insensitive regex will be printed. Finally, the selector also may be a predicate, in which case only members for which the predicate returns true will be printed. The predicate will be passed a single argument, a map that includes the :text that will be printed and the :member object itself, as well as all the properies of the member object as translated by 'bean'. Examples: (show Integer) (show []) (show String 23) (show String \"case\")" ([x] (show x (constantly true))) ([x selector] (let [c (if (class? x) x (class x)) members (sort-by :sort-val (map member-details (concat (.getFields c) (.getMethods c) (.getConstructors c))))] (if (number? selector) (:member (nth members selector)) (let [pred (if (ifn? selector) selector #(re-find (re-pattern (str "(?i)" selector)) (:name %)))] (println "=== " (Modifier/toString (.getModifiers c)) c " ===") (doseq [[i m] (indexed members)] (when (pred m) (printf "[%2d] %s\n" i (:text m))))))))) ;; ---------------------------------------------------------------------- ;; Examine Clojure functions (Vars, really) (defn get-source "Returns a string of the source code for the given symbol, if it can find it. This requires that the symbol resolve to a Var defined in a namespace for which the .clj is in the classpath. Returns nil if it can't find the source. For most REPL usage, 'source' is more convenient. Example: (get-source 'filter)" {:deprecated "1.2"} [x] (when-let [v (resolve x)] (when-let [filepath (:file (meta v))] (when-let [strm (.getResourceAsStream (RT/baseLoader) filepath)] (with-open [rdr (LineNumberReader. (InputStreamReader. strm))] (dotimes [_ (dec (:line (meta v)))] (.readLine rdr)) (let [text (StringBuilder.) pbr (proxy [PushbackReader] [rdr] (read [] (let [i (proxy-super read)] (.append text (char i)) i)))] (read (PushbackReader. pbr)) (str text))))))) (defmacro source "Prints the source code for the given symbol, if it can find it. This requires that the symbol resolve to a Var defined in a namespace for which the .clj is in the classpath. Example: (source filter)" {:deprecated "1.2"} [n] `(println (or (get-source '~n) (str "Source not found")))) (defn apropos "Given a regular expression or stringable thing, return a seq of all definitions in all currently-loaded namespaces that match the str-or-pattern." {:deprecated "1.2"} [str-or-pattern] (let [matches? (if (instance? java.util.regex.Pattern str-or-pattern) #(re-find str-or-pattern (str %)) #(s/substring? (str str-or-pattern) (str %)))] (mapcat (fn [ns] (filter matches? (keys (ns-publics ns)))) (all-ns)))) ;; ---------------------------------------------------------------------- ;; Handle Ctrl-C keystrokes (def ^{:doc "Threads to stop when Ctrl-C is pressed. See 'add-break-thread!'"} break-threads (atom {})) (let [first-time (atom true)] (defn start-handling-break "Register INT signal handler. After calling this, Ctrl-C will cause all break-threads to be stopped. See 'add-break-thread!'" [] (when (= :need-init (swap! first-time {:need-init false, false false, true :need-init})) (sun.misc.Signal/handle (sun.misc.Signal. "INT") (proxy [sun.misc.SignalHandler] [] (handle [sig] (let [exc (Exception. (str sig))] (doseq [tref (vals @break-threads) :when (.get tref)] (.stop (.get tref) exc))))))))) (defn add-break-thread! "Add the given thread to break-threads so that it will be stopped any time the user presses Ctrl-C. Calls start-handling-break for you. Adds the current thread if none is given." ([] (add-break-thread! (Thread/currentThread))) ([t] (start-handling-break) (let [tref (java.lang.ref.WeakReference. t)] (swap! break-threads assoc (.getId t) tref)))) ;; ---------------------------------------------------------------------- ;; Compiler hooks (defn expression-info "Uses the Clojure compiler to analyze the given s-expr. Returns a map with keys :class and :primitive? indicating what the compiler concluded about the return value of the expression. Returns nil if not type info can be determined at compile-time. Example: (expression-info '(+ (int 5) (float 10))) Returns: {:class float, :primitive? true}" [expr] (let [fn-ast (Compiler/analyze Compiler$C/EXPRESSION `(fn [] ~expr)) expr-ast (.body (first (.methods fn-ast)))] (when (.hasJavaClass expr-ast) {:class (.getJavaClass expr-ast) :primitive? (.isPrimitive (.getJavaClass expr-ast))}))) ;; ---------------------------------------------------------------------- ;; scgilardi at gmail (defn run* "Loads the specified namespace and invokes its \"main\" function with optional args." [ns-sym & args] (require ns-sym :reload-all) (apply (ns-resolve ns-sym 'main) args)) (defmacro run "Loads the specified namespace and invokes its \"main\" function with optional args. ns-name is not evaluated." [ns-name & args] `(run* '~ns-name ~@args)) (load "repl_utils/javadoc") clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/repl_utils/000077500000000000000000000000001161102570000262705ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/repl_utils/javadoc.clj000066400000000000000000000062321161102570000303740ustar00rootroot00000000000000; Copyright (c) Christophe Grand, November 2008. 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. ; thanks to Stuart Sierra ; a repl helper to quickly open javadocs. (def *feeling-lucky-url* "http://www.google.com/search?btnI=I%27m%20Feeling%20Lucky&q=allinurl:") (def *feeling-lucky* true) (def ^{:doc "Ref to a list of local paths for Javadoc-generated HTML files."} *local-javadocs* (ref (list))) (def *core-java-api* (if (= "1.5" (System/getProperty "java.specification.version")) "http://java.sun.com/j2se/1.5.0/docs/api/" "http://java.sun.com/javase/6/docs/api/")) (def ^{:doc "Ref to a map from package name prefixes to URLs for remote Javadocs."} *remote-javadocs* (ref (sorted-map "java." *core-java-api* "javax." *core-java-api* "org.ietf.jgss." *core-java-api* "org.omg." *core-java-api* "org.w3c.dom." *core-java-api* "org.xml.sax." *core-java-api* "org.apache.commons.codec." "http://commons.apache.org/codec/api-release/" "org.apache.commons.io." "http://commons.apache.org/io/api-release/" "org.apache.commons.lang." "http://commons.apache.org/lang/api-release/"))) (defn add-local-javadoc "Adds to the list of local Javadoc paths." [path] (dosync (commute *local-javadocs* conj path))) (defn add-remote-javadoc "Adds to the list of remote Javadoc URLs. package-prefix is the beginning of the package name that has docs at this URL." [package-prefix url] (dosync (commute *remote-javadocs* assoc package-prefix url))) (defn find-javadoc-url "Searches for a URL for the given class name. Tries *local-javadocs* first, then *remote-javadocs*. Returns a string." {:tag String} [^String classname] (let [file-path (.replace classname \. File/separatorChar) url-path (.replace classname \. \/)] (if-let [file ^File (first (filter #(.exists ^File %) (map #(File. (str %) (str file-path ".html")) @*local-javadocs*)))] (-> file .toURI str) ;; If no local file, try remote URLs: (or (some (fn [[prefix url]] (when (.startsWith classname prefix) (str url url-path ".html"))) @*remote-javadocs*) ;; if *feeling-lucky* try a web search (when *feeling-lucky* (str *feeling-lucky-url* url-path ".html")))))) (defn javadoc "Opens a browser window displaying the javadoc for the argument. Tries *local-javadocs* first, then *remote-javadocs*." [class-or-object] (let [^Class c (if (instance? Class class-or-object) class-or-object (class class-or-object))] (if-let [url (find-javadoc-url (.getName c))] (browse-url url) (println "Could not find Javadoc for" c)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/seq.clj000066400000000000000000000174561161102570000254050ustar00rootroot00000000000000;;; seq_utils.clj -- Sequence utilities for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; last updated March 2, 2009 ;; Copyright (c) Stuart Sierra, 2008. 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. ;; Change Log ;; ;; January 10, 2009 (Stuart Sierra): ;; ;; * BREAKING CHANGE: "includes?" now takes collection as first ;; argument. This is more consistent with Clojure collection ;; functions; see discussion at http://groups.google.com/group/clojure/browse_thread/thread/8b2c8dc96b39ddd7/a8866d34b601ff43 (ns ^{:author "Stuart Sierra (and others)", :doc "Sequence utilities for Clojure"} clojure.contrib.seq (:import (java.util.concurrent LinkedBlockingQueue TimeUnit) (java.lang.ref WeakReference)) (:refer-clojure :exclude [frequencies shuffle partition-by reductions partition-all group-by flatten])) ;; 'flatten' written by Rich Hickey, ;; see http://groups.google.com/group/clojure/msg/385098fabfcaad9b (defn flatten "DEPRECATED. Prefer clojure.core version. Takes any nested combination of sequential things (lists, vectors, etc.) and returns their contents as a single, flat sequence. (flatten nil) returns nil." {:deprecated "1.2"} [x] (filter (complement sequential?) (rest (tree-seq sequential? seq x)))) (defn separate "Returns a vector: [ (filter f s), (filter (complement f) s) ]" [f s] [(filter f s) (filter (complement f) s)]) (defn indexed "Returns a lazy sequence of [index, item] pairs, where items come from 's' and indexes count up from zero. (indexed '(a b c d)) => ([0 a] [1 b] [2 c] [3 d])" [s] (map vector (iterate inc 0) s)) ;; group-by written by Rich Hickey; ;; see http://paste.lisp.org/display/64190 (defn group-by "DEPRECATED. Prefer clojure.core version. Returns a sorted map of the elements of coll keyed by the result of f on each element. The value at each key will be a vector of the corresponding elements, in the order they appeared in coll." {:deprecated "1.2"} [f coll] (reduce (fn [ret x] (let [k (f x)] (assoc ret k (conj (get ret k []) x)))) (sorted-map) coll)) ;; partition-by originally written by Rich Hickey; ;; modified by Stuart Sierra (defn partition-by "DEPRECATED. Prefer clojure.core version. Applies f to each value in coll, splitting it each time f returns a new value. Returns a lazy seq of lazy seqs." {:deprecated "1.2"} [f coll] (when-let [s (seq coll)] (let [fst (first s) fv (f fst) run (cons fst (take-while #(= fv (f %)) (rest s)))] (lazy-seq (cons run (partition-by f (drop (count run) s))))))) (defn frequencies "DEPRECATED. Prefer clojure.core version. Returns a map from distinct items in coll to the number of times they appear." {:deprecated "1.2"} [coll] (reduce (fn [counts x] (assoc counts x (inc (get counts x 0)))) {} coll)) ;; recursive sequence helpers by Christophe Grand ;; see http://clj-me.blogspot.com/2009/01/recursive-seqs.html (defmacro rec-seq "Similar to lazy-seq but binds the resulting seq to the supplied binding-name, allowing for recursive expressions." [binding-name & body] `(let [s# (atom nil)] (reset! s# (lazy-seq (let [~binding-name @s#] ~@body))))) (defmacro rec-cat "Similar to lazy-cat but binds the resulting sequence to the supplied binding-name, allowing for recursive expressions." [binding-name & exprs] `(rec-seq ~binding-name (lazy-cat ~@exprs))) ;; reductions by Chris Houser ;; see http://groups.google.com/group/clojure/browse_thread/thread/3edf6e82617e18e0/58d9e319ad92aa5f?#58d9e319ad92aa5f (defn reductions "DEPRECATED. Prefer clojure.core version. Returns a lazy seq of the intermediate values of the reduction (as per reduce) of coll by f, starting with init." {:deprecated "1.2"} ([f coll] (if (seq coll) (rec-seq self (cons (first coll) (map f self (rest coll)))) (cons (f) nil))) ([f init coll] (rec-seq self (cons init (map f self coll))))) (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 partition-all "DEPRECATED. Prefer clojure.core version. Returns a lazy sequence of lists like clojure.core/partition, but may include lists with fewer than n items at the end." {:deprecated "1.2"} ([n coll] (partition-all n n coll)) ([n step coll] (lazy-seq (when-let [s (seq coll)] (cons (take n s) (partition-all n step (drop step s))))))) (defn shuffle "DEPRECATED. Prefer clojure.core version. Return a random permutation of coll" {:deprecated "1.2"} [coll] (let [l (java.util.ArrayList. coll)] (java.util.Collections/shuffle l) (seq l))) (defn rand-elt "DEPRECATED. Prefer clojure.core/rand-nth. Return a random element of this seq" {:deprecated "1.2"} [s] (nth s (rand-int (count s)))) ;; seq-on written by Konrad Hinsen (defmulti seq-on "Returns a seq on the object s. Works like the built-in seq but as a multimethod that can have implementations for new classes and types." {:arglists '([s])} type) (defmethod seq-on :default [s] (seq s)) (defn find-first "Returns the first item of coll for which (pred item) returns logical true. Consumes sequences up to the first match, will consume the entire sequence and return nil if no match is found." [pred coll] (first (filter pred coll))) ; based on work related to Rich Hickey's seque. ; blame Chouser for anything broken or ugly. (defn fill-queue "filler-func will be called in another thread with a single arg 'fill'. filler-func may call fill repeatedly with one arg each time which will be pushed onto a queue, blocking if needed until this is possible. fill-queue will return a lazy seq of the values filler-func has pushed onto the queue, blocking if needed until each next element becomes available. filler-func's return value is ignored." ([filler-func & optseq] (let [opts (apply array-map optseq) apoll (:alive-poll opts 1) q (LinkedBlockingQueue. (:queue-size opts 1)) NIL (Object.) ;nil sentinel since LBQ doesn't support nils weak-target (Object.) alive? (WeakReference. weak-target) fill (fn fill [x] (if (.get alive?) (if (.offer q (if (nil? x) NIL x) apoll TimeUnit/SECONDS) x (recur x)) (throw (Exception. "abandoned")))) f (future (try (filler-func fill) (finally (.put q q))) ;q itself is eos sentinel nil)] ; set future's value to nil ((fn drain [] weak-target ; force closing over this object (lazy-seq (let [x (.take q)] (if (identical? x q) @f ;will be nil, touch just to propagate errors (cons (if (identical? x NIL) nil x) (drain)))))))))) (defn positions "Returns a lazy sequence containing the positions at which pred is true for items in coll." [pred coll] (for [[idx elt] (indexed coll) :when (pred elt)] idx)) (defn includes? "Returns true if coll contains something equal (with =) to x, in linear time. Deprecated. Prefer 'contains?' for key testing, or 'some' for ad hoc linear searches." {:deprecated "1.2"} [coll x] (boolean (some (fn [y] (= y x)) coll))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/seq_utils.clj000066400000000000000000000176531161102570000266240ustar00rootroot00000000000000;;; seq_utils.clj -- Sequence utilities for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; last updated March 2, 2009 ;; Copyright (c) Stuart Sierra, 2008. 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. ;; Change Log ;; ;; DEPRECATED in 1.2. Some functions promoted to clojure.core and some ;; moved to c.c.seq ;; ;; January 10, 2009 (Stuart Sierra): ;; ;; * BREAKING CHANGE: "includes?" now takes collection as first ;; argument. This is more consistent with Clojure collection ;; functions; see discussion at http://groups.google.com/group/clojure/browse_thread/thread/8b2c8dc96b39ddd7/a8866d34b601ff43 ;; (ns ^{:author "Stuart Sierra (and others)", :deprecated "1.2" :doc "Sequence utilities for Clojure"} clojure.contrib.seq-utils (:import (java.util.concurrent LinkedBlockingQueue TimeUnit) (java.lang.ref WeakReference)) (:refer-clojure :exclude [frequencies shuffle partition-by reductions partition-all group-by flatten])) ;; 'flatten' written by Rich Hickey, ;; see http://groups.google.com/group/clojure/msg/385098fabfcaad9b (defn flatten "DEPRECATED. Prefer clojure.core version. Takes any nested combination of sequential things (lists, vectors, etc.) and returns their contents as a single, flat sequence. (flatten nil) returns nil." {:deprecated "1.2"} [x] (filter (complement sequential?) (rest (tree-seq sequential? seq x)))) (defn separate "Returns a vector: [ (filter f s), (filter (complement f) s) ]" [f s] [(filter f s) (filter (complement f) s)]) (defn indexed "Returns a lazy sequence of [index, item] pairs, where items come from 's' and indexes count up from zero. (indexed '(a b c d)) => ([0 a] [1 b] [2 c] [3 d])" [s] (map vector (iterate inc 0) s)) ;; group-by written by Rich Hickey; ;; see http://paste.lisp.org/display/64190 (defn group-by "DEPRECATED. Prefer clojure.core version. Returns a sorted map of the elements of coll keyed by the result of f on each element. The value at each key will be a vector of the corresponding elements, in the order they appeared in coll." {:deprecated "1.2"} [f coll] (reduce (fn [ret x] (let [k (f x)] (assoc ret k (conj (get ret k []) x)))) (sorted-map) coll)) ;; partition-by originally written by Rich Hickey; ;; modified by Stuart Sierra (defn partition-by "DEPRECATED. Prefer clojure.core version. Applies f to each value in coll, splitting it each time f returns a new value. Returns a lazy seq of lazy seqs." {:deprecated "1.2"} [f coll] (when-let [s (seq coll)] (let [fst (first s) fv (f fst) run (cons fst (take-while #(= fv (f %)) (rest s)))] (lazy-seq (cons run (partition-by f (drop (count run) s))))))) (defn frequencies "DEPRECATED. Prefer clojure.core version. Returns a map from distinct items in coll to the number of times they appear." {:deprecated "1.2"} [coll] (reduce (fn [counts x] (assoc counts x (inc (get counts x 0)))) {} coll)) ;; recursive sequence helpers by Christophe Grand ;; see http://clj-me.blogspot.com/2009/01/recursive-seqs.html (defmacro rec-seq "Similar to lazy-seq but binds the resulting seq to the supplied binding-name, allowing for recursive expressions." [binding-name & body] `(let [s# (atom nil)] (reset! s# (lazy-seq (let [~binding-name @s#] ~@body))))) (defmacro rec-cat "Similar to lazy-cat but binds the resulting sequence to the supplied binding-name, allowing for recursive expressions." [binding-name & exprs] `(rec-seq ~binding-name (lazy-cat ~@exprs))) ;; reductions by Chris Houser ;; see http://groups.google.com/group/clojure/browse_thread/thread/3edf6e82617e18e0/58d9e319ad92aa5f?#58d9e319ad92aa5f (defn reductions "DEPRECATED. Prefer clojure.core version. Returns a lazy seq of the intermediate values of the reduction (as per reduce) of coll by f, starting with init." {:deprecated "1.2"} ([f coll] (if (seq coll) (rec-seq self (cons (first coll) (map f self (rest coll)))) (cons (f) nil))) ([f init coll] (rec-seq self (cons init (map f self coll))))) (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 partition-all "DEPRECATED. Prefer clojure.core version. Returns a lazy sequence of lists like clojure.core/partition, but may include lists with fewer than n items at the end." {:deprecated "1.2"} ([n coll] (partition-all n n coll)) ([n step coll] (lazy-seq (when-let [s (seq coll)] (cons (take n s) (partition-all n step (drop step s))))))) (defn shuffle "DEPRECATED. Prefer clojure.core version. Return a random permutation of coll" {:deprecated "1.2"} [coll] (let [l (java.util.ArrayList. coll)] (java.util.Collections/shuffle l) (seq l))) (defn rand-elt "DEPRECATED. Prefer clojure.core/rand-nth. Return a random element of this seq" {:deprecated "1.2"} [s] (nth s (rand-int (count s)))) ;; seq-on written by Konrad Hinsen (defmulti seq-on "Returns a seq on the object s. Works like the built-in seq but as a multimethod that can have implementations for new classes and types." {:arglists '([s])} type) (defmethod seq-on :default [s] (seq s)) (defn find-first "Returns the first item of coll for which (pred item) returns logical true. Consumes sequences up to the first match, will consume the entire sequence and return nil if no match is found." [pred coll] (first (filter pred coll))) ; based on work related to Rich Hickey's seque. ; blame Chouser for anything broken or ugly. (defn fill-queue "filler-func will be called in another thread with a single arg 'fill'. filler-func may call fill repeatedly with one arg each time which will be pushed onto a queue, blocking if needed until this is possible. fill-queue will return a lazy seq of the values filler-func has pushed onto the queue, blocking if needed until each next element becomes available. filler-func's return value is ignored." ([filler-func & optseq] (let [opts (apply array-map optseq) apoll (:alive-poll opts 1) q (LinkedBlockingQueue. (:queue-size opts 1)) NIL (Object.) ;nil sentinel since LBQ doesn't support nils weak-target (Object.) alive? (WeakReference. weak-target) fill (fn fill [x] (if (.get alive?) (if (.offer q (if (nil? x) NIL x) apoll TimeUnit/SECONDS) x (recur x)) (throw (Exception. "abandoned")))) f (future (try (filler-func fill) (finally (.put q q))) ;q itself is eos sentinel nil)] ; set future's value to nil ((fn drain [] weak-target ; force closing over this object (lazy-seq (let [x (.take q)] (if (identical? x q) @f ;will be nil, touch just to propagate errors (cons (if (identical? x NIL) nil x) (drain)))))))))) (defn positions "Returns a lazy sequence containing the positions at which pred is true for items in coll." [pred coll] (for [[idx elt] (indexed coll) :when (pred elt)] idx)) (defn includes? "Returns true if coll contains something equal (with =) to x, in linear time. Deprecated. Prefer 'contains?' for key testing, or 'some' for ad hoc linear searches." {:deprecated "1.2"} [coll x] (boolean (some (fn [y] (= y x)) coll))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/server_socket.clj000066400000000000000000000061651161102570000274660ustar00rootroot00000000000000;; Copyright (c) Craig McDaniel, Jan 2009. 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. ;; Server socket library - includes REPL on socket (ns ^{:author "Craig McDaniel", :doc "Server socket library - includes REPL on socket"} clojure.contrib.server-socket (:import (java.net InetAddress ServerSocket Socket SocketException) (java.io InputStreamReader OutputStream OutputStreamWriter PrintWriter) (clojure.lang LineNumberingPushbackReader)) (:use [clojure.main :only (repl)])) (defn- on-thread [f] (doto (Thread. ^Runnable f) (.start))) (defn- close-socket [^Socket s] (when-not (.isClosed s) (doto s (.shutdownInput) (.shutdownOutput) (.close)))) (defn- accept-fn [^Socket s connections fun] (let [ins (.getInputStream s) outs (.getOutputStream s)] (on-thread #(do (dosync (commute connections conj s)) (try (fun ins outs) (catch SocketException e)) (close-socket s) (dosync (commute connections disj s)))))) (defstruct server-def :server-socket :connections) (defn- create-server-aux [fun ^ServerSocket ss] (let [connections (ref #{})] (on-thread #(when-not (.isClosed ss) (try (accept-fn (.accept ss) connections fun) (catch SocketException e)) (recur))) (struct-map server-def :server-socket ss :connections connections))) (defn create-server "Creates a server socket on port. Upon accept, a new thread is created which calls: (fun input-stream output-stream) Optional arguments support specifying a listen backlog and binding to a specific endpoint." ([port fun backlog ^InetAddress bind-addr] (create-server-aux fun (ServerSocket. port backlog bind-addr))) ([port fun backlog] (create-server-aux fun (ServerSocket. port backlog))) ([port fun] (create-server-aux fun (ServerSocket. port)))) (defn close-server [server] (doseq [s @(:connections server)] (close-socket s)) (dosync (ref-set (:connections server) #{})) (.close ^ServerSocket (:server-socket server))) (defn connection-count [server] (count @(:connections server))) ;;;; ;;;; REPL on a socket ;;;; (defn- socket-repl [ins outs] (binding [*in* (LineNumberingPushbackReader. (InputStreamReader. ins)) *out* (OutputStreamWriter. outs) *err* (PrintWriter. ^OutputStream outs true)] (repl))) (defn create-repl-server "create a repl on a socket" ([port backlog ^InetAddress bind-addr] (create-server port socket-repl backlog bind-addr)) ([port backlog] (create-server port socket-repl backlog)) ([port] (create-server port socket-repl))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/set.clj000066400000000000000000000027011161102570000253730ustar00rootroot00000000000000;; Copyright (c) Jason Wolfe. 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. ;; ;; set.clj ;; ;; Clojure functions for operating on sets (supplemental to clojure.set) ;; ;; jason at w01fe dot com ;; Created 2 Feb 2009 ;; Deprecations in 1.2: subset and superset have been promoted to ;; clojure.set (ns ^{:author "Jason Wolfe", :doc "Clojure functions for operating on sets (supplemental to clojure.set)"} clojure.contrib.set) (defn subset? "Is set1 a subset of set2?" {:deprecated "1.2"} [set1 set2] {:tag Boolean} (and (<= (count set1) (count set2)) (every? set2 set1))) (defn superset? "Is set1 a superset of set2?" {:deprecated "1.2"} [set1 set2] {:tag Boolean} (and (>= (count set1) (count set2)) (every? set1 set2))) (defn proper-subset? "Is s1 a proper subset of s2?" [set1 set2] {:tag Boolean} (and (< (count set1) (count set2)) (every? set2 set1))) (defn proper-superset? "Is s1 a proper superset of s2?" [set1 set2] {:tag Boolean} (and (> (count set1) (count set2)) (every? set1 set2))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/shell.clj000066400000000000000000000124001161102570000257040ustar00rootroot00000000000000; Copyright (c) Chris Houser, Jan 2009. 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. ; :dir and :env options added by Stuart Halloway ; Conveniently launch a sub-process providing to its stdin and ; collecting its stdout ;; DEPRECATED in 1.2: Promoted to clojure.java.shell (ns ^{:author "Chris Houser", :deprecated "1.2" :doc "Conveniently launch a sub-process providing to its stdin and collecting its stdout"} clojure.contrib.shell (:import (java.io InputStreamReader OutputStreamWriter))) (def *sh-dir* nil) (def *sh-env* nil) (defmacro with-sh-dir [dir & forms] "Sets the directory for use with sh, see sh for details." `(binding [*sh-dir* ~dir] ~@forms)) (defmacro with-sh-env [env & forms] "Sets the environment for use with sh, see sh for details." `(binding [*sh-env* ~env] ~@forms)) (defn- stream-seq "Takes an InputStream and returns a lazy seq of integers from the stream." [stream] (take-while #(>= % 0) (repeatedly #(.read stream)))) (defn- aconcat "Concatenates arrays of given type." [type & xs] (let [target (make-array type (apply + (map count xs)))] (loop [i 0 idx 0] (when-let [a (nth xs i nil)] (System/arraycopy a 0 target idx (count a)) (recur (inc i) (+ idx (count a))))) target)) (defn- parse-args "Takes a seq of 'sh' arguments and returns a map of option keywords to option values." [args] (loop [[arg :as args] args opts {:cmd [] :out "UTF-8" :dir *sh-dir* :env *sh-env*}] (if-not args opts (if (keyword? arg) (recur (nnext args) (assoc opts arg (second args))) (recur (next args) (update-in opts [:cmd] conj arg)))))) (defn- as-env-key [arg] "Helper so that callers can use symbols, keywords, or strings when building an environment map." (cond (symbol? arg) (name arg) (keyword? arg) (name arg) (string? arg) arg)) (defn- as-file [arg] "Helper so that callers can pass a String for the :dir to sh." (cond (string? arg) (java.io.File. arg) (nil? arg) nil (instance? java.io.File arg) arg)) (defn- as-env-string [arg] "Helper so that callers can pass a Clojure map for the :env to sh." (cond (nil? arg) nil (map? arg) (into-array String (map (fn [[k v]] (str (as-env-key k) "=" v)) arg)) true arg)) (defn sh "Passes the given strings to Runtime.exec() to launch a sub-process. Options are :in may be given followed by a String specifying text to be fed to the sub-process's stdin. :out option may be given followed by :bytes or a String. If a String is given, it will be used as a character encoding name (for example \"UTF-8\" or \"ISO-8859-1\") to convert the sub-process's stdout to a String which is returned. If :bytes is given, the sub-process's stdout will be stored in a byte array and returned. Defaults to UTF-8. :return-map when followed by boolean true, sh returns a map of :exit => sub-process's exit code :out => sub-process's stdout (as byte[] or String) :err => sub-process's stderr (as byte[] or String) when not given or followed by false, sh returns a single array or String of the sub-process's stdout followed by its stderr :env override the process env with a map (or the underlying Java String[] if you are a masochist). :dir override the process dir with a String or java.io.File. You can bind :env or :dir for multiple operations using with-sh-env and with-sh-dir." [& args] (let [opts (parse-args args) proc (.exec (Runtime/getRuntime) (into-array (:cmd opts)) (as-env-string (:env opts)) (as-file (:dir opts)))] (if (:in opts) (with-open [osw (OutputStreamWriter. (.getOutputStream proc))] (.write osw (:in opts))) (.close (.getOutputStream proc))) (with-open [stdout (.getInputStream proc) stderr (.getErrorStream proc)] (let [[[out err] combine-fn] (if (= (:out opts) :bytes) [(for [strm [stdout stderr]] (into-array Byte/TYPE (map byte (stream-seq strm)))) #(aconcat Byte/TYPE %1 %2)] [(for [strm [stdout stderr]] (apply str (map char (stream-seq (InputStreamReader. strm (:out opts)))))) str]) exit-code (.waitFor proc)] (if (:return-map opts) {:exit exit-code :out out :err err} (combine-fn out err)))))) (comment (println (sh "ls" "-l")) (println (sh "ls" "-l" "/no-such-thing")) (println (sh "sed" "s/[aeiou]/oo/g" :in "hello there\n")) (println (sh "cat" :in "x\u25bax\n")) (println (sh "echo" "x\u25bax")) (println (sh "echo" "x\u25bax" :out "ISO-8859-1")) ; reads 4 single-byte chars (println (sh "cat" "myimage.png" :out :bytes)) ; reads binary file into bytes[] ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/shell_out.clj000066400000000000000000000124041161102570000265770ustar00rootroot00000000000000; Copyright (c) Chris Houser, Jan 2009. 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. ; :dir and :env options added by Stuart Halloway ; Conveniently launch a sub-process providing to its stdin and ; collecting its stdout ;; DEPRECATED in 1.2: Promoted to clojure.java.shell (ns ^{:author "Chris Houser", :deprecated "1.2" :doc "Conveniently launch a sub-process providing to its stdin and collecting its stdout"} clojure.contrib.shell-out (:import (java.io InputStreamReader OutputStreamWriter))) (def *sh-dir* nil) (def *sh-env* nil) (defmacro with-sh-dir [dir & forms] "Sets the directory for use with sh, see sh for details." `(binding [*sh-dir* ~dir] ~@forms)) (defmacro with-sh-env [env & forms] "Sets the environment for use with sh, see sh for details." `(binding [*sh-env* ~env] ~@forms)) (defn- stream-seq "Takes an InputStream and returns a lazy seq of integers from the stream." [stream] (take-while #(>= % 0) (repeatedly #(.read stream)))) (defn- aconcat "Concatenates arrays of given type." [type & xs] (let [target (make-array type (apply + (map count xs)))] (loop [i 0 idx 0] (when-let [a (nth xs i nil)] (System/arraycopy a 0 target idx (count a)) (recur (inc i) (+ idx (count a))))) target)) (defn- parse-args "Takes a seq of 'sh' arguments and returns a map of option keywords to option values." [args] (loop [[arg :as args] args opts {:cmd [] :out "UTF-8" :dir *sh-dir* :env *sh-env*}] (if-not args opts (if (keyword? arg) (recur (nnext args) (assoc opts arg (second args))) (recur (next args) (update-in opts [:cmd] conj arg)))))) (defn- as-env-key [arg] "Helper so that callers can use symbols, keywords, or strings when building an environment map." (cond (symbol? arg) (name arg) (keyword? arg) (name arg) (string? arg) arg)) (defn- as-file [arg] "Helper so that callers can pass a String for the :dir to sh." (cond (string? arg) (java.io.File. arg) (nil? arg) nil (instance? java.io.File arg) arg)) (defn- as-env-string [arg] "Helper so that callers can pass a Clojure map for the :env to sh." (cond (nil? arg) nil (map? arg) (into-array String (map (fn [[k v]] (str (as-env-key k) "=" v)) arg)) true arg)) (defn sh "Passes the given strings to Runtime.exec() to launch a sub-process. Options are :in may be given followed by a String specifying text to be fed to the sub-process's stdin. :out option may be given followed by :bytes or a String. If a String is given, it will be used as a character encoding name (for example \"UTF-8\" or \"ISO-8859-1\") to convert the sub-process's stdout to a String which is returned. If :bytes is given, the sub-process's stdout will be stored in a byte array and returned. Defaults to UTF-8. :return-map when followed by boolean true, sh returns a map of :exit => sub-process's exit code :out => sub-process's stdout (as byte[] or String) :err => sub-process's stderr (as byte[] or String) when not given or followed by false, sh returns a single array or String of the sub-process's stdout followed by its stderr :env override the process env with a map (or the underlying Java String[] if you are a masochist). :dir override the process dir with a String or java.io.File. You can bind :env or :dir for multiple operations using with-sh-env and with-sh-dir." [& args] (let [opts (parse-args args) proc (.exec (Runtime/getRuntime) (into-array (:cmd opts)) (as-env-string (:env opts)) (as-file (:dir opts)))] (if (:in opts) (with-open [osw (OutputStreamWriter. (.getOutputStream proc))] (.write osw (:in opts))) (.close (.getOutputStream proc))) (with-open [stdout (.getInputStream proc) stderr (.getErrorStream proc)] (let [[[out err] combine-fn] (if (= (:out opts) :bytes) [(for [strm [stdout stderr]] (into-array Byte/TYPE (map byte (stream-seq strm)))) #(aconcat Byte/TYPE %1 %2)] [(for [strm [stdout stderr]] (apply str (map char (stream-seq (InputStreamReader. strm (:out opts)))))) str]) exit-code (.waitFor proc)] (if (:return-map opts) {:exit exit-code :out out :err err} (combine-fn out err)))))) (comment (println (sh "ls" "-l")) (println (sh "ls" "-l" "/no-such-thing")) (println (sh "sed" "s/[aeiou]/oo/g" :in "hello there\n")) (println (sh "cat" :in "x\u25bax\n")) (println (sh "echo" "x\u25bax")) (println (sh "echo" "x\u25bax" :out "ISO-8859-1")) ; reads 4 single-byte chars (println (sh "cat" "myimage.png" :out :bytes)) ; reads binary file into bytes[] ) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/singleton.clj000066400000000000000000000037361161102570000266130ustar00rootroot00000000000000;;; singleton.clj: singleton functions ;; by Stuart Sierra, http://stuartsierra.com/ ;; April 14, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; Change Log: ;; ;; April 14, 2009: added per-thread-singleton, renamed singleton to ;; global-singleton ;; ;; April 9, 2009: initial version (ns ^{:author "Stuart Sierra", :doc "Singleton functions"} clojure.contrib.singleton) (defn global-singleton "Returns a global singleton function. f is a function of no arguments that creates and returns some object. The singleton function will call f just once, the first time it is needed, and cache the value for all subsequent calls. Warning: global singletons are often unsafe in multi-threaded code. Consider per-thread-singleton instead." [f] (let [instance (atom nil) make-instance (fn [_] (f))] (fn [] (or @instance (swap! instance make-instance))))) (defn per-thread-singleton "Returns a per-thread singleton function. f is a function of no arguments that creates and returns some object. The singleton function will call f only once for each thread, and cache its value for subsequent calls from the same thread. This allows you to safely and lazily initialize shared objects on a per-thread basis. Warning: due to a bug in JDK 5, it may not be safe to use a per-thread-singleton in the initialization function for another per-thread-singleton. See http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=5025230" [f] (let [thread-local (proxy [ThreadLocal] [] (initialValue [] (f)))] (fn [] (.get thread-local)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/sql.clj000066400000000000000000000167021161102570000254050ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; sql.clj ;; ;; A Clojure interface to sql databases via jdbc ;; ;; See clojure.contrib.sql.test for an example ;; ;; scgilardi (gmail) ;; Created 2 April 2008 (ns ^{:author "Stephen C. Gilardi", :doc "A Clojure interface to sql databases via jdbc." :see-also [["http://github.com/richhickey/clojure-contrib/blob/master/src/test/clojure/clojure/contrib/test_sql.clj" "Example code"]]} clojure.contrib.sql (:use (clojure.contrib [def :only (defalias)] [string :only (as-str)]) clojure.contrib.sql.internal)) (defalias find-connection find-connection*) (defalias connection connection*) (defmacro with-connection "Evaluates body in the context of a new connection to a database then closes the connection. db-spec is a map containing values for one of the following parameter sets: Factory: :factory (required) a function of one argument, a map of params (others) (optional) passed to the factory function in a map DriverManager: :classname (required) a String, the jdbc driver class name :subprotocol (required) a String, the jdbc subprotocol :subname (required) a String, the jdbc subname (others) (optional) passed to the driver as properties. DataSource: :datasource (required) a javax.sql.DataSource :username (optional) a String :password (optional) a String, required if :username is supplied JNDI: :name (required) a String or javax.naming.Name :environment (optional) a java.util.Map" [db-spec & body] `(with-connection* ~db-spec (fn [] ~@body))) (defmacro transaction "Evaluates body as a transaction on the open database connection. Any nested transactions are absorbed into the outermost transaction. By default, all database updates are committed together as a group after evaluating the outermost body, or rolled back on any uncaught exception. If set-rollback-only is called within scope of the outermost transaction, the entire transaction will be rolled back rather than committed when complete." [& body] `(transaction* (fn [] ~@body))) (defn set-rollback-only "Marks the outermost transaction such that it will rollback rather than commit when complete" [] (rollback true)) (defn is-rollback-only "Returns true if the outermost transaction will rollback rather than commit when complete" [] (rollback)) (defn do-commands "Executes SQL commands on the open database connection." [& commands] (with-open [stmt (.createStatement (connection))] (doseq [cmd commands] (.addBatch stmt cmd)) (transaction (seq (.executeBatch stmt))))) (defn do-prepared "Executes an (optionally parameterized) SQL prepared statement on the open database connection. Each param-group is a seq of values for all of the parameters." [sql & param-groups] (with-open [stmt (.prepareStatement (connection) sql)] (doseq [param-group param-groups] (doseq [[index value] (map vector (iterate inc 1) param-group)] (.setObject stmt index value)) (.addBatch stmt)) (transaction (seq (.executeBatch stmt))))) (defn create-table "Creates a table on the open database connection given a table name and specs. Each spec is either a column spec: a vector containing a column name and optionally a type and other constraints, or a table-level constraint: a vector containing words that express the constraint. All words used to describe the table may be supplied as strings or keywords." [name & specs] (do-commands (format "CREATE TABLE %s (%s)" (as-str name) (apply str (map as-str (apply concat (interpose [", "] (map (partial interpose " ") specs)))))))) (defn drop-table "Drops a table on the open database connection given its name, a string or keyword" [name] (do-commands (format "DROP TABLE %s" (as-str name)))) (defn insert-values "Inserts rows into a table with values for specified columns only. column-names is a vector of strings or keywords identifying columns. Each value-group is a vector containing a values for each column in order. When inserting complete rows (all columns), consider using insert-rows instead." [table column-names & value-groups] (let [column-strs (map as-str column-names) n (count (first value-groups)) template (apply str (interpose "," (replicate n "?"))) columns (if (seq column-names) (format "(%s)" (apply str (interpose "," column-strs))) "")] (apply do-prepared (format "INSERT INTO %s %s VALUES (%s)" (as-str table) columns template) value-groups))) (defn insert-rows "Inserts complete rows into a table. Each row is a vector of values for each of the table's columns in order." [table & rows] (apply insert-values table nil rows)) (defn insert-records "Inserts records into a table. records are maps from strings or keywords (identifying columns) to values." [table & records] (doseq [record records] (insert-values table (keys record) (vals record)))) (defn delete-rows "Deletes rows from a table. where-params is a vector containing a string providing the (optionally parameterized) selection criteria followed by values for any parameters." [table where-params] (let [[where & params] where-params] (do-prepared (format "DELETE FROM %s WHERE %s" (as-str table) where) params))) (defn update-values "Updates values on selected rows in a table. where-params is a vector containing a string providing the (optionally parameterized) selection criteria followed by values for any parameters. record is a map from strings or keywords (identifying columns) to updated values." [table where-params record] (let [[where & params] where-params column-strs (map as-str (keys record)) columns (apply str (concat (interpose "=?, " column-strs) "=?"))] (do-prepared (format "UPDATE %s SET %s WHERE %s" (as-str table) columns where) (concat (vals record) params)))) (defn update-or-insert-values "Updates values on selected rows in a table, or inserts a new row when no existing row matches the selection criteria. where-params is a vector containing a string providing the (optionally parameterized) selection criteria followed by values for any parameters. record is a map from strings or keywords (identifying columns) to updated values." [table where-params record] (transaction (let [result (update-values table where-params record)] (if (zero? (first result)) (insert-values table (keys record) (vals record)) result)))) (defmacro with-query-results "Executes a query, then evaluates body with results bound to a seq of the results. sql-params is a vector containing a string providing the (optionally parameterized) SQL query followed by values for any parameters." [results sql-params & body] `(with-query-results* ~sql-params (fn [~results] ~@body))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/sql/000077500000000000000000000000001161102570000247055ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/sql/internal.clj000066400000000000000000000150761161102570000272240ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; internal definitions for clojure.contrib.sql ;; ;; scgilardi (gmail) ;; Created 3 October 2008 (ns clojure.contrib.sql.internal (:use (clojure.contrib [except :only (throwf throw-arg)] [properties :only (as-properties)] [seq :only (indexed)])) (:import (clojure.lang RT) (java.sql BatchUpdateException DriverManager SQLException Statement) (java.util Hashtable Map) (javax.naming InitialContext Name) (javax.sql DataSource))) (def *db* {:connection nil :level 0}) (def special-counts {Statement/EXECUTE_FAILED "EXECUTE_FAILED" Statement/SUCCESS_NO_INFO "SUCCESS_NO_INFO"}) (defn find-connection* "Returns the current database connection (or nil if there is none)" [] (:connection *db*)) (defn connection* "Returns the current database connection (or throws if there is none)" [] (or (find-connection*) (throwf "no current database connection"))) (defn rollback "Accessor for the rollback flag on the current connection" ([] (deref (:rollback *db*))) ([val] (swap! (:rollback *db*) (fn [_] val)))) (defn get-connection "Creates a connection to a database. db-spec is a map containing values for one of the following parameter sets: Factory: :factory (required) a function of one argument, a map of params (others) (optional) passed to the factory function in a map DriverManager: :classname (required) a String, the jdbc driver class name :subprotocol (required) a String, the jdbc subprotocol :subname (required) a String, the jdbc subname (others) (optional) passed to the driver as properties. DataSource: :datasource (required) a javax.sql.DataSource :username (optional) a String :password (optional) a String, required if :username is supplied JNDI: :name (required) a String or javax.naming.Name :environment (optional) a java.util.Map" [{:keys [factory classname subprotocol subname datasource username password name environment] :as db-spec}] (cond factory (factory (dissoc db-spec :factory)) (and classname subprotocol subname) (let [url (format "jdbc:%s:%s" subprotocol subname) etc (dissoc db-spec :classname :subprotocol :subname)] (RT/loadClassForName classname) (DriverManager/getConnection url (as-properties etc))) (and datasource username password) (.getConnection datasource username password) datasource (.getConnection datasource) name (let [env (and environment (Hashtable. environment)) context (InitialContext. env) datasource (.lookup context name)] (.getConnection datasource)) :else (throw-arg "db-spec %s is missing a required parameter" db-spec))) (defn with-connection* "Evaluates func in the context of a new connection to a database then closes the connection." [db-spec func] (with-open [con (get-connection db-spec)] (binding [*db* (assoc *db* :connection con :level 0 :rollback (atom false))] (func)))) (defn print-sql-exception "Prints the contents of an SQLException to stream" [stream exception] (.println stream (format (str "%s:" \newline " Message: %s" \newline " SQLState: %s" \newline " Error Code: %d") (.getSimpleName (class exception)) (.getMessage exception) (.getSQLState exception) (.getErrorCode exception)))) (defn print-sql-exception-chain "Prints a chain of SQLExceptions to stream" [stream exception] (loop [e exception] (when e (print-sql-exception stream e) (recur (.getNextException e))))) (defn print-update-counts "Prints the update counts from a BatchUpdateException to stream" [stream exception] (.println stream "Update counts:") (doseq [[index count] (indexed (.getUpdateCounts exception))] (.println stream (format " Statement %d: %s" index (get special-counts count count))))) (defn throw-rollback "Sets rollback and throws a wrapped exception" [e] (rollback true) (throwf e "transaction rolled back: %s" (.getMessage e))) (defn transaction* "Evaluates func as a transaction on the open database connection. Any nested transactions are absorbed into the outermost transaction. By default, all database updates are committed together as a group after evaluating the outermost body, or rolled back on any uncaught exception. If rollback is set within scope of the outermost transaction, the entire transaction will be rolled back rather than committed when complete." [func] (binding [*db* (update-in *db* [:level] inc)] (if (= (:level *db*) 1) (let [con (connection*) auto-commit (.getAutoCommit con)] (io! (.setAutoCommit con false) (try (func) (catch BatchUpdateException e (print-update-counts *err* e) (print-sql-exception-chain *err* e) (throw-rollback e)) (catch SQLException e (print-sql-exception-chain *err* e) (throw-rollback e)) (catch Exception e (throw-rollback e)) (finally (if (rollback) (.rollback con) (.commit con)) (rollback false) (.setAutoCommit con auto-commit))))) (func)))) (defn with-query-results* "Executes a query, then evaluates func passing in a seq of the results as an argument. The first argument is a vector containing the (optionally parameterized) sql query string followed by values for any parameters." [[sql & params :as sql-params] func] (when-not (vector? sql-params) (throw-arg "\"%s\" expected %s %s, found %s %s" "sql-params" "vector" "[sql param*]" (.getName (class sql-params)) (pr-str sql-params))) (with-open [stmt (.prepareStatement (connection*) sql)] (doseq [[index value] (map vector (iterate inc 1) params)] (.setObject stmt index value)) (with-open [rset (.executeQuery stmt)] (func (resultset-seq rset))))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/str_utils.clj000066400000000000000000000070011161102570000266260ustar00rootroot00000000000000;;; str_utils.clj -- string utilities for Clojure ;; by Stuart Sierra ;; April 8, 2008 ;; Copyright (c) Stuart Sierra, 2008. 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. ;; DEPRECATED in 1.2: Promoted to clojure.java.string. Note that ;; many function names and semantics have changed (ns ^{:author "Stuart Sierra", :deprecated "1.2" :doc "String utilities for Clojure"} clojure.contrib.str-utils (:import (java.util.regex Pattern))) (defn re-split "Splits the string on instances of 'pattern'. Returns a sequence of strings. Optional 'limit' argument is the maximum number of splits. Like Perl's 'split'." ([^Pattern pattern string] (seq (. pattern (split string)))) ([^Pattern pattern string limit] (seq (. pattern (split string limit))))) (defn re-partition "Splits the string into a lazy sequence of substrings, alternating between substrings that match the patthern and the substrings between the matches. The sequence always starts with the substring before the first match, or an empty string if the beginning of the string matches. For example: (re-partition #\"[a-z]+\" \"abc123def\") Returns: (\"\" \"abc\" \"123\" \"def\")" [^Pattern re string] (let [m (re-matcher re string)] ((fn step [prevend] (lazy-seq (if (.find m) (cons (.subSequence string prevend (.start m)) (cons (re-groups m) (step (+ (.start m) (count (.group m)))))) (when (< prevend (.length string)) (list (.subSequence string prevend (.length string))))))) 0))) (defn re-gsub "Replaces all instances of 'pattern' in 'string' with 'replacement'. Like Ruby's 'String#gsub'. If (ifn? replacment) is true, the replacement is called with the match. " [^java.util.regex.Pattern regex replacement ^String string] (if (ifn? replacement) (let [parts (vec (re-partition regex string))] (apply str (reduce (fn [parts match-idx] (update-in parts [match-idx] replacement)) parts (range 1 (count parts) 2)))) (.. regex (matcher string) (replaceAll replacement)))) (defn re-sub "Replaces the first instance of 'pattern' in 'string' with 'replacement'. Like Ruby's 'String#sub'. If (ifn? replacement) is true, the replacement is called with the match. " [^Pattern regex replacement ^String string] (if (ifn? replacement) (let [m (re-matcher regex string)] (if (.find m) (str (.subSequence string 0 (.start m)) (replacement (re-groups m)) (.subSequence string (.end m) (.length string))) string)) (.. regex (matcher string) (replaceFirst replacement)))) (defn str-join "Returns a string of all elements in 'sequence', separated by 'separator'. Like Perl's 'join'." [separator sequence] (apply str (interpose separator sequence))) (defn chop "Removes the last character of string." [s] (subs s 0 (dec (count s)))) (defn chomp "Removes all trailing newline \\n or return \\r characters from string. Note: String.trim() is similar and faster." [s] (re-sub #"[\r\n]+$" "" s)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/str_utils2.clj000066400000000000000000000274041161102570000267210ustar00rootroot00000000000000;;; str_utils2.clj -- functional string utilities for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; August 19, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; DEPRECATED in 1.2: Promoted to clojure.java.string. Note that ;; many function names and semantics have changed (ns ^{:author "Stuart Sierra" :deprecated "1.2" :doc "This is a library of string manipulation functions. It is intented as a replacement for clojure.contrib.str-utils. You cannot (use 'clojure.contrib.str-utils2) because it defines functions with the same names as functions in clojure.core. Instead, do (require '[clojure.contrib.str-utils2 :as s]) or something similar. Goals: 1. Be functional 2. String argument first, to work with -> 3. Performance linear in string length Some ideas are borrowed from http://github.com/francoisdevlin/devlinsf-clojure-utils/"} clojure.contrib.str-utils2 (:refer-clojure :exclude (take replace drop butlast partition contains? get repeat reverse partial)) (:import (java.util.regex Pattern))) (defmacro dochars "bindings => [name string] Repeatedly executes body, with name bound to each character in string. Does NOT handle Unicode supplementary characters (above U+FFFF)." [bindings & body] (assert (vector bindings)) (assert (= 2 (count bindings))) ;; This seems to be the fastest way to iterate over characters. `(let [^String s# ~(second bindings)] (dotimes [i# (.length s#)] (let [~(first bindings) (.charAt s# i#)] ~@body)))) (defmacro docodepoints "bindings => [name string] Repeatedly executes body, with name bound to the integer code point of each Unicode character in the string. Handles Unicode supplementary characters (above U+FFFF) correctly." [bindings & body] (assert (vector bindings)) (assert (= 2 (count bindings))) (let [character (first bindings) string (second bindings)] `(let [^String s# ~string len# (.length s#)] (loop [i# 0] (when (< i# len#) (let [~character (.charAt s# i#)] (if (Character/isHighSurrogate ~character) (let [~character (.codePointAt s# i#)] ~@body (recur (+ 2 i#))) (let [~character (int ~character)] ~@body (recur (inc i#)))))))))) (defn codepoints "Returns a sequence of integer Unicode code points in s. Handles Unicode supplementary characters (above U+FFFF) correctly." [^String s] (let [len (.length s) f (fn thisfn [^String s i] (when (< i len) (let [c (.charAt s i)] (if (Character/isHighSurrogate c) (cons (.codePointAt s i) (thisfn s (+ 2 i))) (cons (int c) (thisfn s (inc i)))))))] (lazy-seq (f s 0)))) (defn ^String escape "Returns a new String by applying cmap (a function or a map) to each character in s. If cmap returns nil, the original character is added to the output unchanged." [^String s cmap] (let [buffer (StringBuilder. (.length s))] (dochars [c s] (if-let [r (cmap c)] (.append buffer r) (.append buffer c))) (.toString buffer))) (defn blank? "True if s is nil, empty, or contains only whitespace." [^String s] (every? (fn [^Character c] (Character/isWhitespace c)) s)) (defn ^String take "Take first n characters from s, up to the length of s. Note the argument order is the opposite of clojure.core/take; this is to keep the string as the first argument for use with ->" [^String s n] (if (< (count s) n) s (.substring s 0 n))) (defn ^String drop "Drops first n characters from s. Returns an empty string if n is greater than the length of s. Note the argument order is the opposite of clojure.core/drop; this is to keep the string as the first argument for use with ->" [^String s n] (if (< (count s) n) "" (.substring s n))) (defn ^String butlast "Returns s without the last n characters. Returns an empty string if n is greater than the length of s. Note the argument order is the opposite of clojure.core/butlast; this is to keep the string as the first argument for use with ->" [^String s n] (if (< (count s) n) "" (.substring s 0 (- (count s) n)))) (defn ^String tail "Returns the last n characters of s." [^String s n] (if (< (count s) n) s (.substring s (- (count s) n)))) (defn ^String repeat "Returns a new String containing s repeated n times." [^String s n] (apply str (clojure.core/repeat n s))) (defn ^String reverse "Returns s with its characters reversed." [^String s] (.toString (.reverse (StringBuilder. s)))) (defmulti ^{:doc "Replaces all instances of pattern in string with replacement. Allowed argument types for pattern and replacement are: 1. String and String 2. Character and Character 3. regex Pattern and String (Uses java.util.regex.Matcher.replaceAll) 4. regex Pattern and function (Calls function with re-groups of each match, uses return value as replacement.)" :arglists '([string pattern replacement]) :tag String} replace (fn [^String string pattern replacement] [(class pattern) (class replacement)])) (defmethod replace [String String] [^String s ^String a ^String b] (.replace s a b)) (defmethod replace [Character Character] [^String s ^Character a ^Character b] (.replace s a b)) (defmethod replace [Pattern String] [^String s re replacement] (.replaceAll (re-matcher re s) replacement)) (defmethod replace [Pattern clojure.lang.IFn] [^String s re replacement] (let [m (re-matcher re s)] (let [buffer (StringBuffer. (.length s))] (loop [] (if (.find m) (do (.appendReplacement m buffer (replacement (re-groups m))) (recur)) (do (.appendTail m buffer) (.toString buffer))))))) (defmulti ^{:doc "Replaces the first instance of pattern in s with replacement. Allowed argument types for pattern and replacement are: 1. String and String 2. regex Pattern and String (Uses java.util.regex.Matcher.replaceAll) 3. regex Pattern and function " :arglists '([s pattern replacement]) :tag String} replace-first (fn [s pattern replacement] [(class pattern) (class replacement)])) (defmethod replace-first [String String] [^String s pattern replacement] (.replaceFirst (re-matcher (Pattern/quote pattern) s) replacement)) (defmethod replace-first [Pattern String] [^String s re replacement] (.replaceFirst (re-matcher re s) replacement)) (defmethod replace-first [Pattern clojure.lang.IFn] [^String s ^Pattern re f] (let [m (re-matcher re s)] (let [buffer (StringBuffer.)] (if (.find m) (let [rep (f (re-groups m))] (.appendReplacement m buffer rep) (.appendTail m buffer) (str buffer)))))) (defn partition "Splits the string into a lazy sequence of substrings, alternating between substrings that match the patthern and the substrings between the matches. The sequence always starts with the substring before the first match, or an empty string if the beginning of the string matches. For example: (partition \"abc123def\" #\"[a-z]+\") returns: (\"\" \"abc\" \"123\" \"def\")" [^String s ^Pattern re] (let [m (re-matcher re s)] ((fn step [prevend] (lazy-seq (if (.find m) (cons (.subSequence s prevend (.start m)) (cons (re-groups m) (step (+ (.start m) (count (.group m)))))) (when (< prevend (.length s)) (list (.subSequence s prevend (.length s))))))) 0))) (defn ^String join "Returns a string of all elements in coll, separated by separator. Like Perl's join." [^String separator coll] (apply str (interpose separator coll))) (defn ^String chop "Removes the last character of string, does nothing on a zero-length string." [^String s] (let [size (count s)] (if (zero? size) s (subs s 0 (dec (count s)))))) (defn ^String chomp "Removes all trailing newline \\n or return \\r characters from string. Note: String.trim() is similar and faster." [^String s] (replace s #"[\r\n]+$" "")) (defn title-case [^String s] (throw (Exception. "title-case not implemeted yet"))) (defn ^String swap-case "Changes upper case characters to lower case and vice-versa. Handles Unicode supplementary characters correctly. Uses the locale-sensitive String.toUpperCase() and String.toLowerCase() methods." [^String s] (let [buffer (StringBuilder. (.length s)) ;; array to make a String from one code point ^"[I" array (make-array Integer/TYPE 1)] (docodepoints [c s] (aset-int array 0 c) (if (Character/isLowerCase c) ;; Character.toUpperCase is not locale-sensitive, but ;; String.toUpperCase is; so we use a String. (.append buffer (.toUpperCase (String. array 0 1))) (.append buffer (.toLowerCase (String. array 0 1))))) (.toString buffer))) (defn ^String capitalize "Converts first character of the string to upper-case, all other characters to lower-case." [^String s] (if (< (count s) 2) (.toUpperCase s) (str (.toUpperCase ^String (subs s 0 1)) (.toLowerCase ^String (subs s 1))))) (defn ^String ltrim "Removes whitespace from the left side of string." [^String s] (replace s #"^\s+" "")) (defn ^String rtrim "Removes whitespace from the right side of string." [^String s] (replace s #"\s+$" "")) (defn split-lines "Splits s on \\n or \\r\\n." [^String s] (seq (.split #"\r?\n" s))) ;; borrowed from compojure.str-utils, by James Reeves, EPL 1.0 (defn ^String map-str "Apply f to each element of coll, concatenate all results into a String." [f coll] (apply str (map f coll))) ;; borrowed from compojure.str-utils, by James Reeves, EPL 1.0 (defn grep "Filters elements of coll by a regular expression. The String representation (with str) of each element is tested with re-find." [re coll] (filter (fn [x] (re-find re (str x))) coll)) (defn partial "Like clojure.core/partial for functions that take their primary argument first. Takes a function f and its arguments, NOT INCLUDING the first argument. Returns a new function whose first argument will be the first argument to f. Example: (str-utils2/partial str-utils2/take 2) ;;=> (fn [s] (str-utils2/take s 2))" [f & args] (fn [s & more] (apply f s (concat args more)))) ;;; WRAPPERS ;; The following functions are simple wrappers around java.lang.String ;; functions. They are included here for completeness, and for use ;; when mapping over a collection of strings. (defn ^String upper-case "Converts string to all upper-case." [^String s] (.toUpperCase s)) (defn ^String lower-case "Converts string to all lower-case." [^String s] (.toLowerCase s)) (defn split "Splits string on a regular expression. Optional argument limit is the maximum number of splits." ([^String s ^Pattern re] (seq (.split re s))) ([^String s ^Pattern re limit] (seq (.split re s limit)))) (defn ^String trim "Removes whitespace from both ends of string." [^String s] (.trim s)) (defn ^String contains? "True if s contains the substring." [^String s substring] (.contains s substring)) (defn ^String get "Gets the i'th character in string." [^String s i] (.charAt s i)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/stream_utils.clj000066400000000000000000000211641161102570000273170ustar00rootroot00000000000000;; Stream utilities ;; by Konrad Hinsen ;; last updated May 3, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "Functions for setting up computational pipelines via data streams. NOTE: This library is experimental. It may change significantly with future release. This library defines: - an abstract stream type, whose interface consists of the multimethod stream-next - a macro for implementing streams - implementations of stream for 1) Clojure sequences, and vectors 2) nil, representing an empty stream - tools for writing stream transformers, including the monad stream-m - various utility functions for working with streams Streams are building blocks in the construction of computational pipelines. A stream is represented by its current state plus a function that takes a stream state and obtains the next item in the stream as well as the new stream state. The state is implemented as a Java class or a Clojure type (as defined by the function clojure.core/type), and the function is provided as an implementation of the multimethod stream-next for this class or type. While setting up pipelines using this mechanism is somewhat more cumbersome than using Clojure's lazy seq mechanisms, there are a few advantages: - The state of a stream can be stored in any Clojure data structure, and the stream can be re-generated from it any number of times. Any number of states can be stored this way. - The elements of the stream are never cached, so keeping a reference to a stream state does not incur an uncontrollable memory penalty. Note that the stream mechanism is thread-safe as long as the concrete stream implementations do not use any mutable state. Stream transformers take any number of input streams and produce one output stream. They are typically written using the stream-m monad. In the definition of a stream transformer, (pick s) returns the next value of stream argument s, whereas pick-all returns the next value of all stream arguments in the form of a vector."} clojure.contrib.stream-utils (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.types :only (deftype deftype-)]) (:use [clojure.contrib.monads :only (defmonad with-monad)]) (:use [clojure.contrib.def :only (defvar defvar-)]) (:require [clojure.contrib.seq]) (:require [clojure.contrib.generic.collection])) ; ; Stream type and interface ; (defvar stream-type ::stream "The root type for the stream hierarchy. For each stream type, add a derivation from this type.") (defmacro defstream "Define object of the given type as a stream whose implementation of stream-next is defined by args and body. This macro adds a type-specific method for stream-next and derives type from stream-type." [type-tag args & body] `(do (derive ~type-tag stream-type) (defmethod stream-next ~type-tag ~args ~@body))) (defvar- stream-skip ::skip "The skip-this-item value.") (defn- stream-skip? "Returns true if x is the stream-skip." [x] (identical? x stream-skip)) (defmulti stream-next "Returns a vector [next-value new-state] where next-value is the next item in the data stream defined by stream-state and new-state is the new state of the stream. At the end of the stream, next-value and new-state are nil." {:arglists '([stream-state])} type) (defmethod stream-next nil [s] [nil nil]) (defmethod stream-next clojure.lang.ISeq [s] (if (seq s) [(first s) (rest s)] [nil nil])) (defmethod stream-next clojure.lang.IPersistentVector [v] (stream-next (seq v))) (defn stream-seq "Return a lazy seq on the stream. Also accessible via clojure.contrib.seq/seq-on and clojure.contrib.generic.collection/seq for streams." [s] (lazy-seq (let [[v ns] (stream-next s)] (if (nil? ns) nil (cons v (stream-seq ns)))))) (defmethod clojure.contrib.seq/seq-on stream-type [s] (stream-seq s)) (defmethod clojure.contrib.generic.collection/seq stream-type [s] (stream-seq s)) ; ; Stream transformers ; (defmonad stream-m "Monad describing stream computations. The monadic values can be of any type handled by stream-next." [m-result (fn m-result-stream [v] (fn [s] [v s])) m-bind (fn m-bind-stream [mv f] (fn [s] (let [[v ss :as r] (mv s)] (if (or (nil? ss) (stream-skip? v)) r ((f v) ss))))) m-zero (fn [s] [stream-skip s]) ]) (defn pick "Return the next value of stream argument n inside a stream transformer. When used inside of defst, the name of the stream argument can be used instead of its index n." [n] (fn [streams] (let [[v ns] (stream-next (streams n))] (if (nil? ns) [nil nil] [v (assoc streams n ns)])))) (defn pick-all "Return a vector containing the next value of each stream argument inside a stream transformer." [streams] (let [next (map stream-next streams) values (map first next) streams (vec (map second next))] (if (some nil? streams) [nil nil] [values streams]))) (deftype ::stream-transformer st-as-stream (fn [st streams] [st streams]) seq) (defstream ::stream-transformer [[st streams]] (loop [s streams] (let [[v ns] (st s)] (cond (nil? ns) [nil nil] (stream-skip? v) (recur ns) :else [v (st-as-stream st ns)])))) (defmacro defst "Define the stream transformer name by body. The non-stream arguments args and the stream arguments streams are given separately, with args being possibly empty." [name args streams & body] (if (= (first streams) '&) `(defn ~name ~(vec (concat args streams)) (let [~'st (with-monad stream-m ~@body)] (st-as-stream ~'st ~(second streams)))) `(defn ~name ~(vec (concat args streams)) (let [~'st (with-monad stream-m (let [~streams (range ~(count streams))] ~@body))] (st-as-stream ~'st ~streams))))) ; ; Stream utilities ; (defn stream-drop "Return a stream containing all but the first n elements of stream." [n stream] (if (zero? n) stream (let [[_ s] (stream-next stream)] (recur (dec n) s)))) ; Map a function on a stream (deftype- ::stream-map stream-map-state) (defstream ::stream-map [[f stream]] (let [[v ns] (stream-next stream)] (if (nil? ns) [nil nil] [(f v) (stream-map-state [f ns])]))) (defmulti stream-map "Return a new stream by mapping the function f on the given stream." {:arglists '([f stream])} (fn [f stream] (type stream))) (defmethod stream-map :default [f stream] (stream-map-state [f stream])) (defmethod stream-map ::stream-map [f [g stream]] (stream-map-state [(comp f g) stream])) ; Filter stream elements (deftype- ::stream-filter stream-filter-state) (defstream ::stream-filter [[p stream]] (loop [stream stream] (let [[v ns] (stream-next stream)] (cond (nil? ns) [nil nil] (p v) [v (stream-filter-state [p ns])] :else (recur ns))))) (defmulti stream-filter "Return a new stream that contrains the elements of stream that satisfy the predicate p." {:arglists '([p stream])} (fn [p stream] (type stream))) (defmethod stream-filter :default [p stream] (stream-filter-state [p stream])) (defmethod stream-filter ::stream-filter [p [q stream]] (stream-filter-state [(fn [v] (and (q v) (p v))) stream])) ; Flatten a stream of sequences (deftype- ::stream-flatten stream-flatten-state) (defstream ::stream-flatten [[buffer stream]] (loop [buffer buffer stream stream] (if (nil? buffer) (let [[v new-stream] (stream-next stream)] (cond (nil? new-stream) [nil nil] (empty? v) (recur nil new-stream) :else (recur v new-stream))) [(first buffer) (stream-flatten-state [(next buffer) stream])]))) (defn stream-flatten "Converts a stream of sequences into a stream of the elements of the sequences. Flattening is not recursive, only one level of nesting will be removed." [s] (stream-flatten-state [nil s])) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/string.clj000066400000000000000000000267251161102570000261220ustar00rootroot00000000000000;;; string.clj -- functional string utilities for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; January 26, 2010 ;; Copyright (c) Stuart Sierra, 2010. 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. ;; DEPRECATED in 1.2: Many functions have moved to clojure.string. (ns ^{:author "Stuart Sierra" :doc "This is a library of string manipulation functions. It is intented as a replacement for clojure.contrib.string. You cannot (use 'clojure.contrib.string) because it defines functions with the same names as functions in clojure.core. Instead, do (require '[clojure.contrib.string :as s]) or something similar. Goals: 1. Be functional 2. Most significant argument LAST, to work with ->> 3. At least O(n) performance for Strings of length n Some ideas are borrowed from http://github.com/francoisdevlin/devlinsf-clojure-utils/"} clojure.contrib.string (:refer-clojure :exclude (take replace drop butlast partition contains? get repeat reverse partial)) (:import (java.util.regex Pattern))) (defmacro dochars "bindings => [name string] Repeatedly executes body, with name bound to each character in string. Does NOT handle Unicode supplementary characters (above U+FFFF)." [bindings & body] (assert (vector bindings)) (assert (= 2 (count bindings))) ;; This seems to be the fastest way to iterate over characters. `(let [^String s# ~(second bindings)] (dotimes [i# (.length s#)] (let [~(first bindings) (.charAt s# i#)] ~@body)))) (defmacro docodepoints "bindings => [name string] Repeatedly executes body, with name bound to the integer code point of each Unicode character in the string. Handles Unicode supplementary characters (above U+FFFF) correctly." [bindings & body] (assert (vector bindings)) (assert (= 2 (count bindings))) (let [character (first bindings) string (second bindings)] `(let [^String s# ~string len# (.length s#)] (loop [i# 0] (when (< i# len#) (let [~character (.charAt s# i#)] (if (Character/isHighSurrogate ~character) (let [~character (.codePointAt s# i#)] ~@body (recur (+ 2 i#))) (let [~character (int ~character)] ~@body (recur (inc i#)))))))))) (defn codepoints "Returns a sequence of integer Unicode code points in s. Handles Unicode supplementary characters (above U+FFFF) correctly." [^String s] (let [len (.length s) f (fn thisfn [^String s i] (when (< i len) (let [c (.charAt s i)] (if (Character/isHighSurrogate c) (cons (.codePointAt s i) (thisfn s (+ 2 i))) (cons (int c) (thisfn s (inc i)))))))] (lazy-seq (f s 0)))) (defn ^String escape "Returns a new String by applying cmap (a function or a map) to each character in s. If cmap returns nil, the original character is added to the output unchanged." {:deprecated "1.2"} [cmap ^String s] (let [buffer (StringBuilder. (.length s))] (dochars [c s] (if-let [r (cmap c)] (.append buffer r) (.append buffer c))) (.toString buffer))) (defn blank? "True if s is nil, empty, or contains only whitespace." {:deprecated "1.2"} [^String s] (every? (fn [^Character c] (Character/isWhitespace c)) s)) (defn ^String take "Take first n characters from s, up to the length of s." [n ^String s] (if (< (count s) n) s (.substring s 0 n))) (defn ^String drop "Drops first n characters from s. Returns an empty string if n is greater than the length of s." [n ^String s] (if (< (count s) n) "" (.substring s n))) (defn ^String butlast "Returns s without the last n characters. Returns an empty string if n is greater than the length of s." [n ^String s] (if (< (count s) n) "" (.substring s 0 (- (count s) n)))) (defn ^String tail "Returns the last n characters of s." [n ^String s] (if (< (count s) n) s (.substring s (- (count s) n)))) (defn ^String repeat "Returns a new String containing s repeated n times." [n ^String s] (apply str (clojure.core/repeat n s))) (defn ^String reverse "Returns s with its characters reversed." {:deprecated "1.2"} [^String s] (.toString (.reverse (StringBuilder. s)))) (defn replace-str "Replaces all instances of substring a with b in s." {:deprecated "1.2"} [^String a ^String b ^String s] (.replace s a b)) (defn replace-char "Replaces all instances of character a with character b in s." {:deprecated "1.2"} [^Character a ^Character b ^String s] (.replace s a b)) (defn replace-re "Replaces all matches of re with replacement in s." {:deprecated "1.2"} [re replacement ^String s] (.replaceAll (re-matcher re s) replacement)) (defn replace-by "Replaces all matches of re in s with the result of (f (re-groups the-match))." {:deprecated "1.2"} [re f ^String s] (let [m (re-matcher re s)] (let [buffer (StringBuffer. (.length s))] (loop [] (if (.find m) (do (.appendReplacement m buffer (f (re-groups m))) (recur)) (do (.appendTail m buffer) (.toString buffer))))))) (defn replace-first-str "Replace first occurance of substring a with b in s." {:deprecated "1.2"} [^String a ^String b ^String s] (.replaceFirst (re-matcher (Pattern/quote a) s) b)) (defn replace-first-re "Replace first match of re in s." {:deprecated "1.2"} [^Pattern re ^String replacement ^String s] (.replaceFirst (re-matcher re s) replacement)) (defn replace-first-by "Replace first match of re in s with the result of (f (re-groups the-match))." {:deprecated "1.2"} [^Pattern re f ^String s] (let [m (re-matcher re s)] (let [buffer (StringBuffer.)] (if (.find m) (let [rep (f (re-groups m))] (.appendReplacement m buffer rep) (.appendTail m buffer) (str buffer)))))) (defn partition "Splits the string into a lazy sequence of substrings, alternating between substrings that match the patthern and the substrings between the matches. The sequence always starts with the substring before the first match, or an empty string if the beginning of the string matches. For example: (partition #\"[a-z]+\" \"abc123def\") returns: (\"\" \"abc\" \"123\" \"def\")" [^Pattern re ^String s] (let [m (re-matcher re s)] ((fn step [prevend] (lazy-seq (if (.find m) (cons (.subSequence s prevend (.start m)) (cons (re-groups m) (step (+ (.start m) (count (.group m)))))) (when (< prevend (.length s)) (list (.subSequence s prevend (.length s))))))) 0))) (defn ^String join "Returns a string of all elements in coll, separated by separator. Like Perl's join." {:deprecated "1.2"} [^String separator coll] (apply str (interpose separator coll))) (defn ^String chop "Removes the last character of string, does nothing on a zero-length string." [^String s] (let [size (count s)] (if (zero? size) s (subs s 0 (dec (count s)))))) (defn ^String chomp "Removes all trailing newline \\n or return \\r characters from string. Note: String.trim() is similar and faster. Deprecated in 1.2. Use clojure.string/trim-newline" {:deprecated "1.2"} [^String s] (replace-re #"[\r\n]+$" "" s)) (defn ^String swap-case "Changes upper case characters to lower case and vice-versa. Handles Unicode supplementary characters correctly. Uses the locale-sensitive String.toUpperCase() and String.toLowerCase() methods." [^String s] (let [buffer (StringBuilder. (.length s)) ;; array to make a String from one code point ^"[I" array (make-array Integer/TYPE 1)] (docodepoints [c s] (aset-int array 0 c) (if (Character/isLowerCase c) ;; Character.toUpperCase is not locale-sensitive, but ;; String.toUpperCase is; so we use a String. (.append buffer (.toUpperCase (String. array 0 1))) (.append buffer (.toLowerCase (String. array 0 1))))) (.toString buffer))) (defn ^String capitalize "Converts first character of the string to upper-case, all other characters to lower-case." {:deprecated "1.2"} [^String s] (if (< (count s) 2) (.toUpperCase s) (str (.toUpperCase ^String (subs s 0 1)) (.toLowerCase ^String (subs s 1))))) (defn ^String ltrim "Removes whitespace from the left side of string. Deprecated in 1.2. Use clojure.string/triml." {:deprecated "1.2"} [^String s] (replace-re #"^\s+" "" s)) (defn ^String rtrim "Removes whitespace from the right side of string. Deprecated in 1.2. Use clojure.string/trimr." {:deprecated "1.2"} [^String s] (replace-re #"\s+$" "" s)) (defn split-lines "Splits s on \\n or \\r\\n." {:deprecated "1.2"} [^String s] (seq (.split #"\r?\n" s))) ;; borrowed from compojure.string, by James Reeves, EPL 1.0 (defn ^String map-str "Apply f to each element of coll, concatenate all results into a String." [f coll] (apply str (map f coll))) ;; borrowed from compojure.string, by James Reeves, EPL 1.0 (defn grep "Filters elements of coll by a regular expression. The String representation (with str) of each element is tested with re-find." [re coll] (filter (fn [x] (re-find re (str x))) coll)) (defn as-str "Like clojure.core/str, but if an argument is a keyword or symbol, its name will be used instead of its literal representation. Example: (str :foo :bar) ;;=> \":foo:bar\" (as-str :foo :bar) ;;=> \"foobar\" Note that this does not apply to keywords or symbols nested within data structures; they will be rendered as with str. Example: (str {:foo :bar}) ;;=> \"{:foo :bar}\" (as-str {:foo :bar}) ;;=> \"{:foo :bar}\" " ([] "") ([x] (if (instance? clojure.lang.Named x) (name x) (str x))) ([x & ys] ((fn [^StringBuilder sb more] (if more (recur (. sb (append (as-str (first more)))) (next more)) (str sb))) (new StringBuilder ^String (as-str x)) ys))) ;;; WRAPPERS ;; The following functions are simple wrappers around java.lang.String ;; functions. They are included here for completeness, and for use ;; when mapping over a collection of strings. (defn ^String upper-case "Converts string to all upper-case." {:deprecated "1.2"} [^String s] (.toUpperCase s)) (defn ^String lower-case "Converts string to all lower-case." {:deprecated "1.2"} [^String s] (.toLowerCase s)) (defn split "Splits string on a regular expression. Optional argument limit is the maximum number of splits." {:deprecated "1.2"} ([^Pattern re ^String s] (seq (.split re s))) ([^Pattern re limit ^String s] (seq (.split re s limit)))) (defn ^String trim "Removes whitespace from both ends of string." {:deprecated "1.2"} [^String s] (.trim s)) (defn ^String substring? "True if s contains the substring." [substring ^String s] (.contains s substring)) (defn ^String get "Gets the i'th character in string." {:deprecated "1.2"} [^String s i] (.charAt s i)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/strint.clj000066400000000000000000000053651161102570000261340ustar00rootroot00000000000000;;; strint.clj -- String interpolation for Clojure ;; originally proposed/published at http://muckandbrass.com/web/x/AgBP ;; by Chas Emerick ;; December 4, 2009 ;; Copyright (c) Chas Emerick, 2009. 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 ^{:author "Chas Emerick", :doc "String interpolation for Clojure."} clojure.contrib.strint) (defn- silent-read "Attempts to clojure.core/read a single form from the provided String, returning a vector containing the read form and a String containing the unread remainder of the provided String. Returns nil if no valid form can be read from the head of the String." [s] (try (let [r (-> s java.io.StringReader. java.io.PushbackReader.)] [(read r) (slurp r)]) (catch Exception e))) ; this indicates an invalid form -- the head of s is just string data (defn- interpolate "Yields a seq of Strings and read forms." ([s atom?] (lazy-seq (if-let [[form rest] (silent-read (subs s (if atom? 2 1)))] (cons form (interpolate (if atom? (subs rest 1) rest))) (cons (subs s 0 2) (interpolate (subs s 2)))))) ([^String s] (if-let [start (->> ["~{" "~("] (map #(.indexOf s %)) (remove #(== -1 %)) sort first)] (lazy-seq (cons (subs s 0 start) (interpolate (subs s start) (= \{ (.charAt s (inc start)))))) [s]))) (defmacro << "Takes a single string argument and emits a str invocation that concatenates the string data and evaluated expressions contained within that argument. Evaluation is controlled using ~{} and ~() forms. The former is used for simple value replacement using clojure.core/str; the latter can be used to embed the results of arbitrary function invocation into the produced string. Examples: user=> (def v 30.5) #'user/v user=> (<< \"This trial required ~{v}ml of solution.\") \"This trial required 30.5ml of solution.\" user=> (<< \"There are ~(int v) days in November.\") \"There are 30 days in November.\" user=> (def m {:a [1 2 3]}) #'user/m user=> (<< \"The total for your order is $~(->> m :a (apply +)).\") \"The total for your order is $6.\" Note that quotes surrounding string literals within ~() forms must be escaped." [string] `(str ~@(interpolate string))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/swing_utils.clj000066400000000000000000000124701161102570000271530ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; clojure.contrib.swing-utils ;; ;; Useful functions for interfacing Clojure to Swing ;; ;; scgilardi (gmail) ;; Created 31 May 2009 (ns clojure.contrib.swing-utils (:import (java.awt.event ActionListener KeyAdapter) (javax.swing AbstractAction Action JMenu JMenuBar JMenuItem SwingUtilities)) (:use [clojure.contrib.def :only (defvar)])) (defn add-action-listener "Adds an ActionLister to component. When the action fires, f will be invoked with the event as its first argument followed by args. Returns the listener." [component f & args] (let [listener (proxy [ActionListener] [] (actionPerformed [event] (apply f event args)))] (.addActionListener component listener) listener)) (defn add-key-typed-listener "Adds a KeyListener to component that only responds to KeyTyped events. When a key is typed, f is invoked with the KeyEvent as its first argument followed by args. Returns the listener." [component f & args] (let [listener (proxy [KeyAdapter] [] (keyTyped [event] (apply f event args)))] (.addKeyListener component listener) listener)) ;; ---------------------------------------------------------------------- ;; Meikel Brandmeyer (defn do-swing* "Runs thunk in the Swing event thread according to schedule: - :later => schedule the execution and return immediately - :now => wait until the execution completes." [schedule thunk] (cond (= schedule :later) (SwingUtilities/invokeLater thunk) (= schedule :now) (if (SwingUtilities/isEventDispatchThread) (thunk) (SwingUtilities/invokeAndWait thunk))) nil) (defmacro do-swing "Executes body in the Swing event thread asynchronously. Returns immediately after scheduling the execution." [& body] `(do-swing* :later (fn [] ~@body))) (defmacro do-swing-and-wait "Executes body in the Swing event thread synchronously. Returns after the execution is complete." [& body] `(do-swing* :now (fn [] ~@body))) (defvar action-translation-table (atom {:name Action/NAME :accelerator Action/ACCELERATOR_KEY :command-key Action/ACTION_COMMAND_KEY :long-desc Action/LONG_DESCRIPTION :short-desc Action/SHORT_DESCRIPTION :mnemonic Action/MNEMONIC_KEY :icon Action/SMALL_ICON}) "Translation table for the make-action constructor.") (defn make-action "Create an Action proxy from the given action spec. The standard keys recognised are: :name, :accelerator, :command-key, :long-desc, :short-desc, :mnemonic and :icon - corresponding to the similar named Action properties. The :handler value is used in the actionPerformed method of the proxy to pass on the event." [spec] (let [t-table @action-translation-table handler (:handler spec) spec (dissoc spec :handler) spec (map (fn [[k v]] [(t-table k) v]) spec) action (proxy [AbstractAction] [] (actionPerformed [evt] (handler evt)))] (doseq [[k v] spec] (.putValue action k v)) action)) (defvar menu-constructor-dispatch (atom #{:action :handler :items}) "An atom containing the dispatch set for the add-menu-item method.") (defmulti add-menu-item "Adds a menu item to the parent according to the item description. The item description is a map of the following structure. Either: - one single :action specifying a javax.swing.Action to be associated with the item. - a specification suitable for make-action - a set of :name, :mnemonic and :items keys, specifying a submenu with the given sequence of item entries. - an empty map specifying a separator." {:arglists '([parent item])} (fn add-menu-item-dispatch [_ item] (some @menu-constructor-dispatch (keys item)))) (defmethod add-menu-item :action add-menu-item-action [parent {:keys [action]}] (let [item (JMenuItem. action)] (.add parent item))) (defmethod add-menu-item :handler add-menu-item-handler [parent spec] (add-menu-item parent {:action (make-action spec)})) (defmethod add-menu-item :items add-menu-item-submenu [parent {:keys [items mnemonic name]}] (let [menu (JMenu. name)] (when mnemonic (.setMnemonic menu mnemonic)) (doseq [item items] (add-menu-item menu item)) (.add parent menu))) (defmethod add-menu-item nil ; nil meaning separator add-menu-item-separator [parent _] (.addSeparator parent)) (defn make-menubar "Create a menubar containing the given sequence of menu items. The menu items are described by a map as is detailed in the docstring of the add-menu-item function." [menubar-items] (let [menubar (JMenuBar.)] (doseq [item menubar-items] (add-menu-item menubar item)) menubar)) ;; ---------------------------------------------------------------------- clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/test_is.clj000066400000000000000000000076331161102570000262630ustar00rootroot00000000000000;;; test_is.clj: Compatibility layer for old clojure.contrib.test-is ;; by Stuart Sierra, http://stuartsierra.com/ ;; August 28, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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. ;; DEPRECATED in 1.2: Moved to clojure.test (ns ^{:deprecated "1.2" :doc "Backwards-compatibility for clojure.contrib.test-is The clojure.contrib.test-is library moved from Contrib into the Clojure distribution as clojure.test. This happened on or around clojure-contrib Git commit 82cf0409d0fcb71be477ebfc4da18ee2128a2ad1 on June 25, 2009. This file makes the clojure.test interface available under the old namespace clojure.contrib.test-is. This includes support for the old syntax of the 'are' macro. This was suggested by Howard Lewis Ship in ticket #26, http://www.assembla.com/spaces/clojure-contrib/tickets/26" :author "Stuart Sierra"} clojure.contrib.test-is (:require clojure.test [clojure.walk :as walk])) ;;; COPY INTERNED VARS (EXCEPT are) FROM clojure.test (doseq [v (disj (set (vals (ns-interns 'clojure.test))) #'clojure.test/are)] (intern *ns* (with-meta (:name (meta v)) (meta v)) (var-get v))) ;;; REDEFINE OLD clojure.contrib.template (defn find-symbols "Recursively finds all symbols in form." [form] (distinct (filter symbol? (tree-seq coll? seq form)))) (defn find-holes "Recursively finds all symbols starting with _ in form." [form] (sort (distinct (filter #(.startsWith (name %) "_") (find-symbols form))))) (defn find-pure-exprs "Recursively finds all sub-expressions in form that do not contain any symbols starting with _" [form] (filter #(and (list? %) (empty? (find-holes %))) (tree-seq seq? seq form))) (defn flatten-map "Transforms a map into a vector like [key value key value]." [m] (reduce (fn [coll [k v]] (conj coll k v)) [] m)) (defn template? "Returns true if form is a valid template expression." [form] (if (seq (find-holes form)) true false)) (defn apply-template "Replaces _1, _2, _3, etc. in expr with corresponding elements of values. Returns the modified expression. For use in macros." [expr values] (when-not (template? expr) (throw (IllegalArgumentException. (str (pr-str expr) " is not a valid template.")))) (let [expr (walk/postwalk-replace {'_ '_1} expr) holes (find-holes expr) smap (zipmap holes values)] (walk/prewalk-replace smap expr))) (defmacro do-template "Repeatedly evaluates template expr (in a do block) using values in args. args are grouped by the number of holes in the template. Example: (do-template (check _1 _2) :a :b :c :d) expands to (do (check :a :b) (check :c :d))" [expr & args] (when-not (template? expr) (throw (IllegalArgumentException. (str (pr-str expr) " is not a valid template.")))) (let [expr (walk/postwalk-replace {'_ '_1} expr) argcount (count (find-holes expr))] `(do ~@(map (fn [a] (apply-template expr a)) (partition argcount args))))) ;;; REDEFINE are MACRO TO MATCH OLD TEMPLATE BEHAVIOR (defmacro are "Checks multiple assertions with a template expression. See clojure.contrib.template/do-template for an explanation of templates. Example: (are (= _1 _2) 2 (+ 1 1) 4 (* 2 2)) Expands to: (do (is (= 2 (+ 1 1))) (is (= 4 (* 2 2)))) Note: This breaks some reporting features, such as line numbers." [expr & args] `(do-template (is ~expr) ~@args)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/trace.clj000066400000000000000000000057541161102570000257110ustar00rootroot00000000000000;;; trace.clj -- simple call-tracing macros for Clojure ;; by Stuart Sierra, http://stuartsierra.com/ ;; December 3, 2008 ;; Copyright (c) Stuart Sierra, 2008. 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. ;; This file defines simple "tracing" macros to help you see what your ;; code is doing. ;; CHANGE LOG ;; ;; December 3, 2008: ;; ;; * replaced *trace-out* with tracer ;; ;; * made trace a function instead of a macro ;; (suggestion from Stuart Halloway) ;; ;; * added trace-fn-call ;; ;; June 9, 2008: first version (ns ^{:author "Stuart Sierra, Michel Salim", :doc "This file defines simple \"tracing\" macros to help you see what your code is doing."} clojure.contrib.trace) (def ^{:doc "Current stack depth of traced function calls."} *trace-depth* 0) (defn tracer "This function is called by trace. Prints to standard output, but may be rebound to do anything you like. 'name' is optional." [name value] (println (str "TRACE" (when name (str " " name)) ": " value))) (defn trace "Sends name (optional) and value to the tracer function, then returns value. May be wrapped around any expression without affecting the result." ([value] (trace nil value)) ([name value] (tracer name (pr-str value)) value)) (defn trace-indent "Returns an indentation string based on *trace-depth*" [] (apply str (take *trace-depth* (repeat "| ")))) (defn trace-fn-call "Traces a single call to a function f with args. 'name' is the symbol name of the function." [name f args] (let [id (gensym "t")] (tracer id (str (trace-indent) (pr-str (cons name args)))) (let [value (binding [*trace-depth* (inc *trace-depth*)] (apply f args))] (tracer id (str (trace-indent) "=> " (pr-str value))) value))) (defmacro deftrace "Use in place of defn; traces each call/return of this fn, including arguments. Nested calls to deftrace'd functions will print a tree-like structure." [name & definition] `(do (def ~name) (let [f# (fn ~@definition)] (defn ~name [& args#] (trace-fn-call '~name f# args#))))) (defmacro dotrace "Given a sequence of function identifiers, evaluate the body expressions in an environment in which the identifiers are bound to the traced functions. Does not work on inlined functions, such as clojure.core/+" [fnames & exprs] `(binding [~@(interleave fnames (for [fname fnames] `(let [f# @(var ~fname)] (fn [& args#] (trace-fn-call '~fname f# args#)))))] ~@exprs)) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/types.clj000066400000000000000000000227461161102570000257570ustar00rootroot00000000000000;; Data types ;; by Konrad Hinsen ;; last updated May 3, 2009 ;; Copyright (c) Konrad Hinsen, 2009. 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 ^{:author "Konrad Hinsen" :doc "General and algebraic data types"} clojure.contrib.types (:refer-clojure :exclude (deftype)) (:use [clojure.contrib.def :only (name-with-attributes)])) ; ; Utility functions ; (defn- qualified-symbol [s] (symbol (str *ns*) (str s))) (defn- qualified-keyword [s] (keyword (str *ns*) (str s))) (defn- unqualified-symbol [s] (let [s-str (str s)] (symbol (subs s-str (inc (.indexOf s-str (int \/))))))) (defn- resolve-symbol [s] (if-let [var (resolve s)] (symbol (str (.ns var)) (str (.sym var))) s)) ; ; Data type definition ; (defmulti deconstruct type) (defmulti constructor-form type) (defmethod constructor-form :default [o] nil) (defmethod constructor-form ::type [o] (cons (::constructor (meta o)) (deconstruct o))) (defmacro deftype "Define a data type by a type tag (a namespace-qualified keyword) and a symbol naming the constructor function. Optionally, a constructor and a deconstructor function can be given as well, the defaults being 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." {:arglists '([type-tag constructor-name docstring? attr-map?] [type-tag constructor-name docstring? attr-map? constructor] [type-tag constructor-name docstring? attr-map? constructor deconstructor])} [type-tag constructor-name & options] (let [[constructor-name options] (name-with-attributes constructor-name options) [constructor deconstructor] options constructor (if (nil? constructor) 'clojure.core/identity constructor) deconstructor (if (nil? deconstructor) 'clojure.core/list deconstructor)] `(do (derive ~type-tag ::type) (let [meta-map# {:type ~type-tag ::constructor (quote ~(qualified-symbol constructor-name))}] (def ~constructor-name (comp (fn [~'x] (with-meta ~'x meta-map#)) ~constructor)) (defmethod deconstruct ~type-tag [~'x] (~deconstructor (with-meta ~'x {}))))))) (defmacro deftype- "Same as deftype but the constructor is private." [type-tag constructor-name & optional] `(deftype ~type-tag ~(vary-meta constructor-name assoc :private true) ~@optional)) (defmethod print-method ::type [o w] (let [cf (constructor-form o)] (if (symbol? cf) (print-method (unqualified-symbol cf) w) (print-method (cons (unqualified-symbol (first cf)) (rest cf)) w)))) ; ; Algebraic types ; (derive ::adt ::type) (defmethod constructor-form ::adt [o] (let [v (vals o)] (if (= 1 (count v)) (first v) v))) (defn- constructor-code [meta-map-symbol constructor] (if (symbol? constructor) `(def ~constructor (with-meta {::tag (quote ~(qualified-symbol constructor))} ~meta-map-symbol)) (let [[name & args] constructor keys (cons ::tag (map (comp keyword str) args))] (if (empty? args) (throw (IllegalArgumentException. "zero argument constructor")) `(let [~'basis (create-struct ~@keys)] (defn ~name ~(vec args) (with-meta (struct ~'basis (quote ~(qualified-symbol name)) ~@args) ~meta-map-symbol))))))) (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 tag must be a keyword." [type-tag & constructors] (let [meta-map-symbol (gensym "mm")] `(let [~meta-map-symbol {:type ~type-tag}] (derive ~type-tag ::adt) ~@(map (partial constructor-code meta-map-symbol) constructors) ))) ; ; Matching templates ; (defn- symbol-tests-and-bindings [template vsymbol] [`(= (quote ~(resolve-symbol template)) ~vsymbol) []]) (defn- sequential-tests-and-bindings [template vsymbol] (let [enum-values (map list template (range (count template))) ; Non-symbols in the template create an equality test with the ; corresponding value in the object's value list tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i))) (filter (complement #(symbol? (first %))) enum-values)) ; Symbols in the template become bindings to the corresponding ; value in the object. However, if a symbol occurs more than once, ; only one binding is generated, and equality tests are added ; for the other values. bindings (reduce (fn [map [symbol index]] (assoc map symbol (conj (get map symbol []) index))) {} (filter #(symbol? (first %)) enum-values)) tests (concat tests (map (fn [[symbol indices]] (cons `= (map #(list `nth vsymbol %) indices))) (filter #(> (count (second %)) 1) bindings))) bindings (mapcat (fn [[symbol indices]] [symbol (list `nth vsymbol (first indices))]) bindings)] [tests (vec bindings)])) (defn- constr-tests-and-bindings [template cfsymbol] (let [[tag & values] template cfasymbol (gensym) [tests bindings] (sequential-tests-and-bindings values cfasymbol) argtests (if (empty? tests) tests `((let [~cfasymbol (rest ~cfsymbol)] ~@tests)))] [`(and (seq? ~cfsymbol) (= (quote ~(resolve-symbol tag)) (first ~cfsymbol)) ~@argtests) `[~cfasymbol (rest ~cfsymbol) ~@bindings]])) (defn- list-tests-and-bindings [template vsymbol] (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)] [`(and (list? ~vsymbol) ~@tests) bindings])) (defn- vector-tests-and-bindings [template vsymbol] (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)] [`(and (vector? ~vsymbol) ~@tests) bindings])) (defn- map-tests-and-bindings [template vsymbol] (let [; First test if the given keys are all present. tests (map (fn [[k v]] `(contains? ~vsymbol ~k)) template) ; Non-symbols in the template create an equality test with the ; corresponding value in the object's value list. tests (concat tests (map (fn [[k v]] `(= ~v (~k ~vsymbol))) (filter (complement #(symbol? (second %))) template))) ; Symbols in the template become bindings to the corresponding ; value in the object. However, if a symbol occurs more than once, ; only one binding is generated, and equality tests are added ; for the other values. bindings (reduce (fn [map [key symbol]] (assoc map symbol (conj (get map symbol []) key))) {} (filter #(symbol? (second %)) template)) tests (concat tests (map (fn [[symbol keys]] (cons `= (map #(list % vsymbol) keys))) (filter #(> (count (second %)) 1) bindings))) bindings (mapcat (fn [[symbol keys]] [symbol (list (first keys) vsymbol)]) bindings)] [`(and (map? ~vsymbol) ~@tests) (vec bindings)])) (defn- tests-and-bindings [template vsymbol cfsymbol] (cond (symbol? template) (symbol-tests-and-bindings template cfsymbol) (seq? template) (if (= (first template) 'quote) (list-tests-and-bindings (second template) vsymbol) (constr-tests-and-bindings template cfsymbol)) (vector? template) (vector-tests-and-bindings template vsymbol) (map? template) (map-tests-and-bindings template vsymbol) :else (throw (IllegalArgumentException. "illegal template for match")))) (defmacro match "Given a value and a list of template-expr clauses, evaluate the first expr whose template matches the value. There are four kinds of templates: 1) Lists of the form (tag x1 x2 ...) match instances of types whose constructor has the same form as the list. 2) Quoted lists of the form '(x1 x2 ...) match lists of the same length. 3) Vectors of the form [x1 x2 ...] match vectors of the same length. 4) Maps of the form {:key1 x1 :key2 x2 ...} match maps that have the same keys as the template, but which can have additional keys that are not part of the template. The values x1, x2, ... can be symbols or non-symbol values. Non-symbols must be equal to the corresponding values in the object to be matched. Symbols will be bound to the corresponding value in the object in the evaluation of expr. If the same symbol occurs more than once in a, template the corresponding elements of the object must be equal for the template to match." [value & clauses] (when (odd? (count clauses)) (throw (Exception. "Odd number of elements in match expression"))) (let [vsymbol (gensym) cfsymbol (gensym) terms (mapcat (fn [[template expr]] (if (= template :else) [template expr] (let [[tests bindings] (tests-and-bindings template vsymbol cfsymbol)] [tests (if (empty? bindings) expr `(let ~bindings ~expr))]))) (partition 2 clauses))] `(let [~vsymbol ~value ~cfsymbol (constructor-form ~vsymbol)] (cond ~@terms)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/with_ns.clj000066400000000000000000000024611161102570000262560ustar00rootroot00000000000000;;; with_ns.clj -- temporary namespace macro ;; by Stuart Sierra, http://stuartsierra.com/ ;; March 28, 2009 ;; Copyright (c) Stuart Sierra, 2009. 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 ^{:author "Stuart Sierra", :doc "Temporary namespace macro"} clojure.contrib.with-ns) (defmacro with-ns "Evaluates body in another namespace. ns is either a namespace object or a symbol. This makes it possible to define functions in namespaces other than the current one." [ns & body] `(binding [*ns* (the-ns ~ns)] ~@(map (fn [form] `(eval '~form)) body))) (defmacro with-temp-ns "Evaluates body in an anonymous namespace, which is then immediately removed. The temporary namespace will 'refer' clojure.core." [& body] `(try (create-ns 'sym#) (let [result# (with-ns 'sym# (clojure.core/refer-clojure) ~@body)] result#) (finally (remove-ns 'sym#)))) clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/zip_filter.clj000066400000000000000000000066561161102570000267640ustar00rootroot00000000000000; Copyright (c) Chris Houser, April 2008. 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. ; System for filtering trees and nodes generated by zip.clj in ; general, and xml trees in particular. (ns ^{:author "Chris Houser", :doc "System for filtering trees and nodes generated by zip.clj in general, and xml trees in particular. "} clojure.contrib.zip-filter (:refer-clojure :exclude (descendants ancestors)) (:require [clojure.zip :as zip])) ; This uses the negative form (no-auto) so that the result from any ; naive function, including user functions, defaults to "auto". (defn auto [v x] (with-meta x ((if v dissoc assoc) (meta x) :zip-filter/no-auto? true))) (defn auto? [x] (not (:zip-filter/no-auto? (meta x)))) (defn right-locs "Returns a lazy sequence of locations to the right of loc, starting with loc." [loc] (lazy-seq (when loc (cons (auto false loc) (right-locs (zip/right loc)))))) (defn left-locs "Returns a lazy sequence of locations to the left of loc, starting with loc." [loc] (lazy-seq (when loc (cons (auto false loc) (left-locs (zip/left loc)))))) (defn leftmost? "Returns true if there are no more nodes to the left of location loc." [loc] (nil? (zip/left loc))) (defn rightmost? "Returns true if there are no more nodes to the right of location loc." [loc] (nil? (zip/right loc))) (defn children "Returns a lazy sequence of all immediate children of location loc, left-to-right." [loc] (when (zip/branch? loc) (map #(auto false %) (right-locs (zip/down loc))))) (defn children-auto "Returns a lazy sequence of all immediate children of location loc, left-to-right, marked so that a following tag= predicate will auto-descend." ^{:private true} [loc] (when (zip/branch? loc) (map #(auto true %) (right-locs (zip/down loc))))) (defn descendants "Returns a lazy sequence of all descendants of location loc, in depth-first order, left-to-right, starting with loc." [loc] (lazy-seq (cons (auto false loc) (mapcat descendants (children loc))))) (defn ancestors "Returns a lazy sequence of all ancestors of location loc, starting with loc and proceeding to loc's parent node and on through to the root of the tree." [loc] (lazy-seq (when loc (cons (auto false loc) (ancestors (zip/up loc)))))) (defn- fixup-apply "Calls (pred loc), and then converts the result to the 'appropriate' sequence." ^{:private true} [pred loc] (let [rtn (pred loc)] (cond (and (map? (meta rtn)) (:zip-filter/is-node? (meta rtn))) (list rtn) (= rtn true) (list loc) (= rtn false) nil (nil? rtn) nil (sequential? rtn) rtn :else (list rtn)))) (defn mapcat-chain ^{:private true} [loc preds mkpred] (reduce (fn [prevseq expr] (mapcat #(fixup-apply (or (mkpred expr) expr) %) prevseq)) (list (with-meta loc (assoc (meta loc) :zip-filter/is-node? true))) preds)) ; see clojure.contrib.zip-filter.xml for examples clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/zip_filter/000077500000000000000000000000001161102570000262555ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/main/clojure/clojure/contrib/zip_filter/xml.clj000066400000000000000000000130601161102570000275470ustar00rootroot00000000000000; Copyright (c) Chris Houser, April 2008. 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. ; Specialization of zip-filter for xml trees. (ns clojure.contrib.zip-filter.xml (:require [clojure.contrib.zip-filter :as zf] [clojure.zip :as zip] [clojure.xml :as xml])) (declare xml->) (defn attr "Returns the xml attribute named attrname, of the xml node at location loc." ([attrname] (fn [loc] (attr loc attrname))) ([loc attrname] (when (zip/branch? loc) (-> loc zip/node :attrs attrname)))) (defn attr= "Returns a query predicate that matches a node when it has an attribute named attrname whose value is attrval." [attrname attrval] (fn [loc] (= attrval (attr loc attrname)))) (defn tag= "Returns a query predicate that matches a node when its is a tag named tagname." [tagname] (fn [loc] (filter #(and (zip/branch? %) (= tagname ((zip/node %) :tag))) (if (zf/auto? loc) (zf/children-auto loc) (list (zf/auto true loc)))))) (defn text "Returns the textual contents of the given location, similar to xpaths's value-of" [loc] (.replaceAll ^String (apply str (xml-> loc zf/descendants zip/node string?)) (str "[\\s" (char 160) "]+") " ")) (defn text= "Returns a query predicate that matches a node when its textual content equals s." [s] (fn [loc] (= (text loc) s))) (defn seq-test "Returns a query predicate that matches a node when its xml content matches the query expresions given." ^{:private true} [preds] (fn [loc] (and (seq (apply xml-> loc preds)) (list loc)))) (defn xml-> "The loc is passed to the first predicate. If the predicate returns a collection, each value of the collection is passed to the next predicate. If it returns a location, the location is passed to the next predicate. If it returns true, the input location is passed to the next predicate. If it returns false or nil, the next predicate is not called. This process is repeated, passing the processed results of each predicate to the next predicate. xml-> returns the final sequence. The entire chain is evaluated lazily. There are also special predicates: keywords are converted to tag=, strings to text=, and vectors to sub-queries that return true if they match. See the footer of zip-query.clj for examples." [loc & preds] (zf/mapcat-chain loc preds #(cond (keyword? %) (tag= %) (string? %) (text= %) (vector? %) (seq-test %)))) (defn xml1-> "Returns the first item from loc based on the query predicates given. See xml->" [loc & preds] (first (apply xml-> loc preds))) ; === examples === (comment (defn parse-str [s] (zip/xml-zip (xml/parse (new org.xml.sax.InputSource (new java.io.StringReader s))))) (def atom1 (parse-str " tag:blogger.com,1999:blog-28403206 2008-02-14T08:00:58.567-08:00 n01senet 1 2008-02-13 clojure is the best lisp yet Chouser 2 2008-02-07 experimenting with vnc agriffis ")) ; simple single-function filter (assert (= (xml-> atom1 #((zip/node %) :tag)) '(:feed))) ; two-stage filter using helpful query prediates (assert (= (xml-> atom1 (tag= :title) text) '("n01senet"))) ; same filter as above, this time using keyword shortcut (assert (= (xml-> atom1 :title text) '("n01senet"))) ; multi-stage filter (assert (= (xml-> atom1 :entry :author :name text) '("Chouser" "agriffis"))) ; test xml1-> (assert (= (xml1-> atom1 :entry :author :name text) "Chouser")) ; multi-stage filter with subquery specified using a vector (assert (= (xml-> atom1 :entry [:author :name (text= "agriffis")] :id text) '("2"))) ; same filter as above, this time using a string shortcut (assert (= (xml-> atom1 :entry [:author :name "agriffis"] :id text) '("2"))) ; attribute access (assert (= (xml-> atom1 :title (attr :type)) '("text"))) ; attribute filtering (assert (= (xml-> atom1 :link [(attr= :rel "alternate")] (attr :type)) '("text/html"))) ; ancestors (assert (= (xml-> atom1 zf/descendants :id "2" zf/ancestors zip/node #(:tag %)) '(:id :entry :feed))) ; ancestors with non-auto tag= (:entry), followed by auto tag= (:id) (assert (= (xml-> atom1 zf/descendants :name "Chouser" zf/ancestors :entry :id text) '("1"))) ; left-locs and detection of returning a single loc (zip/up) (assert (= (xml-> atom1 zf/descendants :name "Chouser" zip/up zf/left-locs :id text) '("1"))) ; right-locs (assert (= (xml-> atom1 zf/descendants :id zf/right-locs :author text) '("Chouser" "agriffis"))) ) clojure-contrib_1.2.0.orig/src/test/000077500000000000000000000000001161102570000173735ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/000077500000000000000000000000001161102570000210365ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/000077500000000000000000000000001161102570000225015ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/000077500000000000000000000000001161102570000241415ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/000077500000000000000000000000001161102570000255545ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/000077500000000000000000000000001161102570000267165ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test.clj000066400000000000000000000023711161102570000303720ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test.clj ;; ;; A Clojure implementation of Datalog -- Tests ;; ;; straszheimjeffrey (gmail) ;; Created 11 Feburary 2009 (ns clojure.contrib.datalog.tests.test (:use [clojure.test :only (run-tests)]) (:gen-class)) (def test-names [:test-util :test-database :test-literals :test-rules :test-magic :test-softstrat]) (def test-namespaces (map #(symbol (str "clojure.contrib.datalog.tests." (name %))) test-names)) (defn run "Runs all defined tests" [] (println "Loading tests...") (apply require :reload-all test-namespaces) (apply run-tests test-namespaces)) (defn -main "Run all defined tests from the command line" [& args] (run) (System/exit 0)) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test_database.clj000066400000000000000000000124501161102570000322150ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-database.clj ;; ;; A Clojure implementation of Datalog -- Database ;; ;; straszheimjeffrey (gmail) ;; Created 12 Feburary 2009 (ns clojure.contrib.datalog.tests.test-database (:use clojure.test clojure.contrib.datalog.database)) (def test-db (make-database (relation :fred [:mary :sue]) (index :fred :mary) (relation :sally [:jen :becky :joan]) (index :sally :jen) (index :sally :becky))) (deftest test-make-database (is (= test-db (datalog-database {:sally (datalog-relation #{:jen :joan :becky} #{} {:becky {} :jen {}}) :fred (datalog-relation #{:sue :mary} #{} {:mary {}})})))) (deftest test-ensure-relation (is (contains? (ensure-relation test-db :bob [:sam :george] [:sam]) :bob)) (is (contains? (ensure-relation test-db :fred [:mary :sue] [:mary]) :fred)) (is (thrown? AssertionError (ensure-relation test-db :fred [:bob :joe] [])))) (deftest test-add-tuple (let [new-db (add-tuple test-db :fred {:mary 1 :sue 2})] (is (= (select new-db :fred {:mary 1}) [{:mary 1 :sue 2}]))) (is (thrown? AssertionError (add-tuple test-db :fred {:mary 1})))) (def test-db-1 (add-tuples test-db [:fred :mary 1 :sue 2] [:fred :mary 2 :sue 3] [:sally :jen 1 :becky 2 :joan 0] [:sally :jen 1 :becky 4 :joan 3] [:sally :jen 1 :becky 3 :joan 0] [:sally :jen 1 :becky 2 :joan 3] [:fred :mary 1 :sue 1] [:fred :mary 3 :sue 1])) (deftest test-add-tuples (is (= test-db-1 (datalog-database {:sally (datalog-relation #{:jen :joan :becky} #{{:jen 1, :joan 0, :becky 3} {:jen 1, :joan 0, :becky 2} {:jen 1, :joan 3, :becky 2} {:jen 1, :joan 3, :becky 4}} {:becky {3 #{{:jen 1, :joan 0, :becky 3}} 4 #{{:jen 1, :joan 3, :becky 4}} 2 #{{:jen 1, :joan 0, :becky 2} {:jen 1, :joan 3, :becky 2}}} :jen {1 #{{:jen 1, :joan 0, :becky 3} {:jen 1, :joan 0, :becky 2} {:jen 1, :joan 3, :becky 2} {:jen 1, :joan 3, :becky 4}}}}) :fred (datalog-relation #{:sue :mary} #{{:sue 2, :mary 1} {:sue 1, :mary 1} {:sue 3, :mary 2} {:sue 1, :mary 3}} {:mary {3 #{{:sue 1, :mary 3}} 2 #{{:sue 3, :mary 2}} 1 #{{:sue 2, :mary 1} {:sue 1, :mary 1}}}})})))) (deftest test-remove-tuples (let [db (reduce #(apply remove-tuple %1 (first %2) (next %2)) test-db-1 [[:fred {:mary 1 :sue 1}] [:fred {:mary 3 :sue 1}] [:sally {:jen 1 :becky 2 :joan 0}] [:sally {:jen 1 :becky 4 :joan 3}]])] (is (= db (datalog-database {:sally (datalog-relation #{:jen :joan :becky} #{{:jen 1, :joan 0, :becky 3} {:jen 1, :joan 3, :becky 2}} {:becky {3 #{{:jen 1, :joan 0, :becky 3}} 2 #{{:jen 1, :joan 3, :becky 2}}} :jen {1 #{{:jen 1, :joan 0, :becky 3} {:jen 1, :joan 3, :becky 2}}}}) :fred (datalog-relation #{:sue :mary} #{{:sue 2, :mary 1} {:sue 3, :mary 2}} {:mary {2 #{{:sue 3, :mary 2}} 1 #{{:sue 2, :mary 1}}}})}))))) (deftest test-select (is (= (set (select test-db-1 :sally {:jen 1 :becky 2})) #{{:jen 1 :joan 0 :becky 2} {:jen 1 :joan 3 :becky 2}})) (is (= (set (select test-db-1 :fred {:sue 1}))) #{{:mary 3 :sue 1} {:mary 1 :sue 1}}) (is (empty? (select test-db-1 :sally {:joan 5 :jen 1})))) (deftest test-any-match? (is (any-match? test-db-1 :fred {:mary 3})) (is (any-match? test-db-1 :sally {:jen 1 :becky 2 :joan 3})) (is (not (any-match? test-db-1 :sally {:jen 5}))) (is (not (any-match? test-db-1 :fred {:mary 1 :sue 5})))) (comment (run-tests) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test_literals.clj000066400000000000000000000131521161102570000322700ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-literals.clj ;; ;; A Clojure implementation of Datalog -- Literals tests ;; ;; straszheimjeffrey (gmail) ;; Created 25 Feburary 2009 (ns clojure.contrib.datalog.tests.test-literals (:use clojure.test) (:use clojure.contrib.datalog.literals clojure.contrib.datalog.database)) (def pl (eval (build-literal '(:fred :x ?x :y ?y :z 3)))) (def nl (eval (build-literal '(not! :fred :x ?x :y ?y :z 3)))) (def cl (eval (build-literal '(if > ?x 3)))) (def bl (eval (build-literal '(:fred)))) (def bns {:x '?x :y '?y :z 3}) (deftest test-build-literal (is (= (:predicate pl) :fred)) (is (= (:term-bindings pl) bns)) (is (= (:predicate nl) :fred)) (is (= (:term-bindings nl) bns)) (is (= (:symbol cl) '>)) (is (= (:terms cl) '(?x 3))) (is ((:fun cl) [4 3])) (is (not ((:fun cl) [2 4]))) (is (= (:predicate bl) :fred))) (deftest test-literal-predicate (is (= (literal-predicate pl) :fred)) (is (= (literal-predicate nl) :fred)) (is (nil? (literal-predicate cl))) (is (= (literal-predicate bl) :fred))) (deftest test-literal-columns (is (= (literal-columns pl) #{:x :y :z})) (is (= (literal-columns nl) #{:x :y :z})) (is (nil? (literal-columns cl))) (is (empty? (literal-columns bl)))) (deftest test-literal-vars (is (= (literal-vars pl) #{'?x '?y})) (is (= (literal-vars nl) #{'?x '?y})) (is (= (literal-vars cl) #{'?x})) (is (empty? (literal-vars bl)))) (deftest test-positive-vars (is (= (positive-vars pl) (literal-vars pl))) (is (nil? (positive-vars nl))) (is (nil? (positive-vars cl))) (is (empty? (positive-vars bl)))) (deftest test-negative-vars (is (nil? (negative-vars pl))) (is (= (negative-vars nl) (literal-vars nl))) (is (= (negative-vars cl) (literal-vars cl))) (is (empty? (negative-vars bl)))) (deftest test-negated? (is (not (negated? pl))) (is (negated? nl)) (is (not (negated? cl)))) (deftest test-vs-from-cs (is (= (get-vs-from-cs pl #{:x}) #{'?x})) (is (empty? (get-vs-from-cs pl #{:z}))) (is (= (get-vs-from-cs pl #{:x :r}) #{'?x})) (is (empty? (get-vs-from-cs pl #{})))) (deftest test-cs-from-vs (is (= (get-cs-from-vs pl #{'?x}) #{:x})) (is (= (get-cs-from-vs pl #{'?x '?r}) #{:x})) (is (empty? (get-cs-from-vs pl #{})))) (deftest test-literal-appropriate? (is (not (literal-appropriate? #{} pl))) (is (literal-appropriate? #{'?x} pl)) (is (not (literal-appropriate? #{'?x} nl))) (is (literal-appropriate? #{'?x '?y} nl)) (is (not (literal-appropriate? #{'?z} cl))) (is (literal-appropriate? #{'?x} cl))) (deftest test-adorned-literal (is (= (literal-predicate (adorned-literal pl #{:x})) {:pred :fred :bound #{:x}})) (is (= (literal-predicate (adorned-literal nl #{:x :y :q})) {:pred :fred :bound #{:x :y}})) (is (= (:term-bindings (adorned-literal nl #{:x})) {:x '?x :y '?y :z 3})) (is (= (adorned-literal cl #{}) cl))) (deftest test-get-adorned-bindings (is (= (get-adorned-bindings (literal-predicate (adorned-literal pl #{:x}))) #{:x})) (is (= (get-adorned-bindings (literal-predicate pl)) nil))) (deftest test-get-base-predicate (is (= (get-base-predicate (literal-predicate (adorned-literal pl #{:x}))) :fred)) (is (= (get-base-predicate (literal-predicate pl)) :fred))) (deftest test-magic-literal (is (= (magic-literal pl) {:predicate {:pred :fred :magic true}, :term-bindings {}, :literal-type :clojure.contrib.datalog.literals/literal})) (is (= (magic-literal (adorned-literal pl #{:x})) {:predicate {:pred :fred :magic true :bound #{:x}}, :term-bindings {:x '?x}, :literal-type :clojure.contrib.datalog.literals/literal}))) (comment (use 'clojure.contrib.stacktrace) (e) (use :reload 'clojure.contrib.datalog.literals) ) (def db1 (make-database (relation :fred [:x :y]) (index :fred :x) (relation :sally [:x]))) (def db2 (add-tuples db1 [:fred :x 1 :y :mary] [:fred :x 1 :y :becky] [:fred :x 3 :y :sally] [:fred :x 4 :y :joe] [:sally :x 1] [:sally :x 2])) (def lit1 (eval (build-literal '(:fred :x ?x :y ?y)))) (def lit2 (eval (build-literal '(not! :fred :x ?x)))) (def lit3 (eval (build-literal '(if > ?x ?y)))) (def lit4 (adorned-literal (eval (build-literal '(:joan :x ?x :y ?y))) #{:x})) (deftest test-join-literal (is (= (set (join-literal db2 lit1 [{'?x 1} {'?x 2} {'?x 3}])) #{{'?x 1, '?y :mary} {'?x 1, '?y :becky} {'?x 3, '?y :sally}})) (is (= (join-literal db2 lit2 [{'?x 1} {'?x 2} {'?x 3}]) [{'?x 2}])) (is (= (join-literal db2 lit3 [{'?x 1 '?y 2} {'?x 3 '?y 1}]) [{'?x 3 '?y 1}]))) (deftest test-project-literal (is (= ((project-literal db2 lit4 [{'?x 1 '?y 3}{'?x 4 '?y 2}]) {:pred :joan :bound #{:x}}) (datalog-relation ;; Schema #{:y :x} ;; Data #{ {:x 1, :y 3} {:x 4, :y 2} } ;; Indexes { :x { 4 #{{:x 4, :y 2}} 1 #{{:x 1, :y 3}} } })))) (comment (run-tests) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test_magic.clj000066400000000000000000000052251161102570000315330ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-magic.clj ;; ;; A Clojure implementation of Datalog -- Magic Tests ;; ;; straszheimjeffrey (gmail) ;; Created 18 Feburary 2009 (ns clojure.contrib.datalog.tests.test-magic (:use clojure.test) (:use clojure.contrib.datalog.magic clojure.contrib.datalog.rules)) (def rs (rules-set (<- (:p :x ?x :y ?y) (:e :x ?x :y ?y)) (<- (:p :x ?x :y ?y) (:e :x ?x :y ?z) (:p :x ?z :y ?y)) (<- (:e :x ?x :y ?y) (:b :x ?x :y ?y)) (<- (:e :x ?y :y ?y) (:c :x ?x :y ?y)))) (def q (adorn-query (?- :p :x 1 :y ?y))) (def ars (adorn-rules-set rs q)) (deftest test-adorn-rules-set (is (= ars (rules-set (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?y :x ?x)) (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?z :x ?x) ({:pred :p :bound #{:x}} :y ?y :x ?z)) (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) (:c :y ?y :x ?x)) (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) (:b :y ?y :x ?x)))))) (def m (magic-transform ars)) (deftest test-magic-transform (is (= m (rules-set (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) ({:pred :e :magic true :bound #{:x}} :x ?y) (:c :y ?y :x ?x)) (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) ({:pred :e :magic true :bound #{:x}} :x ?x) (:b :y ?y :x ?x)) (<- ({:pred :p :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) ({:pred :e :bound #{:x}} :y ?z :x ?x)) (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) ({:pred :e :bound #{:x}} :y ?z :x ?x) ({:pred :p :bound #{:x}} :y ?y :x ?z)) (<- ({:pred :e :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x)) (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) ({:pred :e :bound #{:x}} :y ?y :x ?x)))))) (comment (run-tests) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test_rules.clj000066400000000000000000000102111161102570000315740ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-rules.clj ;; ;; A Clojure implementation of Datalog -- Rule Tests ;; ;; straszheimjeffrey (gmail) ;; Created 12 Feburary 2009 (ns clojure.contrib.datalog.tests.test-rules (:use clojure.test clojure.contrib.datalog.rules clojure.contrib.datalog.literals clojure.contrib.datalog.database)) (def tr-1 (<- (:fred :x ?x :y ?y) (:mary :x ?x :z ?z) (:sally :z ?z :y ?y))) (def tr-2 (<- (:fred) (not! :mary :x 3))) (def tr-3 (<- (:fred :x ?x :y ?y) (if > ?x ?y) (:mary :x ?x) (:sally :y ?y))) (deftest test-rule-safety (is (thrown-with-msg? Exception #".*Head vars.*not bound.*" (<- (:fred :x ?x) (:sally :y ?y)))) (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" (<- (:fred :x ?x) (:becky :x ?x) (not! :sally :y ?y)))) (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" (<- (:fred :x ?x) (:becky :x ?x) (if > ?x ?y))))) (deftest test-sip (is (= (compute-sip #{:x} #{:mary :sally} tr-1) (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) ({:pred :mary :bound #{:x}} :z ?z :x ?x) ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) (is (= (compute-sip #{} #{:mary :sally} tr-1) (<- (:fred :y ?y :x ?x) (:mary :z ?z :x ?x) ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) (is (= (compute-sip #{} #{:mary} tr-2) (<- (:fred) (not! {:pred :mary :bound #{:x}} :x 3)))) (is (= (compute-sip #{} #{} tr-2) tr-2)) (is (= (display-rule (compute-sip #{:x} #{:mary :sally} tr-3)) (display-rule (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) ({:pred :mary :bound #{:x}} :x ?x) (:sally :y ?y) (if > ?x ?y)))))) ; Display rule is used because = does not work on ; (if > ?x ?y) because it contains a closure (def rs (rules-set (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y)) (<- (:edge :a ?x :b ?y) (:route :a ?x :b ?y) (if not= ?x ?y)))) (deftest test-rules-set (is (= (count rs) 3)) (is (contains? rs (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))))) (deftest test-predicate-map (let [pm (predicate-map rs)] (is (= (pm :path) #{(<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))})) (is (= (-> :edge pm count) 1)))) (def db1 (make-database (relation :fred [:x :y]) (index :fred :x) (relation :sally [:x]) (relation :ben [:y]))) (def db2 (add-tuples db1 [:fred :x 1 :y :mary] [:fred :x 1 :y :becky] [:fred :x 3 :y :sally] [:fred :x 4 :y :joe] [:fred :x 4 :y :bob] [:sally :x 1] [:sally :x 2] [:sally :x 3] [:sally :x 4] [:ben :y :bob])) (deftest test-apply-rule (is (= (apply-rule db2 empty-database (<- (:becky :y ?y) (:sally :x ?x) (:fred :x ?x :y ?y) (not! :ben :y ?y) (if not= ?x 3))) (datalog-database { :becky (datalog-relation ;; Schema #{:y} ;; Data #{ {:y :joe} {:y :mary} {:y :becky} } ;; Indexes { }) })))) (comment (run-tests) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test_softstrat.clj000066400000000000000000000230071161102570000325020ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-softstrat.clj ;; ;; A Clojure implementation of Datalog -- Soft Stratification Tests ;; ;; straszheimjeffrey (gmail) ;; Created 28 Feburary 2009 (ns clojure.contrib.datalog.tests.test-softstrat (:use clojure.test) (:use clojure.contrib.datalog.softstrat clojure.contrib.datalog.magic clojure.contrib.datalog.rules clojure.contrib.datalog.database) (:use [clojure.contrib.set :only (subset?)])) (def rs1 (rules-set (<- (:p :x ?x) (:b :x ?x :y ?y :z ?z) (not! :q :x ?x) (not! :q :x ?y) (not! :q :x ?z)) (<- (:q :x ?x) (:d :x ?x)))) (def q1 (?- :p :x 1)) (def ws (build-soft-strat-work-plan rs1 q1)) (deftest test-soft-stratification (let [soft (:stratification ws) q (:query ws)] (is (= q (?- {:pred :p :bound #{:x}} :x 1))) (is (= (count soft) 4)) (is (subset? (rules-set (<- ({:pred :q :bound #{:x}} :x ?x) ({:pred :q :magic true :bound #{:x}} :x ?x) (:d :x ?x)) (<- ({:pred :q :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) (:b :z ?z :y ?y :x ?x))) (nth soft 0))) (is (= (nth soft 1) (rules-set (<- ({:pred :q :magic true :bound #{:x}} :x ?y) ({:pred :p :magic true :bound #{:x}} :x ?x) (:b :z ?z :y ?y :x ?x) (not! {:pred :q :bound #{:x}} :x ?x))))) (is (= (nth soft 2) (rules-set (<- ({:pred :q :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) (:b :z ?z :y ?y :x ?x) (not! {:pred :q :bound #{:x}} :x ?x) (not! {:pred :q :bound #{:x}} :x ?y))))) (is (= (nth soft 3) (rules-set (<- ({:pred :p :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) (:b :z ?z :y ?y :x ?x) (not! {:pred :q :bound #{:x}} :x ?x) (not! {:pred :q :bound #{:x}} :x ?y) (not! {:pred :q :bound #{:x}} :x ?z))))))) (def tdb-1 (make-database (relation :b [:x :y :z]) (relation :d [:x]))) (def tdb-2 (add-tuples tdb-1 [:b :x 1 :y 2 :z 3])) (deftest test-tdb-2 (is (= (evaluate-soft-work-set ws tdb-2 {}) [{:x 1}]))) (def tdb-3 (add-tuples tdb-2 [:d :x 2] [:d :x 3])) (deftest test-tdb-3 (is (empty? (evaluate-soft-work-set ws tdb-3 {})))) ;;;;;;;;;;; (def db-base (make-database (relation :employee [:id :name :position]) (index :employee :name) (relation :boss [:employee-id :boss-id]) (index :boss :employee-id) (relation :can-do-job [:position :job]) (index :can-do-job :position) (relation :job-replacement [:job :can-be-done-by]) (relation :job-exceptions [:id :job]))) (def db (add-tuples db-base [:employee :id 1 :name "Bob" :position :boss] [:employee :id 2 :name "Mary" :position :chief-accountant] [:employee :id 3 :name "John" :position :accountant] [:employee :id 4 :name "Sameer" :position :chief-programmer] [:employee :id 5 :name "Lilian" :position :programmer] [:employee :id 6 :name "Li" :position :technician] [:employee :id 7 :name "Fred" :position :sales] [:employee :id 8 :name "Brenda" :position :sales] [:employee :id 9 :name "Miki" :position :project-management] [:employee :id 10 :name "Albert" :position :technician] [:boss :employee-id 2 :boss-id 1] [:boss :employee-id 3 :boss-id 2] [:boss :employee-id 4 :boss-id 1] [:boss :employee-id 5 :boss-id 4] [:boss :employee-id 6 :boss-id 4] [:boss :employee-id 7 :boss-id 1] [:boss :employee-id 8 :boss-id 7] [:boss :employee-id 9 :boss-id 1] [:boss :employee-id 10 :boss-id 6] [:can-do-job :position :boss :job :management] [:can-do-job :position :accountant :job :accounting] [:can-do-job :position :chief-accountant :job :accounting] [:can-do-job :position :programmer :job :programming] [:can-do-job :position :chief-programmer :job :programming] [:can-do-job :position :technician :job :server-support] [:can-do-job :position :sales :job :sales] [:can-do-job :position :project-management :job :project-management] [:job-replacement :job :pc-support :can-be-done-by :server-support] [:job-replacement :job :pc-support :can-be-done-by :programming] [:job-replacement :job :payroll :can-be-done-by :accounting] [:job-exceptions :id 4 :job :pc-support])) (def rules (rules-set (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) (:employee :id ?e-id :name ?x) (:employee :id ?b-id :name ?y)) (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) (:works-for :employee ?z :boss ?y)) (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) (:can-do-job :position ?pos :job ?y)) (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) (:employee-job* :employee ?x :job ?z)) (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) (:employee :name ?x :position ?z) (if = ?z :boss)) (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) (:employee :id ?id :name ?x) (not! :job-exceptions :id ?id :job ?y)) (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) (not! :employee-job :employee ?y :job :pc-support)))) (def ws-1 (build-soft-strat-work-plan rules (?- :works-for :employee '??name :boss ?x))) (defn evaluate-1 [name] (set (evaluate-soft-work-set ws-1 db {'??name name}))) (deftest test-ws-1 (is (= (evaluate-1 "Albert") #{{:employee "Albert", :boss "Li"} {:employee "Albert", :boss "Sameer"} {:employee "Albert", :boss "Bob"}})) (is (empty? (evaluate-1 "Bob"))) (is (= (evaluate-1 "John") #{{:employee "John", :boss "Bob"} {:employee "John", :boss "Mary"}}))) (def ws-2 (build-soft-strat-work-plan rules (?- :employee-job :employee '??name :job ?x))) (defn evaluate-2 [name] (set (evaluate-soft-work-set ws-2 db {'??name name}))) (deftest test-ws-2 (is (= (evaluate-2 "Albert") #{{:employee "Albert", :job :pc-support} {:employee "Albert", :job :server-support}})) (is (= (evaluate-2 "Sameer") #{{:employee "Sameer", :job :programming}})) (is (= (evaluate-2 "Bob") #{{:employee "Bob", :job :accounting} {:employee "Bob", :job :management} {:employee "Bob", :job :payroll} {:employee "Bob", :job :pc-support} {:employee "Bob", :job :project-management} {:employee "Bob", :job :programming} {:employee "Bob", :job :server-support} {:employee "Bob", :job :sales}}))) (def ws-3 (build-soft-strat-work-plan rules (?- :bj :name '??name :boss ?x))) (defn evaluate-3 [name] (set (evaluate-soft-work-set ws-3 db {'??name name}))) (deftest test-ws-3 (is (= (evaluate-3 "Albert") #{{:name "Albert", :boss "Sameer"}}))) (def ws-4 (build-soft-strat-work-plan rules (?- :works-for :name ?x :boss ?x))) (deftest test-ws-4 (is (= (set (evaluate-soft-work-set ws-4 db {})) #{{:employee "Miki", :boss "Bob"} {:employee "Albert", :boss "Li"} {:employee "Lilian", :boss "Sameer"} {:employee "Li", :boss "Bob"} {:employee "Lilian", :boss "Bob"} {:employee "Brenda", :boss "Fred"} {:employee "Fred", :boss "Bob"} {:employee "John", :boss "Bob"} {:employee "John", :boss "Mary"} {:employee "Albert", :boss "Sameer"} {:employee "Sameer", :boss "Bob"} {:employee "Albert", :boss "Bob"} {:employee "Brenda", :boss "Bob"} {:employee "Mary", :boss "Bob"} {:employee "Li", :boss "Sameer"}}))) (comment (run-tests) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/datalog/tests/test_util.clj000066400000000000000000000037431161102570000314330ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-util.clj ;; ;; A Clojure implementation of Datalog -- Utilities Tests ;; ;; straszheimjeffrey (gmail) ;; Created 11 Feburary 2009 (ns clojure.contrib.datalog.tests.test-util (:use clojure.test clojure.contrib.datalog.util) (:use [clojure.contrib.except :only (throwf)])) (deftest test-is-var? (is (is-var? '?x)) (is (is-var? '?)) (is (not (is-var? '??x))) (is (not (is-var? '??))) (is (not (is-var? 'x))) (is (not (is-var? "fred"))) (is (not (is-var? :q)))) (deftest test-map-values (let [map {:fred 1 :sally 2}] (is (= (map-values #(* 2 %) map) {:fred 2 :sally 4})) (is (= (map-values identity {}) {})))) (deftest test-keys-to-vals (let [map {:fred 1 :sally 2 :joey 3}] (is (= (set (keys-to-vals map [:fred :sally])) #{1 2})) (is (= (set (keys-to-vals map [:fred :sally :becky])) #{1 2})) (is (empty? (keys-to-vals map []))) (is (empty? (keys-to-vals {} [:fred]))))) (deftest test-reverse-map (let [map {:fred 1 :sally 2 :joey 3} map-1 (assoc map :mary 3)] (is (= (reverse-map map) {1 :fred 2 :sally 3 :joey})) (is (or (= (reverse-map map-1) {1 :fred 2 :sally 3 :joey}) (= (reverse-map map-1) {1 :fred 2 :sally 3 :mary}))))) (def some-maps [ { :a 1 :b 2 } { :c 3 :b 3 } { :d 4 :a 1 } { :g 4 :b 4 } { :a 2 :b 1 } { :e 1 :f 1 } ]) (def reduced (preduce + some-maps)) (def merged (apply merge-with + some-maps)) (deftest test-preduce (is (= reduced merged))) (comment (run-tests) ) ; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/mock/000077500000000000000000000000001161102570000250725ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/mock/test_adapter.clj000066400000000000000000000012571161102570000302500ustar00rootroot00000000000000(ns clojure.contrib.test-contrib.mock-test.test-adapter-test (:use clojure.contrib.mock.test-adapter [clojure.contrib.test-contrib.mock-test :only (assert-called)] clojure.test)) (deftest test-report-problem-called (def #^{:private true :dynamic true} fn1 (fn [x] "dummy code")) (def #^{:private true :dynamic true} fn2 (fn [x y] "dummy code2")) (let [under-test (fn [x] (fn1 x))] (assert-called clojure.contrib.mock.test-adapter/report-problem true (expect [fn1 (times 5)] (under-test "hi"))))) (deftest test-is-report-called (assert-called clojure.test/report true (clojure.contrib.mock.test-adapter/report-problem 'fn-name 5 6 "fake problem"))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/pprint/000077500000000000000000000000001161102570000254555ustar00rootroot00000000000000clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/pprint/test_cl_format.clj000066400000000000000000000756341161102570000311730ustar00rootroot00000000000000;;; cl_format.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Dec 2008. 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. ;; This test set tests the basic cl-format functionality (ns clojure.contrib.pprint.test-cl-format (:refer-clojure :exclude [format]) (:use [clojure.test :only (deftest are run-tests)] clojure.contrib.pprint.test-helper clojure.contrib.pprint)) (def format cl-format) ;; TODO tests for ~A, ~D, etc. ;; TODO add tests for ~F, etc.: 0.0, 9.9999 with rounding, 9.9999E99 with rounding (simple-tests d-tests (cl-format nil "~D" 0) "0" (cl-format nil "~D" 2e6) "2000000" (cl-format nil "~D" 2000000) "2000000" (cl-format nil "~:D" 2000000) "2,000,000" (cl-format nil "~D" 1/2) "1/2" (cl-format nil "~D" 'fred) "fred" ) (simple-tests base-tests (cl-format nil "~{~2r~^ ~}~%" (range 10)) "0 1 10 11 100 101 110 111 1000 1001\n" (with-out-str (dotimes [i 35] (binding [*print-base* (+ i 2)] ;print the decimal number 40 (write 40) ;in each base from 2 to 36 (if (zero? (mod i 10)) (prn) (cl-format true " "))))) "101000 1111 220 130 104 55 50 44 40 37 34 31 2c 2a 28 26 24 22 20 1j 1i 1h 1g 1f 1e 1d 1c 1b 1a 19 18 17 16 15 14 " (with-out-str (doseq [pb [2 3 8 10 16]] (binding [*print-radix* true ;print the integer 10 and *print-base* pb] ;the ratio 1/10 in bases 2, (cl-format true "~&~S ~S~%" 10 1/10)))) ;3, 8, 10, 16 "#b1010 #b1/1010 #3r101 #3r1/101 #o12 #o1/12 10. #10r1/10 #xa #x1/a ") (simple-tests cardinal-tests (cl-format nil "~R" 0) "zero" (cl-format nil "~R" 4) "four" (cl-format nil "~R" 15) "fifteen" (cl-format nil "~R" -15) "minus fifteen" (cl-format nil "~R" 25) "twenty-five" (cl-format nil "~R" 20) "twenty" (cl-format nil "~R" 200) "two hundred" (cl-format nil "~R" 203) "two hundred three" (cl-format nil "~R" 44879032) "forty-four million, eight hundred seventy-nine thousand, thirty-two" (cl-format nil "~R" -44879032) "minus forty-four million, eight hundred seventy-nine thousand, thirty-two" (cl-format nil "~R = ~:*~:D" 44000032) "forty-four million, thirty-two = 44,000,032" (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094) "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-four = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094" (cl-format nil "~R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475) "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475 = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475" (cl-format nil "~R = ~:*~:D" 2e6) "two million = 2,000,000" (cl-format nil "~R = ~:*~:D" 200000200000) "two hundred billion, two hundred thousand = 200,000,200,000") (simple-tests ordinal-tests (cl-format nil "~:R" 0) "zeroth" (cl-format nil "~:R" 4) "fourth" (cl-format nil "~:R" 15) "fifteenth" (cl-format nil "~:R" -15) "minus fifteenth" (cl-format nil "~:R" 25) "twenty-fifth" (cl-format nil "~:R" 20) "twentieth" (cl-format nil "~:R" 200) "two hundredth" (cl-format nil "~:R" 203) "two hundred third" (cl-format nil "~:R" 44879032) "forty-four million, eight hundred seventy-nine thousand, thirty-second" (cl-format nil "~:R" -44879032) "minus forty-four million, eight hundred seventy-nine thousand, thirty-second" (cl-format nil "~:R = ~:*~:D" 44000032) "forty-four million, thirty-second = 44,000,032" (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094) "four hundred forty-eight septendecillion, seven hundred ninety sexdecillion, three hundred twenty-nine quindecillion, four hundred eighty quattuordecillion, nine hundred forty-eight tredecillion, two hundred nine duodecillion, three hundred eighty-four undecillion, three hundred eighty-nine decillion, four hundred twenty-nine nonillion, three hundred eighty-four octillion, twenty-nine septillion, three hundred eighty-four sextillion, twenty-nine quintillion, eight hundred forty-two quadrillion, ninety-eight trillion, four hundred twenty billion, nine hundred eighty-nine million, eight hundred forty-two thousand, ninety-fourth = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094" (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593475) "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475th = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,475" (cl-format nil "~:R = ~:*~:D" 448790329480948209384389429384029384029842098420989842094490320942058747587584758375847593471) "448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471st = 448,790,329,480,948,209,384,389,429,384,029,384,029,842,098,420,989,842,094,490,320,942,058,747,587,584,758,375,847,593,471" (cl-format nil "~:R = ~:*~:D" 2e6) "two millionth = 2,000,000") (simple-tests ordinal1-tests (cl-format nil "~:R" 1) "first" (cl-format nil "~:R" 11) "eleventh" (cl-format nil "~:R" 21) "twenty-first" (cl-format nil "~:R" 20) "twentieth" (cl-format nil "~:R" 220) "two hundred twentieth" (cl-format nil "~:R" 200) "two hundredth" (cl-format nil "~:R" 999) "nine hundred ninety-ninth" ) (simple-tests roman-tests (cl-format nil "~@R" 3) "III" (cl-format nil "~@R" 4) "IV" (cl-format nil "~@R" 9) "IX" (cl-format nil "~@R" 29) "XXIX" (cl-format nil "~@R" 429) "CDXXIX" (cl-format nil "~@:R" 429) "CCCCXXVIIII" (cl-format nil "~@:R" 3429) "MMMCCCCXXVIIII" (cl-format nil "~@R" 3429) "MMMCDXXIX" (cl-format nil "~@R" 3479) "MMMCDLXXIX" (cl-format nil "~@R" 3409) "MMMCDIX" (cl-format nil "~@R" 300) "CCC" (cl-format nil "~@R ~D" 300 20) "CCC 20" (cl-format nil "~@R" 5000) "5,000" (cl-format nil "~@R ~D" 5000 20) "5,000 20" (cl-format nil "~@R" "the quick") "the quick") (simple-tests c-tests (cl-format nil "~{~c~^, ~}~%" "hello") "h, e, l, l, o\n" (cl-format nil "~{~:c~^, ~}~%" "hello") "h, e, l, l, o\n" (cl-format nil "~@C~%" \m) "\\m\n" (cl-format nil "~@C~%" (char 222)) "\\Þ\n" (cl-format nil "~@C~%" (char 8)) "\\backspace\n" (cl-format nil "~@C~%" (char 3)) "\\\n") (simple-tests e-tests (cl-format nil "*~E*" 0.0) "*0.0E+0*" (cl-format nil "*~6E*" 0.0) "*0.0E+0*" (cl-format nil "*~6,0E*" 0.0) "* 0.E+0*" (cl-format nil "*~7,2E*" 0.0) "*0.00E+0*" (cl-format nil "*~5E*" 0.0) "*0.E+0*" (cl-format nil "*~10,2,2,,'?E*" 2.8E120) "*??????????*" (cl-format nil "*~10,2E*" 9.99999) "* 1.00E+1*" (cl-format nil "*~10,2E*" 9.99999E99) "* 1.00E+100*" (cl-format nil "*~10,2,2E*" 9.99999E99) "* 1.00E+100*" (cl-format nil "*~10,2,2,,'?E*" 9.99999E99) "*??????????*" ) (simple-tests $-tests (cl-format nil "~$" 22.3) "22.30" (cl-format nil "~$" 22.375) "22.38" (cl-format nil "~3,5$" 22.375) "00022.375" (cl-format nil "~3,5,8$" 22.375) "00022.375" (cl-format nil "~3,5,10$" 22.375) " 00022.375" (cl-format nil "~3,5,14@$" 22.375) " +00022.375" (cl-format nil "~3,5,14@$" 22.375) " +00022.375" (cl-format nil "~3,5,14@:$" 22.375) "+ 00022.375" (cl-format nil "~3,,14@:$" 0.375) "+ 0.375" (cl-format nil "~1,1$" -12.0) "-12.0" (cl-format nil "~1,1$" 12.0) "12.0" (cl-format nil "~1,1$" 12.0) "12.0" (cl-format nil "~1,1@$" 12.0) "+12.0" (cl-format nil "~1,1,8,' @:$" 12.0) "+ 12.0" (cl-format nil "~1,1,8,' @$" 12.0) " +12.0" (cl-format nil "~1,1,8,' :$" 12.0) " 12.0" (cl-format nil "~1,1,8,' $" 12.0) " 12.0" (cl-format nil "~1,1,8,' @:$" -12.0) "- 12.0" (cl-format nil "~1,1,8,' @$" -12.0) " -12.0" (cl-format nil "~1,1,8,' :$" -12.0) "- 12.0" (cl-format nil "~1,1,8,' $" -12.0) " -12.0" (cl-format nil "~1,1$" 0.001) "0.0" (cl-format nil "~2,1$" 0.001) "0.00" (cl-format nil "~1,1,6$" 0.001) " 0.0" (cl-format nil "~1,1,6$" 0.0015) " 0.0" (cl-format nil "~2,1,6$" 0.005) " 0.01" (cl-format nil "~2,1,6$" 0.01) " 0.01" (cl-format nil "~$" 0.099) "0.10" (cl-format nil "~1$" 0.099) "0.1" (cl-format nil "~1$" 0.1) "0.1" (cl-format nil "~1$" 0.99) "1.0" (cl-format nil "~1$" -0.99) "-1.0") (simple-tests f-tests (cl-format nil "~,1f" -12.0) "-12.0" (cl-format nil "~,0f" 9.4) "9." (cl-format nil "~,0f" 9.5) "10." (cl-format nil "~,0f" -0.99) "-1." (cl-format nil "~,1f" -0.99) "-1.0" (cl-format nil "~,2f" -0.99) "-0.99" (cl-format nil "~,3f" -0.99) "-0.990" (cl-format nil "~,0f" 0.99) "1." (cl-format nil "~,1f" 0.99) "1.0" (cl-format nil "~,2f" 0.99) "0.99" (cl-format nil "~,3f" 0.99) "0.990" (cl-format nil "~f" -1) "-1.0" (cl-format nil "~2f" -1) "-1." (cl-format nil "~3f" -1) "-1." (cl-format nil "~4f" -1) "-1.0" (cl-format nil "~8f" -1) " -1.0" (cl-format nil "~1,1f" 0.1) ".1") (simple-tests ampersand-tests (cl-format nil "The quick brown ~a jumped over ~d lazy dogs" 'elephant 5) "The quick brown elephant jumped over 5 lazy dogs" (cl-format nil "The quick brown ~&~a jumped over ~d lazy dogs" 'elephant 5) "The quick brown \nelephant jumped over 5 lazy dogs" (cl-format nil "The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) "The quick brown \nelephant jumped\n over 5 lazy dogs" (cl-format nil "~&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) "The quick brown \nelephant jumped\n over 5 lazy dogs" (cl-format nil "~3&The quick brown ~&~a jumped\n~& over ~d lazy dogs" 'elephant 5) "\n\nThe quick brown \nelephant jumped\n over 5 lazy dogs" (cl-format nil "~@{~&The quick brown ~a jumped over ~d lazy dogs~}" 'elephant 5 'fox 10) "The quick brown elephant jumped over 5 lazy dogs\nThe quick brown fox jumped over 10 lazy dogs" (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 0) "I don't have one\n" (cl-format nil "I ~[don't ~:;d~&o ~]have one~%" 1) "I d\no have one\n") (simple-tests t-tests (cl-format nil "~@{~&~A~8,4T~:*~A~}" 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" (cl-format nil "~@{~&~A~,4T~:*~A~}" 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" (cl-format nil "~@{~&~A~2,6@T~:*~A~}" 'a 'aa 'aaa 'aaaa 'aaaaa 'aaaaaa 'aaaaaaa 'aaaaaaaa 'aaaaaaaaa 'aaaaaaaaaa) "a a\naa aa\naaa aaa\naaaa aaaa\naaaaa aaaaa\naaaaaa aaaaaa\naaaaaaa aaaaaaa\naaaaaaaa aaaaaaaa\naaaaaaaaa aaaaaaaaa\naaaaaaaaaa aaaaaaaaaa" ) (simple-tests paren-tests (cl-format nil "~(PLEASE SPEAK QUIETLY IN HERE~)") "please speak quietly in here" (cl-format nil "~@(PLEASE SPEAK QUIETLY IN HERE~)") "Please speak quietly in here" (cl-format nil "~@:(but this Is imporTant~)") "BUT THIS IS IMPORTANT" (cl-format nil "~:(the greAt gatsby~)!") "The Great Gatsby!" ;; Test cases from CLtL 18.3 - string-upcase, et al. (cl-format nil "~@:(~A~)" "Dr. Livingstone, I presume?") "DR. LIVINGSTONE, I PRESUME?" (cl-format nil "~(~A~)" "Dr. Livingstone, I presume?") "dr. livingstone, i presume?" (cl-format nil "~:(~A~)" " hello ") " Hello " (cl-format nil "~:(~A~)" "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") "Occluded Casements Forestall Inadvertent Defenestration" (cl-format nil "~:(~A~)" 'kludgy-hash-search) "Kludgy-Hash-Search" (cl-format nil "~:(~A~)" "DON'T!") "Don'T!" ;not "Don't!" (cl-format nil "~:(~A~)" "pipe 13a, foo16c") "Pipe 13a, Foo16c" ) (simple-tests square-bracket-tests ;; Tests for format without modifiers (cl-format nil "I ~[don't ~]have one~%" 0) "I don't have one\n" (cl-format nil "I ~[don't ~]have one~%" 1) "I have one\n" (cl-format nil "I ~[don't ~;do ~]have one~%" 0) "I don't have one\n" (cl-format nil "I ~[don't ~;do ~]have one~%" 1) "I do have one\n" (cl-format nil "I ~[don't ~;do ~]have one~%" 2) "I have one\n" (cl-format nil "I ~[don't ~:;do ~]have one~%" 0) "I don't have one\n" (cl-format nil "I ~[don't ~:;do ~]have one~%" 1) "I do have one\n" (cl-format nil "I ~[don't ~:;do ~]have one~%" 2) "I do have one\n" (cl-format nil "I ~[don't ~:;do ~]have one~%" 700) "I do have one\n" ;; Tests for format with a colon (cl-format nil "I ~:[don't ~;do ~]have one~%" true) "I do have one\n" (cl-format nil "I ~:[don't ~;do ~]have one~%" 700) "I do have one\n" (cl-format nil "I ~:[don't ~;do ~]have one~%" '(a b)) "I do have one\n" (cl-format nil "I ~:[don't ~;do ~]have one~%" nil) "I don't have one\n" (cl-format nil "I ~:[don't ~;do ~]have one~%" false) "I don't have one\n" ;; Tests for format with an at sign (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 nil) "We had 15 wins.\n" (cl-format nil "We had ~D wins~@[ (out of ~D tries)~].~%" 15 17) "We had 15 wins (out of 17 tries).\n" ;; Format tests with directives (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 0, 7) "Max 15: Blue team 7.\n" (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, 1, 12) "Max 15: Red team 12.\n" (cl-format nil "Max ~D: ~[Blue team ~D~;Red team ~D~:;No team ~A~].~%" 15, -1, "(system failure)") "Max 15: No team (system failure).\n" ;; Nested format tests (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" 15, 0, 7, true) "Max 15: Blue team 7 (complete success).\n" (cl-format nil "Max ~D: ~[Blue team ~D~:[~; (complete success)~]~;Red team ~D~:;No team ~].~%" 15, 0, 7, false) "Max 15: Blue team 7.\n" ;; Test the selector as part of the argument (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~].") "The answer is nothing." (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 4) "The answer is 4." (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 7 22) "The answer is 7 out of 22." (cl-format nil "The answer is ~#[nothing~;~D~;~D out of ~D~:;something crazy~]." 1 2 3 4) "The answer is something crazy." ) (simple-tests curly-brace-plain-tests ;; Iteration from sublist (cl-format nil "Coordinates are~{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ]) "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" (cl-format nil "Coordinates are~2{ [~D,~D]~}~%" [ 0, 1, 1, 0, 3, 5, 2, 1 ]) "Coordinates are [0,1] [1,0]\n" (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) "Coordinates are\n" (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) "Coordinates are none\n" (cl-format nil "Coordinates are~{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3 1]) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~{~:}~%" "" []) "Coordinates are\n" (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3 1]) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) "Coordinates are none\n" ) (simple-tests curly-brace-colon-tests ;; Iteration from list of sublists (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" (cl-format nil "Coordinates are~:{ [~D,~D]~}~%" [ [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ]) "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" (cl-format nil "Coordinates are~2:{ [~D,~D]~}~%" [ [0, 1], [1, 0], [3, 5], [2, 1] ]) "Coordinates are [0,1] [1,0]\n" (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%" [ ]) "Coordinates are\n" (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [ ]) "Coordinates are none\n" (cl-format nil "Coordinates are~:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [[2 3] [1]]) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~:{~:}~%" "" []) "Coordinates are\n" (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [[2 3] [1]]) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [ ]) "Coordinates are none\n" ) (simple-tests curly-brace-at-tests ;; Iteration from main list (cl-format nil "Coordinates are~@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" (cl-format nil "Coordinates are~2@{ [~D,~D]~}~%" 0, 1, 1, 0, 3, 5, 2, 1) "Coordinates are [0,1] [1,0]\n" (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") "Coordinates are\n" (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") "Coordinates are none\n" (cl-format nil "Coordinates are~@{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" 2 3 1) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~@{~:}~%" "") "Coordinates are\n" (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" 2 3 1) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~@{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") "Coordinates are none\n" ) (simple-tests curly-brace-colon-at-tests ;; Iteration from sublists on the main arg list (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1] ) "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" (cl-format nil "Coordinates are~@:{ [~D,~D]~}~%" [0, 1, 0], [1, 0, 12], [3, 5], [2, 1] ) "Coordinates are [0,1] [1,0] [3,5] [2,1]\n" (cl-format nil "Coordinates are~2@:{ [~D,~D]~}~%" [0, 1], [1, 0], [3, 5], [2, 1]) "Coordinates are [0,1] [1,0]\n" (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~}~%") "Coordinates are\n" (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%") "Coordinates are none\n" (cl-format nil "Coordinates are~@:{ ~#[none~;<~D>~:;[~D,~D]~]~:}~%" [2 3] [1]) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~@:{~:}~%" "") "Coordinates are\n" (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]" [2 3] [1]) "Coordinates are [2,3] <1>\n" (cl-format nil "Coordinates are~@:{~:}~%" " ~#[none~;<~D>~:;[~D,~D]~]") "Coordinates are none\n" ) ;; TODO tests for ~^ in ~[ constructs and other brackets ;; TODO test ~:^ generates an error when used improperly ;; TODO test ~:^ works in ~@:{...~} (let [aseq '(a quick brown fox jumped over the lazy dog) lseq (mapcat identity (for [x aseq] [x (.length (name x))]))] (simple-tests up-tests (cl-format nil "~{~a~^, ~}" aseq) "a, quick, brown, fox, jumped, over, the, lazy, dog" (cl-format nil "~{~a~0^, ~}" aseq) "a" (cl-format nil "~{~a~#,3^, ~}" aseq) "a, quick, brown, fox, jumped, over" (cl-format nil "~{~a~v,3^, ~}" lseq) "a, quick, brown, fox" (cl-format nil "~{~a~3,v,4^, ~}" lseq) "a, quick, brown, fox" )) (simple-tests angle-bracket-tests (cl-format nil "~") "foobarbaz" (cl-format nil "~20") "foo bar baz" (cl-format nil "~,,2") "foo bar baz" (cl-format nil "~20<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" (cl-format nil "~20:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz" (cl-format nil "~20@<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz " (cl-format nil "~20@:<~A~;~A~;~A~>" "foo" "bar" "baz") " foo bar baz " (cl-format nil "~10,,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" (cl-format nil "~10,10,2<~A~;~A~;~A~>" "foo" "bar" "baz") "foo bar baz" (cl-format nil "~10,10<~A~;~A~;~A~>" "foo" "bar" "baz") "foo barbaz" (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar" "baz") "foo bar baz" (cl-format nil "~20<~A~;~^~A~;~^~A~>" "foo" "bar") "foo bar" (cl-format nil "~20@<~A~;~^~A~;~^~A~>" "foo") "foo " (cl-format nil "~20:<~A~;~^~A~;~^~A~>" "foo") " foo" ) (simple-tests angle-bracket-max-column-tests (cl-format nil "~%;; ~{~<~%;; ~1,50:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance" "\\s"))) "\n;; This function computes the circular\n;; thermodynamic coefficient of the thrombulator\n;; angle for use in determining the reaction\n;; distance.\n" (cl-format true "~%;; ~{~<~%;; ~:; ~A~>~}.~%" (into [] (.split "This function computes the circular thermodynamic coefficient of the thrombulator angle for use in determining the reaction distance." "\\s")))) (defn list-to-table [aseq column-width] (let [stream (get-pretty-writer (java.io.StringWriter.))] (binding [*out* stream] (doseq [row aseq] (doseq [col row] (cl-format true "~4D~7,vT" col column-width)) (prn))) (.flush stream) (.toString (:base @@(:base @@stream))))) (simple-tests column-writer-test (list-to-table (map #(vector % (* % %) (* % % %)) (range 1 21)) 8) " 1 1 1 \n 2 4 8 \n 3 9 27 \n 4 16 64 \n 5 25 125 \n 6 36 216 \n 7 49 343 \n 8 64 512 \n 9 81 729 \n 10 100 1000 \n 11 121 1331 \n 12 144 1728 \n 13 169 2197 \n 14 196 2744 \n 15 225 3375 \n 16 256 4096 \n 17 289 4913 \n 18 324 5832 \n 19 361 6859 \n 20 400 8000 \n") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The following tests are the various examples from the format ;; documentation in Common Lisp, the Language, 2nd edition, Chapter 22.3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn expt [base pow] (reduce * (repeat pow base))) (let [x 5, y "elephant", n 3] (simple-tests cltl-intro-tests (format nil "foo") "foo" (format nil "The answer is ~D." x) "The answer is 5." (format nil "The answer is ~3D." x) "The answer is 5." (format nil "The answer is ~3,'0D." x) "The answer is 005." (format nil "The answer is ~:D." (expt 47 x)) "The answer is 229,345,007." (format nil "Look at the ~A!" y) "Look at the elephant!" (format nil "Type ~:C to ~A." (char 4) "delete all your files") "Type Control-D to delete all your files." (format nil "~D item~:P found." n) "3 items found." (format nil "~R dog~:[s are~; is~] here." n (= n 1)) "three dogs are here." (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) "three dogs are here." (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) "Here are three puppies.")) (simple-tests cltl-B-tests ;; CLtL didn't have the colons here, but the spec requires them (format nil "~,,' ,4:B" 0xFACE) "1111 1010 1100 1110" (format nil "~,,' ,4:B" 0x1CE) "1 1100 1110" (format nil "~19,,' ,4:B" 0xFACE) "1111 1010 1100 1110" ;; This one was a nice idea, but nothing in the spec supports it working this way ;; (and SBCL doesn't work this way either) ;(format nil "~19,,' ,4:B" 0x1CE) "0000 0001 1100 1110") ) (simple-tests cltl-P-tests (format nil "~D tr~:@P/~D win~:P" 7 1) "7 tries/1 win" (format nil "~D tr~:@P/~D win~:P" 1 0) "1 try/0 wins" (format nil "~D tr~:@P/~D win~:P" 1 3) "1 try/3 wins") (defn foo [x] (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x)) (simple-tests cltl-F-tests (foo 3.14159) " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" (foo 100.0) "100.00|******|100.00| 100.0|100.00|100.0" (foo 1234.0) "1234.00|******|??????|1234.0|1234.00|1234.0" (foo 0.006) " 0.01| 0.06| 0.01| 0.006|0.01|0.006") (defn foo-e [x] (format nil "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" x x x x)) ;; Clojure doesn't support float/double differences in representation (simple-tests cltl-E-tests (foo-e 0.0314159) " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" ; Added this one (foo-e 3.14159) " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" (foo-e -3.14159) " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" (foo-e 1100.0) " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" ; In Clojure, this is identical to the above ; (foo-e 1100.0L0) " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3" (foo-e 1.1E13) "*********| 11.00$+12|+.001E+16| 1.10E+13" (foo-e 1.1E120) "*********|??????????|%%%%%%%%%|1.10E+120" ; Clojure doesn't support real numbers this large ; (foo-e 1.1L1200) "*********|??????????|%%%%%%%%%|1.10L+1200" ) (simple-tests cltl-E-scale-tests (map (fn [k] (format nil "Scale factor ~2D~:*: |~13,6,2,VE|" (- k 5) 3.14159)) ;Prints 13 lines (range 13)) '("Scale factor -5: | 0.000003E+06|" "Scale factor -4: | 0.000031E+05|" "Scale factor -3: | 0.000314E+04|" "Scale factor -2: | 0.003142E+03|" "Scale factor -1: | 0.031416E+02|" "Scale factor 0: | 0.314159E+01|" "Scale factor 1: | 3.141590E+00|" "Scale factor 2: | 31.41590E-01|" "Scale factor 3: | 314.1590E-02|" "Scale factor 4: | 3141.590E-03|" "Scale factor 5: | 31415.90E-04|" "Scale factor 6: | 314159.0E-05|" "Scale factor 7: | 3141590.E-06|")) (defn foo-g [x] (format nil "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" x x x x)) ;; Clojure doesn't support float/double differences in representation (simple-tests cltl-G-tests (foo-g 0.0314159) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" (foo-g 0.314159) " 0.31 |0.314 |0.314 | 0.31 " (foo-g 3.14159) " 3.1 | 3.14 | 3.14 | 3.1 " (foo-g 31.4159) " 31. | 31.4 | 31.4 | 31. " (foo-g 314.159) " 3.14E+2| 314. | 314. | 3.14E+2" (foo-g 3141.59) " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" ; In Clojure, this is identical to the above ; (foo-g 3141.59L0) " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3" (foo-g 3.14E12) "*********|314.0$+10|0.314E+13| 3.14E+12" (foo-g 3.14E120) "*********|?????????|%%%%%%%%%|3.14E+120" ; Clojure doesn't support real numbers this large ; (foo-g 3.14L1200) "*********|?????????|%%%%%%%%%|3.14L+1200" ) (defn type-clash-error [fun nargs argnum right-type wrong-type] (format nil ;; CLtL has this format string slightly wrong "~&Function ~S requires its ~:[~:R ~;~*~]~ argument to be of type ~S,~%but it was called ~ with an argument of type ~S.~%" fun (= nargs 1) argnum right-type wrong-type)) (simple-tests cltl-Newline-tests (type-clash-error 'aref nil 2 'integer 'vector) "Function aref requires its second argument to be of type integer, but it was called with an argument of type vector.\n" (type-clash-error 'car 1 1 'list 'short-float) "Function car requires its argument to be of type list, but it was called with an argument of type short-float.\n") (simple-tests cltl-?-tests (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) " 7" (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) " 7" (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) " 7" (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) " 14") (defn f [n] (format nil "~@(~R~) error~:P detected." n)) (simple-tests cltl-paren-tests (format nil "~@R ~(~@R~)" 14 14) "XIV xiv" (f 0) "Zero errors detected." (f 1) "One error detected." (f 23) "Twenty-three errors detected.") (let [*print-level* nil *print-length* 5] (simple-tests cltl-bracket-tests (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) " print length = 5")) (let [foo "Items:~#[ none~; ~S~; ~S and ~S~ ~:;~@{~#[~; and~] ~ ~S~^,~}~]."] (simple-tests cltl-bracket1-tests (format nil foo) "Items: none." (format nil foo 'foo) "Items: foo." (format nil foo 'foo 'bar) "Items: foo and bar." (format nil foo 'foo 'bar 'baz) "Items: foo, bar, and baz." (format nil foo 'foo 'bar 'baz 'quux) "Items: foo, bar, baz, and quux.")) (simple-tests cltl-curly-bracket-tests (format nil "The winners are:~{ ~S~}." '(fred harry jill)) "The winners are: fred harry jill." (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) "Pairs: ." (format nil "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) "Pairs: ." (format nil "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3) "Pairs: ." (format nil "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) "Pairs: .") (simple-tests cltl-angle-bracket-tests (format nil "~10") "foo bar" (format nil "~10:") " foo bar" (format nil "~10:@") " foo bar " (format nil "~10") " foobar" (format nil "~10:") " foobar" (format nil "~10@") "foobar " (format nil "~10:@") " foobar ") (let [donestr "Done.~^ ~D warning~:P.~^ ~D error~:P." tellstr "~@{~@(~@[~R~^ ~]~A~)~}."] ;; The CLtL example is a little wrong here (simple-tests cltl-up-tests (format nil donestr) "Done." (format nil donestr 3) "Done. 3 warnings." (format nil donestr 1 5) "Done. 1 warning. 5 errors." (format nil tellstr 23) "Twenty-three." (format nil tellstr nil "losers") "Losers." (format nil tellstr 23 "losers") "Twenty-three losers." (format nil "~15<~S~;~^~S~;~^~S~>" 'foo) " foo" (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) "foo bar" (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) "foo bar baz")) (simple-tests cltl-up-x3j13-tests (format nil "~:{/~S~^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) "/hot .../hamburger/ice .../french ..." (format nil "~:{/~S~:^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) "/hot .../hamburger .../ice .../french" (format nil "~:{/~S~#:^ ...~}" ;; This is wrong in CLtL '((hot dog) (hamburger) (ice cream) (french fries))) "/hot .../hamburger") clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/pprint/test_helper.clj000066400000000000000000000014711161102570000304700ustar00rootroot00000000000000;;; helper.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, April 2009. 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. ;; This is just a macro to make my tests a little cleaner (ns clojure.contrib.pprint.test-helper (:use [clojure.test :only (deftest are run-tests)])) (defmacro simple-tests [name & test-pairs] `(deftest ~name (are [x y] (= x y) ~@test-pairs))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/pprint/test_pretty.clj000066400000000000000000000105711161102570000305410ustar00rootroot00000000000000;;; pretty.clj -- part of the pretty printer for Clojure ;; by Tom Faulhaber ;; April 3, 2009 ; Copyright (c) Tom Faulhaber, Feb 2009. 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.contrib.pprint.test-pretty (:use [clojure.test :only (deftest are run-tests)] clojure.contrib.pprint.test-helper clojure.contrib.pprint)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Unit tests for the pretty printer ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (simple-tests xp-fill-test (binding [*print-pprint-dispatch* *simple-dispatch* *print-right-margin* 38 *print-miser-width* nil] (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" '((x 4) (*print-length* nil) (z 2) (list nil)))) "(let ((x 4) (*print-length* nil)\n (z 2) (list nil))\n ...)\n" (binding [*print-pprint-dispatch* *simple-dispatch* *print-right-margin* 22] (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%" '((x 4) (*print-length* nil) (z 2) (list nil)))) "(let ((x 4)\n (*print-length*\n nil)\n (z 2)\n (list nil))\n ...)\n") (simple-tests xp-miser-test (binding [*print-pprint-dispatch* *simple-dispatch* *print-right-margin* 10, *print-miser-width* 9] (cl-format nil "~:" '(first second third))) "(LIST\n first\n second\n third)" (binding [*print-pprint-dispatch* *simple-dispatch* *print-right-margin* 10, *print-miser-width* 8] (cl-format nil "~:" '(first second third))) "(LIST first second third)") (simple-tests mandatory-fill-test (cl-format nil "
~%~~%
~%" [ "hello" "gooodbye" ]) "
Usage: *hello*
       *gooodbye*
") (simple-tests prefix-suffix-test (binding [*print-pprint-dispatch* *simple-dispatch* *print-right-margin* 10, *print-miser-width* 10] (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third))) "{LIST\n first\n second\n third}") (simple-tests pprint-test (binding [*print-pprint-dispatch* *simple-dispatch*] (write '(defn foo [x y] (let [result (* x y)] (if (> result 400) (cl-format true "That number is too big") (cl-format true "The result of ~d x ~d is ~d" x y result)))) :stream nil)) "(defn foo [x y] (let [result (* x y)] (if (> result 400) (cl-format true \"That number is too big\") (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" (with-pprint-dispatch *code-dispatch* (write '(defn foo [x y] (let [result (* x y)] (if (> result 400) (cl-format true "That number is too big") (cl-format true "The result of ~d x ~d is ~d" x y result)))) :stream nil)) "(defn foo [x y] (let [result (* x y)] (if (> result 400) (cl-format true \"That number is too big\") (cl-format true \"The result of ~d x ~d is ~d\" x y result))))" (binding [*print-pprint-dispatch* *simple-dispatch* *print-right-margin* 15] (write '(fn (cons (car x) (cdr y))) :stream nil)) "(fn\n (cons\n (car x)\n (cdr y)))" (with-pprint-dispatch *code-dispatch* (binding [*print-right-margin* 52] (write '(add-to-buffer this (make-buffer-blob (str (char c)) nil)) :stream nil))) "(add-to-buffer\n this\n (make-buffer-blob (str (char c)) nil))" ) (simple-tests pprint-reader-macro-test (with-pprint-dispatch *code-dispatch* (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])") :stream nil)) "(map #(first %) [[1 2 3] [4 5 6] [7]])" (with-pprint-dispatch *code-dispatch* (write (read-string "@@(ref (ref 1))") :stream nil)) "@@(ref (ref 1))" (with-pprint-dispatch *code-dispatch* (write (read-string "'foo") :stream nil)) "'foo" ) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_complex_numbers.clj000066400000000000000000000353541161102570000311060ustar00rootroot00000000000000;; Test routines for complex-numbers.clj ;; by Konrad Hinsen ;; last updated April 2, 2009 ;; Copyright (c) Konrad Hinsen, 2008. 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.contrib.test-complex-numbers (:refer-clojure :exclude [+ - * / = < > <= >=]) (:use [clojure.test :only (deftest is are run-tests)] [clojure.contrib.generic.arithmetic :only (+ - * /)] [clojure.contrib.generic.comparison :only (= < > <= >=)] [clojure.contrib.generic.math-functions :only (abs approx= conjugate exp sqr sqrt)] [clojure.contrib.complex-numbers :only (complex imaginary real imag)])) (deftest complex-addition (is (= (+ (complex 1 2) (complex 1 2)) (complex 2 4))) (is (= (+ (complex 1 2) (complex -3 -7)) (complex -2 -5))) (is (= (+ (complex -3 -7) (complex 1 2)) (complex -2 -5))) (is (= (+ (complex 1 2) 3) (complex 4 2))) (is (= (+ 3 (complex 1 2)) (complex 4 2))) (is (= (+ (complex 1 2) -1) (imaginary 2))) (is (= (+ -1 (complex 1 2)) (imaginary 2))) (is (= (+ (complex 1 2) (imaginary -2)) 1)) (is (= (+ (imaginary -2) (complex 1 2)) 1)) (is (= (+ (complex 1 2) (imaginary 5)) (complex 1 7))) (is (= (+ (imaginary 5) (complex 1 2)) (complex 1 7))) (is (= (+ (complex -3 -7) (complex 1 2)) (complex -2 -5))) (is (= (+ (complex 1 2) (complex -3 -7)) (complex -2 -5))) (is (= (+ (complex -3 -7) (complex -3 -7)) (complex -6 -14))) (is (= (+ (complex -3 -7) 3) (imaginary -7))) (is (= (+ 3 (complex -3 -7)) (imaginary -7))) (is (= (+ (complex -3 -7) -1) (complex -4 -7))) (is (= (+ -1 (complex -3 -7)) (complex -4 -7))) (is (= (+ (complex -3 -7) (imaginary -2)) (complex -3 -9))) (is (= (+ (imaginary -2) (complex -3 -7)) (complex -3 -9))) (is (= (+ (complex -3 -7) (imaginary 5)) (complex -3 -2))) (is (= (+ (imaginary 5) (complex -3 -7)) (complex -3 -2))) (is (= (+ 3 (complex 1 2)) (complex 4 2))) (is (= (+ (complex 1 2) 3) (complex 4 2))) (is (= (+ 3 (complex -3 -7)) (imaginary -7))) (is (= (+ (complex -3 -7) 3) (imaginary -7))) (is (= (+ 3 (imaginary -2)) (complex 3 -2))) (is (= (+ (imaginary -2) 3) (complex 3 -2))) (is (= (+ 3 (imaginary 5)) (complex 3 5))) (is (= (+ (imaginary 5) 3) (complex 3 5))) (is (= (+ -1 (complex 1 2)) (imaginary 2))) (is (= (+ (complex 1 2) -1) (imaginary 2))) (is (= (+ -1 (complex -3 -7)) (complex -4 -7))) (is (= (+ (complex -3 -7) -1) (complex -4 -7))) (is (= (+ -1 (imaginary -2)) (complex -1 -2))) (is (= (+ (imaginary -2) -1) (complex -1 -2))) (is (= (+ -1 (imaginary 5)) (complex -1 5))) (is (= (+ (imaginary 5) -1) (complex -1 5))) (is (= (+ (imaginary -2) (complex 1 2)) 1)) (is (= (+ (complex 1 2) (imaginary -2)) 1)) (is (= (+ (imaginary -2) (complex -3 -7)) (complex -3 -9))) (is (= (+ (complex -3 -7) (imaginary -2)) (complex -3 -9))) (is (= (+ (imaginary -2) 3) (complex 3 -2))) (is (= (+ 3 (imaginary -2)) (complex 3 -2))) (is (= (+ (imaginary -2) -1) (complex -1 -2))) (is (= (+ -1 (imaginary -2)) (complex -1 -2))) (is (= (+ (imaginary -2) (imaginary -2)) (imaginary -4))) (is (= (+ (imaginary -2) (imaginary 5)) (imaginary 3))) (is (= (+ (imaginary 5) (imaginary -2)) (imaginary 3))) (is (= (+ (imaginary 5) (complex 1 2)) (complex 1 7))) (is (= (+ (complex 1 2) (imaginary 5)) (complex 1 7))) (is (= (+ (imaginary 5) (complex -3 -7)) (complex -3 -2))) (is (= (+ (complex -3 -7) (imaginary 5)) (complex -3 -2))) (is (= (+ (imaginary 5) 3) (complex 3 5))) (is (= (+ 3 (imaginary 5)) (complex 3 5))) (is (= (+ (imaginary 5) -1) (complex -1 5))) (is (= (+ -1 (imaginary 5)) (complex -1 5))) (is (= (+ (imaginary 5) (imaginary -2)) (imaginary 3))) (is (= (+ (imaginary -2) (imaginary 5)) (imaginary 3))) (is (= (+ (imaginary 5) (imaginary 5)) (imaginary 10)))) (deftest complex-subtraction (is (= (- (complex 1 2) (complex 1 2)) 0)) (is (= (- (complex 1 2) (complex -3 -7)) (complex 4 9))) (is (= (- (complex -3 -7) (complex 1 2)) (complex -4 -9))) (is (= (- (complex 1 2) 3) (complex -2 2))) (is (= (- 3 (complex 1 2)) (complex 2 -2))) (is (= (- (complex 1 2) -1) (complex 2 2))) (is (= (- -1 (complex 1 2)) (complex -2 -2))) (is (= (- (complex 1 2) (imaginary -2)) (complex 1 4))) (is (= (- (imaginary -2) (complex 1 2)) (complex -1 -4))) (is (= (- (complex 1 2) (imaginary 5)) (complex 1 -3))) (is (= (- (imaginary 5) (complex 1 2)) (complex -1 3))) (is (= (- (complex -3 -7) (complex 1 2)) (complex -4 -9))) (is (= (- (complex 1 2) (complex -3 -7)) (complex 4 9))) (is (= (- (complex -3 -7) (complex -3 -7)) 0)) (is (= (- (complex -3 -7) 3) (complex -6 -7))) (is (= (- 3 (complex -3 -7)) (complex 6 7))) (is (= (- (complex -3 -7) -1) (complex -2 -7))) (is (= (- -1 (complex -3 -7)) (complex 2 7))) (is (= (- (complex -3 -7) (imaginary -2)) (complex -3 -5))) (is (= (- (imaginary -2) (complex -3 -7)) (complex 3 5))) (is (= (- (complex -3 -7) (imaginary 5)) (complex -3 -12))) (is (= (- (imaginary 5) (complex -3 -7)) (complex 3 12))) (is (= (- 3 (complex 1 2)) (complex 2 -2))) (is (= (- (complex 1 2) 3) (complex -2 2))) (is (= (- 3 (complex -3 -7)) (complex 6 7))) (is (= (- (complex -3 -7) 3) (complex -6 -7))) (is (= (- 3 (imaginary -2)) (complex 3 2))) (is (= (- (imaginary -2) 3) (complex -3 -2))) (is (= (- 3 (imaginary 5)) (complex 3 -5))) (is (= (- (imaginary 5) 3) (complex -3 5))) (is (= (- -1 (complex 1 2)) (complex -2 -2))) (is (= (- (complex 1 2) -1) (complex 2 2))) (is (= (- -1 (complex -3 -7)) (complex 2 7))) (is (= (- (complex -3 -7) -1) (complex -2 -7))) (is (= (- -1 (imaginary -2)) (complex -1 2))) (is (= (- (imaginary -2) -1) (complex 1 -2))) (is (= (- -1 (imaginary 5)) (complex -1 -5))) (is (= (- (imaginary 5) -1) (complex 1 5))) (is (= (- (imaginary -2) (complex 1 2)) (complex -1 -4))) (is (= (- (complex 1 2) (imaginary -2)) (complex 1 4))) (is (= (- (imaginary -2) (complex -3 -7)) (complex 3 5))) (is (= (- (complex -3 -7) (imaginary -2)) (complex -3 -5))) (is (= (- (imaginary -2) 3) (complex -3 -2))) (is (= (- 3 (imaginary -2)) (complex 3 2))) (is (= (- (imaginary -2) -1) (complex 1 -2))) (is (= (- -1 (imaginary -2)) (complex -1 2))) (is (= (- (imaginary -2) (imaginary -2)) 0)) (is (= (- (imaginary -2) (imaginary 5)) (imaginary -7))) (is (= (- (imaginary 5) (imaginary -2)) (imaginary 7))) (is (= (- (imaginary 5) (complex 1 2)) (complex -1 3))) (is (= (- (complex 1 2) (imaginary 5)) (complex 1 -3))) (is (= (- (imaginary 5) (complex -3 -7)) (complex 3 12))) (is (= (- (complex -3 -7) (imaginary 5)) (complex -3 -12))) (is (= (- (imaginary 5) 3) (complex -3 5))) (is (= (- 3 (imaginary 5)) (complex 3 -5))) (is (= (- (imaginary 5) -1) (complex 1 5))) (is (= (- -1 (imaginary 5)) (complex -1 -5))) (is (= (- (imaginary 5) (imaginary -2)) (imaginary 7))) (is (= (- (imaginary -2) (imaginary 5)) (imaginary -7))) (is (= (- (imaginary 5) (imaginary 5)) 0))) (deftest complex-multiplication (is (= (* (complex 1 2) (complex 1 2)) (complex -3 4))) (is (= (* (complex 1 2) (complex -3 -7)) (complex 11 -13))) (is (= (* (complex -3 -7) (complex 1 2)) (complex 11 -13))) (is (= (* (complex 1 2) 3) (complex 3 6))) (is (= (* 3 (complex 1 2)) (complex 3 6))) (is (= (* (complex 1 2) -1) (complex -1 -2))) (is (= (* -1 (complex 1 2)) (complex -1 -2))) (is (= (* (complex 1 2) (imaginary -2)) (complex 4 -2))) (is (= (* (imaginary -2) (complex 1 2)) (complex 4 -2))) (is (= (* (complex 1 2) (imaginary 5)) (complex -10 5))) (is (= (* (imaginary 5) (complex 1 2)) (complex -10 5))) (is (= (* (complex -3 -7) (complex 1 2)) (complex 11 -13))) (is (= (* (complex 1 2) (complex -3 -7)) (complex 11 -13))) (is (= (* (complex -3 -7) (complex -3 -7)) (complex -40 42))) (is (= (* (complex -3 -7) 3) (complex -9 -21))) (is (= (* 3 (complex -3 -7)) (complex -9 -21))) (is (= (* (complex -3 -7) -1) (complex 3 7))) (is (= (* -1 (complex -3 -7)) (complex 3 7))) (is (= (* (complex -3 -7) (imaginary -2)) (complex -14 6))) (is (= (* (imaginary -2) (complex -3 -7)) (complex -14 6))) (is (= (* (complex -3 -7) (imaginary 5)) (complex 35 -15))) (is (= (* (imaginary 5) (complex -3 -7)) (complex 35 -15))) (is (= (* 3 (complex 1 2)) (complex 3 6))) (is (= (* (complex 1 2) 3) (complex 3 6))) (is (= (* 3 (complex -3 -7)) (complex -9 -21))) (is (= (* (complex -3 -7) 3) (complex -9 -21))) (is (= (* 3 (imaginary -2)) (imaginary -6))) (is (= (* (imaginary -2) 3) (imaginary -6))) (is (= (* 3 (imaginary 5)) (imaginary 15))) (is (= (* (imaginary 5) 3) (imaginary 15))) (is (= (* -1 (complex 1 2)) (complex -1 -2))) (is (= (* (complex 1 2) -1) (complex -1 -2))) (is (= (* -1 (complex -3 -7)) (complex 3 7))) (is (= (* (complex -3 -7) -1) (complex 3 7))) (is (= (* -1 (imaginary -2)) (imaginary 2))) (is (= (* (imaginary -2) -1) (imaginary 2))) (is (= (* -1 (imaginary 5)) (imaginary -5))) (is (= (* (imaginary 5) -1) (imaginary -5))) (is (= (* (imaginary -2) (complex 1 2)) (complex 4 -2))) (is (= (* (complex 1 2) (imaginary -2)) (complex 4 -2))) (is (= (* (imaginary -2) (complex -3 -7)) (complex -14 6))) (is (= (* (complex -3 -7) (imaginary -2)) (complex -14 6))) (is (= (* (imaginary -2) 3) (imaginary -6))) (is (= (* 3 (imaginary -2)) (imaginary -6))) (is (= (* (imaginary -2) -1) (imaginary 2))) (is (= (* -1 (imaginary -2)) (imaginary 2))) (is (= (* (imaginary -2) (imaginary -2)) -4)) (is (= (* (imaginary -2) (imaginary 5)) 10)) (is (= (* (imaginary 5) (imaginary -2)) 10)) (is (= (* (imaginary 5) (complex 1 2)) (complex -10 5))) (is (= (* (complex 1 2) (imaginary 5)) (complex -10 5))) (is (= (* (imaginary 5) (complex -3 -7)) (complex 35 -15))) (is (= (* (complex -3 -7) (imaginary 5)) (complex 35 -15))) (is (= (* (imaginary 5) 3) (imaginary 15))) (is (= (* 3 (imaginary 5)) (imaginary 15))) (is (= (* (imaginary 5) -1) (imaginary -5))) (is (= (* -1 (imaginary 5)) (imaginary -5))) (is (= (* (imaginary 5) (imaginary -2)) 10)) (is (= (* (imaginary -2) (imaginary 5)) 10)) (is (= (* (imaginary 5) (imaginary 5)) -25))) (deftest complex-division (is (= (/ (complex 1 2) (complex 1 2)) 1)) (is (= (/ (complex 1 2) (complex -3 -7)) (complex -17/58 1/58))) (is (= (/ (complex -3 -7) (complex 1 2)) (complex -17/5 -1/5))) (is (= (/ (complex 1 2) 3) (complex 1/3 2/3))) (is (= (/ 3 (complex 1 2)) (complex 3/5 -6/5))) (is (= (/ (complex 1 2) -1) (complex -1 -2))) (is (= (/ -1 (complex 1 2)) (complex -1/5 2/5))) (is (= (/ (complex 1 2) (imaginary -2)) (complex -1 1/2))) (is (= (/ (imaginary -2) (complex 1 2)) (complex -4/5 -2/5))) (is (= (/ (complex 1 2) (imaginary 5)) (complex 2/5 -1/5))) (is (= (/ (imaginary 5) (complex 1 2)) (complex 2 1))) (is (= (/ (complex -3 -7) (complex 1 2)) (complex -17/5 -1/5))) (is (= (/ (complex 1 2) (complex -3 -7)) (complex -17/58 1/58))) (is (= (/ (complex -3 -7) (complex -3 -7)) 1)) (is (= (/ (complex -3 -7) 3) (complex -1 -7/3))) (is (= (/ 3 (complex -3 -7)) (complex -9/58 21/58))) (is (= (/ (complex -3 -7) -1) (complex 3 7))) (is (= (/ -1 (complex -3 -7)) (complex 3/58 -7/58))) (is (= (/ (complex -3 -7) (imaginary -2)) (complex 7/2 -3/2))) (is (= (/ (imaginary -2) (complex -3 -7)) (complex 7/29 3/29))) (is (= (/ (complex -3 -7) (imaginary 5)) (complex -7/5 3/5))) (is (= (/ (imaginary 5) (complex -3 -7)) (complex -35/58 -15/58))) (is (= (/ 3 (complex 1 2)) (complex 3/5 -6/5))) (is (= (/ (complex 1 2) 3) (complex 1/3 2/3))) (is (= (/ 3 (complex -3 -7)) (complex -9/58 21/58))) (is (= (/ (complex -3 -7) 3) (complex -1 -7/3))) #_(is (= (/ 3 (imaginary -2)) (imaginary 1.5))) (is (= (/ (imaginary -2) 3) (imaginary -2/3))) (is (= (/ 3 (imaginary 5)) (imaginary -3/5))) (is (= (/ (imaginary 5) 3) (imaginary 5/3))) (is (= (/ -1 (complex 1 2)) (complex -1/5 2/5))) (is (= (/ (complex 1 2) -1) (complex -1 -2))) (is (= (/ -1 (complex -3 -7)) (complex 3/58 -7/58))) (is (= (/ (complex -3 -7) -1) (complex 3 7))) (is (= (/ -1 (imaginary -2)) (imaginary -1/2))) (is (= (/ (imaginary -2) -1) (imaginary 2))) (is (= (/ -1 (imaginary 5)) (imaginary 1/5))) (is (= (/ (imaginary 5) -1) (imaginary -5))) (is (= (/ (imaginary -2) (complex 1 2)) (complex -4/5 -2/5))) (is (= (/ (complex 1 2) (imaginary -2)) (complex -1 1/2))) (is (= (/ (imaginary -2) (complex -3 -7)) (complex 7/29 3/29))) (is (= (/ (complex -3 -7) (imaginary -2)) (complex 7/2 -3/2))) (is (= (/ (imaginary -2) 3) (imaginary -2/3))) (is (= (/ 3 (imaginary -2)) (imaginary 3/2))) (is (= (/ (imaginary -2) -1) (imaginary 2))) (is (= (/ -1 (imaginary -2)) (imaginary -1/2))) (is (= (/ (imaginary -2) (imaginary -2)) 1)) (is (= (/ (imaginary -2) (imaginary 5)) -2/5)) (is (= (/ (imaginary 5) (imaginary -2)) -5/2)) (is (= (/ (imaginary 5) (complex 1 2)) (complex 2 1))) (is (= (/ (complex 1 2) (imaginary 5)) (complex 2/5 -1/5))) (is (= (/ (imaginary 5) (complex -3 -7)) (complex -35/58 -15/58))) (is (= (/ (complex -3 -7) (imaginary 5)) (complex -7/5 3/5))) (is (= (/ (imaginary 5) 3) (imaginary 5/3))) (is (= (/ 3 (imaginary 5)) (imaginary -3/5))) (is (= (/ (imaginary 5) -1) (imaginary -5))) (is (= (/ -1 (imaginary 5)) (imaginary 1/5))) (is (= (/ (imaginary 5) (imaginary -2)) -5/2)) (is (= (/ (imaginary -2) (imaginary 5)) -2/5)) (is (= (/ (imaginary 5) (imaginary 5)) 1))) (deftest complex-conjugate (is (= (conjugate (complex 1 2)) (complex 1 -2))) (is (= (conjugate (complex -3 -7)) (complex -3 7))) (is (= (conjugate (imaginary -2)) (imaginary 2))) (is (= (conjugate (imaginary 5)) (imaginary -5)))) (deftest complex-abs (doseq [c [(complex 1 2) (complex -2 3) (complex 4 -2) (complex -3 -7) (imaginary -2) (imaginary 5)]] (is (approx= (* c (conjugate c)) (sqr (abs c)) 1e-14)))) (deftest complex-sqrt (doseq [c [(complex 1 2) (complex -2 3) (complex 4 -2) (complex -3 -7) (imaginary -2) (imaginary 5)]] (let [r (sqrt c)] (is (approx= c (sqr r) 1e-14)) (is (>= (real r) 0))))) (deftest complex-exp (is (approx= (exp (complex 1 2)) (complex -1.1312043837568135 2.4717266720048188) 1e-14)) (is (approx= (exp (complex 2 3)) (complex -7.3151100949011028 1.0427436562359045) 1e-14)) (is (approx= (exp (complex 4 -2)) (complex -22.720847417619233 -49.645957334580565) 1e-14)) (is (approx= (exp (complex 3 -7)) (complex 15.142531566086868 -13.195928586605717) 1e-14)) (is (approx= (exp (imaginary -2)) (complex -0.41614683654714241 -0.90929742682568171) 1e-14)) (is (approx= (exp (imaginary 5)) (complex 0.2836621854632263 -0.95892427466313845) 1e-14))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_core.clj000066400000000000000000000034171161102570000266270ustar00rootroot00000000000000; Copyright (c) Laurent Petit, March 2009. 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. ;; test namespace for clojure.contrib.core ;; note to other contrib members: feel free to add to this lib (ns clojure.contrib.test-core (:use clojure.test) (:use clojure.contrib.core)) (deftest test-classic-versions (testing "Classic -> throws NPE if passed nil" (is (thrown? NullPointerException (-> nil .toString))) (is (thrown? NullPointerException (-> "foo" seq next next next .toString)))) (testing "Classic .. throws NPE if one of the intermediate threaded values is nil" (is (thrown? NullPointerException (.. nil toString))) (is (thrown? NullPointerException (.. [nil] (get 0) toString))))) (deftest test-new-versions (testing "Version -?>> falls out on nil" (is (nil? (-?>> nil .toString))) (is (nil? (-?>> [] seq (map inc)))) (is (= [] (->> [] seq (map inc))))) (testing "Version -?>> completes for non-nil" (is (= [3 4] (-?>> [1 2] (map inc) (map inc))))) (testing "Version -?> falls out on nil" (is (nil? (-?> nil .toString))) (is (nil? (-?> "foo" seq next next next .toString)))) (testing "Version -?> completes for non-nil" (is (= [\O \O] (-?> "foo" .toUpperCase rest)))) (testing "Version .?. returns nil if one of the intermediate threaded values is nil" (is (nil? (.?. nil toString))) (is (nil? (.?. [nil] (get 0) toString))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_dataflow.clj000066400000000000000000000051651161102570000275020ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-dataflow ;; ;; A Library to Support a Dataflow Model of State - Tests ;; ;; straszheimjeffrey (gmail) ;; Created 11 March 2009 (ns clojure.contrib.test-dataflow (:use clojure.test) (:use clojure.contrib.dataflow)) (def df-1 (build-dataflow [(cell :source base 0) (cell :source items ()) (cell product (* ?base (apply + ?items))) (cell :validator (when (number? ?-product) (assert (>= ?product ?-product))))])) (deftest test-df-1 (is (= (get-value df-1 'product) 0)) (is (do (update-values df-1 {'items [4 5]}) (= (get-value df-1 'product) 0))) (is (do (update-values df-1 {'base 2}) (= (get-value df-1 'product) 18))) (is (thrown? AssertionError (update-values df-1 {'base 0}))) (is (= (get-value df-1 'product) 18))) (def df-2 (build-dataflow [(cell :source strength 10) (cell :source agility 10) (cell :source magic 10) (cell total-cost (apply + ?*cost)) (cell cost (- ?strength 10)) (cell cost (- ?agility 10)) (cell cost (- ?magic 10)) (cell combat (+ ?strength ?agility ?combat-mod)) (cell speed (+ ?agility (/ ?strength 10.0) ?speed-mod)) (cell casting (+ ?agility ?magic ?magic-mod)) (cell combat-mod (apply + ?*combat-mods)) (cell speed-mod (apply + ?*speed-mods)) (cell magic-mod (apply + ?*magic-mods))])) (def magic-skill [(cell cost 5) (cell speed-mods 1) (cell magic-mods 2)]) (defn gv [n] (get-value df-2 n)) (deftest test-df-2 (is (and (= (gv 'total-cost) 0) (= (gv 'strength) 10) (= (gv 'casting) 20))) (is (do (update-values df-2 {'magic 12}) (and (= (gv 'total-cost) 2) (= (gv 'casting) 22)))) (is (do (add-cells df-2 magic-skill) (and (= (gv 'total-cost) 7) (= (gv 'casting) 24)))) (is (do (remove-cells df-2 magic-skill) (and (= (gv 'total-cost) 2) (= (gv 'casting) 22))))) (comment (run-tests) (use :reload 'clojure.contrib.dataflow) (use 'clojure.contrib.stacktrace) (e) (use 'clojure.contrib.trace) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_def.clj000066400000000000000000000020211161102570000264230ustar00rootroot00000000000000;; Tests for def.clj ;; by Stuart Halloway ;; Copyright (c) Stuart Halloway, 2009. 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.contrib.test-def (:use clojure.test) (:require [clojure.contrib.def :as d])) (defn sample-fn "sample-fn docstring" []) (d/defalias aliased-fn sample-fn) (defmacro sample-macro "sample-macro-docstring" []) (d/defalias aliased-macro sample-macro) (deftest defalias-preserves-metadata (let [preserved-meta #(-> % (meta) (select-keys [:doc :arglists :ns :file :macro]))] (are [x y] (= (preserved-meta (var x)) (preserved-meta (var y))) aliased-fn sample-fn aliased-macro sample-macro))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_fnmap.clj000066400000000000000000000017571161102570000270050ustar00rootroot00000000000000(ns clojure.contrib.test-fnmap (:use clojure.contrib.fnmap clojure.test)) (deftest acts-like-map (let [m1 (fnmap get assoc :key1 1 :key2 2)] (are [k v] (= v (get m1 k)) :key1 1 :key2 2 :nonexistent-key nil) (are [k v] (= v (k m1)) :key1 1 :key2 2 :nonexistent-key nil) (let [m2 (assoc m1 :key3 3 :key4 4)] (are [k v] (= v (get m2 k)) :key1 1 :key2 2 :key3 3 :key4 4 :nonexistent-key nil)))) (defn assoc-validate [m key value] (if (integer? value) (assoc m key value) (throw (Exception. "Only integers allowed in this map!")))) (deftest validators (let [m (fnmap get assoc-validate)] (is (= 2 (:key2 (assoc m :key2 2)))) (is (thrown? Exception (assoc m :key3 3.14))))) (defn get-transform [m key] (when-let [value (m key)] (- value))) (deftest transforms (let [m (fnmap get-transform assoc)] (is (= -2 (:key2 (assoc m :key2 2)))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_graph.clj000066400000000000000000000127261161102570000270030ustar00rootroot00000000000000;; Copyright (c) Jeffrey Straszheim. 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. ;; ;; test-graph ;; ;; Basic Graph Theory Algorithms Tests ;; ;; straszheimjeffrey (gmail) ;; Created 23 June 2009 (ns clojure.contrib.test-graph (use clojure.test clojure.contrib.graph)) (def empty-graph (struct directed-graph #{} {})) (def test-graph-1 (struct directed-graph #{:a :b :c :d :e} {:a #{:b :c} :b #{:a :c} :c #{:d :e} :d #{:a :b} :e #{:d}})) (deftest test-reverse-graph (is (= (reverse-graph test-graph-1) (struct directed-graph #{:a :b :c :d :e} {:c #{:b :a} :e #{:c} :d #{:c :e} :b #{:d :a} :a #{:d :b}}))) (is (= (reverse-graph (reverse-graph test-graph-1)) test-graph-1)) (is (= (reverse-graph empty-graph) empty-graph))) (deftest test-add-loops (let [tg1 (add-loops test-graph-1)] (is (every? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1)))) (is (= (add-loops empty-graph) empty-graph))) (deftest test-remove-loops (let [tg1 (remove-loops (add-loops test-graph-1))] (is (not-any? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1)))) (is (= (remove-loops empty-graph) empty-graph))) (def test-graph-2 (struct directed-graph #{:a :b :c :d :e :f :g :h :i :j} {:a #{:b :c} :b #{:a :c} :c #{:d :e} :d #{:a :b} :e #{:d} :f #{:f} :g #{:a :f} :h #{} :i #{:j} :j #{:i}})) (deftest test-lazy-walk (is (= (lazy-walk test-graph-2 :h) [:h])) (is (= (lazy-walk test-graph-2 :j) [:j :i]))) (deftest test-transitive-closure (let [tc-1 (transitive-closure test-graph-1) tc-2 (transitive-closure test-graph-2) get (fn [n] (set (get-neighbors tc-2 n)))] (is (every? #(= #{:a :b :c :d :e} (set %)) (map (partial get-neighbors tc-1) (:nodes tc-1)))) (is (= (get :a) #{:a :b :c :d :e})) (is (= (get :h) #{})) (is (= (get :j) #{:i :j})) (is (= (get :g) #{:a :b :c :d :e :f})))) (deftest test-post-ordered-nodes (is (= (set (post-ordered-nodes test-graph-2)) #{:a :b :c :d :e :f :g :h :i :j})) (is (empty? (post-ordered-nodes empty-graph)))) (deftest test-scc (is (= (set (scc test-graph-2)) #{#{:h} #{:g} #{:i :j} #{:b :c :a :d :e} #{:f}})) (is (empty? (scc empty-graph)))) (deftest test-component-graph (let [cg (component-graph test-graph-2) ecg (component-graph empty-graph)] (is (= (:nodes cg) (set (scc test-graph-2)))) (is (= (get-neighbors cg #{:a :b :c :d :e}) #{#{:a :b :c :d :e}})) (is (= (get-neighbors cg #{:g}) #{#{:a :b :c :d :e} #{:f}})) (is (= (get-neighbors cg #{:i :j}) #{#{:i :j}})) (is (= (get-neighbors cg #{:h}) #{})) (is (= (apply max (map count (self-recursive-sets cg))) 1)) (is (= ecg empty-graph)))) (deftest test-recursive-component? (let [sccs (scc test-graph-2)] (is (= (set (filter (partial recursive-component? test-graph-2) sccs)) #{#{:i :j} #{:b :c :a :d :e} #{:f}})))) (deftest test-self-recursive-sets (is (= (set (self-recursive-sets test-graph-2)) (set (filter (partial recursive-component? test-graph-2) (scc test-graph-2))))) (is (empty? (self-recursive-sets empty-graph)))) (def test-graph-3 (struct directed-graph #{:a :b :c :d :e :f} {:a #{:b} :b #{:c} :c #{:d} :d #{:e} :e #{:f} :f #{}})) (def test-graph-4 (struct directed-graph #{:a :b :c :d :e :f :g :h} {:a #{} :b #{:a} :c #{:a} :d #{:a :b} :e #{:d :c} :f #{:e} :g #{:d} :h #{:f}})) (def test-graph-5 (struct directed-graph #{:a :b :c :d :e :f :g :h} {:a #{} :b #{} :c #{:b} :d #{} :e #{} :f #{} :g #{:f} :h #{}})) (deftest test-dependency-list (is (thrown-with-msg? Exception #".*Fixed point overflow.*" (dependency-list test-graph-2))) (is (= (dependency-list test-graph-3) [#{:f} #{:e} #{:d} #{:c} #{:b} #{:a}])) (is (= (dependency-list test-graph-4) [#{:a} #{:b :c} #{:d} #{:g :e} #{:f} #{:h}])) (is (= (dependency-list test-graph-5) [#{:f :b :a :d :h :e} #{:g :c}])) (is (= (dependency-list empty-graph) [#{}]))) (deftest test-stratification-list (is (thrown-with-msg? Exception #".*Fixed point overflow.*" (stratification-list test-graph-2 test-graph-2))) (is (= (stratification-list test-graph-4 test-graph-5) [#{:a} #{:b :c} #{:d} #{:e} #{:f :g} #{:h}])) (is (= (stratification-list empty-graph empty-graph) [#{}]))) (comment (run-tests) ) ;; End of file clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_greatest_least.clj000066400000000000000000000046661161102570000307140ustar00rootroot00000000000000(ns clojure.contrib.test-greatest-least (:use clojure.contrib.greatest-least [clojure.test :only (is deftest run-tests)])) (deftest test-greatest (is (nil? (greatest)) "greatest with no arguments is nil") (is (= 1 (greatest 1))) (is (= 2 (greatest 1 2))) (is (= 2 (greatest 2 1))) (is (= "b" (greatest "aa" "b")))) (deftest test-greatest-by (is (nil? (greatest-by identity)) "greatest-by with no arguments is nil") (is (= "" (greatest-by count ""))) (is (= "a" (greatest-by count "a" ""))) (is (= "a" (greatest-by count "" "a"))) (is (= "aa" (greatest-by count "aa" "b")))) (deftest test-least (is (nil? (least)) "least with no arguments is nil") (is (= 1 (least 1))) (is (= 1 (least 1 2))) (is (= 1 (least 2 1))) (is (= "aa" (least "aa" "b")))) (deftest test-least-by (is (nil? (least-by identity)) "least-by with no arguments is nil") (is (= "" (least-by count ""))) (is (= "" (least-by count "a" ""))) (is (= "" (least-by count "" "a"))) (is (= "b" (least-by count "aa" "b")))) (deftest test-all-greatest (is (nil? (all-greatest)) "all-greatest with no arguments is nil") (is (= (list 1) (all-greatest 1))) (is (= (list 1 1) (all-greatest 1 1))) (is (= (list 2) (all-greatest 2 1 1))) (is (= (list 2) (all-greatest 1 2 1))) (is (= (list 2) (all-greatest 1 1 2))) (is (= (list :c) (all-greatest :b :c :a)))) (deftest test-all-greatest-by (is (nil? (all-greatest-by identity)) "all-greatest-by with no arguments is nil") (is (= (list "a")) (all-greatest-by count "a")) (is (= (list "a" "a")) (all-greatest-by count "a" "a")) (is (= (list "aa")) (all-greatest-by count "aa" "b")) (is (= (list "aa")) (all-greatest-by count "b" "aa" "c")) (is (= (list "cc" "aa")) (all-greatest-by count "aa" "b" "cc"))) (deftest test-all-least (is (nil? (all-least)) "all-least with no arguments is nil") (is (= (list 1) (all-least 1))) (is (= (list 1 1) (all-least 1 1))) (is (= (list 1 1) (all-least 2 1 1))) (is (= (list 1 1) (all-least 1 2 1))) (is (= (list 1 1) (all-least 1 1 2))) (is (= (list :a) (all-least :b :c :a)))) (deftest test-all-least-by (is (nil? (all-least-by identity)) "all-least-by with no arguments is nil") (is (= (list "a")) (all-least-by count "a")) (is (= (list "a" "a")) (all-least-by count "a" "a")) (is (= (list "b")) (all-least-by count "aa" "b")) (is (= (list "c" "b")) (all-least-by count "b" "aa" "c")) (is (= (list "b")) (all-least-by count "aa" "b" "cc"))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_io.clj000066400000000000000000000075351161102570000263130ustar00rootroot00000000000000(ns clojure.contrib.test-io (:refer-clojure :exclude (spit)) (:use clojure.test clojure.contrib.io) (:import (java.io File FileInputStream BufferedInputStream) (java.net URL URI))) (deftest file-str-backslash (is (= (java.io.File. (str "C:" java.io.File/separator "Documents" java.io.File/separator "file.txt")) (file-str "C:\\Documents\\file.txt")))) (deftest test-as-file (testing "strings" (is (= (File. "foo") (as-file "foo")))) (testing "Files" (is (= (File. "bar") (as-file (File. "bar")))))) (deftest test-as-url (are [result expr] (= result expr) (URL. "http://foo") (as-url (URL. "http://foo")) (URL. "http://foo") (as-url "http://foo") (URL. "http://foo") (as-url (URI. "http://foo")) (URL. "file:/foo") (as-url (File. "/foo")))) (deftest test-delete-file (let [file (File/createTempFile "test" "deletion") not-file (File. (str (java.util.UUID/randomUUID)))] (delete-file (.getAbsolutePath file)) (is (not (.exists file))) (is (thrown? ArithmeticException (/ 1 0))) (is (thrown? java.io.IOException (delete-file not-file))) (is (delete-file not-file :silently)))) (deftest test-relative-path-string (testing "strings" (is (= "foo" (relative-path-string "foo")))) (testing "absolute path strings are forbidden" (is (thrown? IllegalArgumentException (relative-path-string (str File/separator "baz"))))) (testing "relative File paths" (is (= "bar" (relative-path-string (File. "bar"))))) (testing "absolute File paths are forbidden" (is (thrown? IllegalArgumentException (relative-path-string (File. (str File/separator "quux"))))))) (defn stream-should-have [stream expected-bytes msg] (let [actual-bytes (byte-array (alength expected-bytes))] (.read stream actual-bytes) (is (= -1 (.read stream)) (str msg " : should be end of stream")) (is (= (seq expected-bytes) (seq actual-bytes)) (str msg " : byte arrays should match")))) (deftest test-input-stream (let [file (File/createTempFile "test-input-stream" "txt") bytes (.getBytes "foobar")] (spit file "foobar") (doseq [[expr msg] [[file File] [(FileInputStream. file) FileInputStream] [(BufferedInputStream. (FileInputStream. file)) BufferedInputStream] [(.. file toURI) URI] [(.. file toURI toURL) URL] [(.. file toURI toURL toString) "URL as String"] [(.. file toString) "File as String"]]] (with-open [s (input-stream expr)] (stream-should-have s bytes msg))))) (deftest test-streams-buffering (let [data (.getBytes "")] (is (instance? java.io.BufferedReader (reader data))) (is (instance? java.io.BufferedWriter (writer (java.io.ByteArrayOutputStream.)))) (is (instance? java.io.BufferedInputStream (input-stream data))) (is (instance? java.io.BufferedOutputStream (output-stream (java.io.ByteArrayOutputStream.)))))) (deftest test-streams-defaults (let [f (File/createTempFile "clojure.contrib" "test-reader-writer") content "test\u2099ing"] (try (is (thrown? Exception (reader (Object.)))) (is (thrown? Exception (writer (Object.)))) (are [write-to read-from] (= content (do (spit write-to content) (slurp* (or read-from write-to)))) f nil (.getAbsolutePath f) nil (.toURL f) nil (.toURI f) nil (java.io.FileOutputStream. f) f (java.io.OutputStreamWriter. (java.io.FileOutputStream. f) "UTF-8") f f (java.io.FileInputStream. f) f (java.io.InputStreamReader. (java.io.FileInputStream. f) "UTF-8")) (is (= content (slurp* (.getBytes content "UTF-8")))) (is (= content (slurp* (.toCharArray content)))) (finally (.delete f))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_jmx.clj000066400000000000000000000161171161102570000264760ustar00rootroot00000000000000;; Tests for JMX support for Clojure (see also clojure/contrib/jmx.clj) ;; by Stuart Halloway ;; Copyright (c) Stuart Halloway, 2009. 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.contrib.test-jmx (:import javax.management.openmbean.CompositeDataSupport [javax.management MBeanAttributeInfo AttributeList] [java.util.logging LogManager Logger] clojure.contrib.jmx.Bean) (:use clojure.test) (:require [clojure.contrib [jmx :as jmx]])) (defn =set [a b] (= (set a) (set b))) (defn seq-contains-all? "Does container contain every item in containee? Not fast. Testing use only" [container containee] (let [container (set container)] (every? #(contains? container %) containee))) (deftest finding-mbeans (testing "as-object-name" (are [cname object-name] (= cname (.getCanonicalName object-name)) "java.lang:type=Memory" (jmx/as-object-name "java.lang:type=Memory"))) (testing "mbean-names" (are [cnames object-name] (= cnames (map #(.getCanonicalName %) object-name)) ["java.lang:type=Memory"] (jmx/mbean-names "java.lang:type=Memory")))) ; These actual beans may differ on different JVM platforms. ; Tested April 2010 to work on Sun and IBM JDKs. (deftest testing-actual-beans (testing "reflecting on capabilities" (are [attr-list mbean-name] (seq-contains-all? (jmx/attribute-names mbean-name) attr-list) [:Verbose :ObjectPendingFinalizationCount :HeapMemoryUsage :NonHeapMemoryUsage] "java.lang:type=Memory") (are [op-list mbean-name] (seq-contains-all? (jmx/operation-names mbean-name) op-list) [:gc] "java.lang:type=Memory")) (testing "mbean-from-oname" (are [key-names oname] (seq-contains-all? (keys (jmx/mbean oname)) key-names) [:Verbose :ObjectPendingFinalizationCount :HeapMemoryUsage :NonHeapMemoryUsage] "java.lang:type=Memory"))) (deftest raw-reading-attributes (let [mem "java.lang:type=Memory" log "java.util.logging:type=Logging"] (testing "simple scalar attributes" (are [a b] (= a b) false (jmx/raw-read mem :Verbose)) (are [type attr] (instance? type attr) Number (jmx/raw-read mem :ObjectPendingFinalizationCount))))) (deftest reading-attributes (testing "simple scalar attributes" (are [type attr] (instance? type attr) Number (jmx/read "java.lang:type=Memory" :ObjectPendingFinalizationCount))) (testing "composite attributes" (are [ks attr] (=set ks (keys attr)) [:used :max :init :committed] (jmx/read "java.lang:type=Memory" :HeapMemoryUsage))) (testing "tabular attributes" (is (map? (jmx/read "java.lang:type=Runtime" :SystemProperties))))) (deftest writing-attributes (let [mem "java.lang:type=Memory"] (jmx/write! mem :Verbose true) (is (true? (jmx/raw-read mem :Verbose))) (jmx/write! mem :Verbose false))) (deftest test-invoke-operations (testing "without arguments" (jmx/invoke "java.lang:type=Memory" :gc)) (testing "with arguments" (.addLogger (LogManager/getLogManager) (Logger/getLogger "clojure.contrib.test_contrib.test_jmx")) (jmx/invoke "java.util.logging:type=Logging" :setLoggerLevel "clojure.contrib.test_contrib.test_jmx" "WARNING"))) (deftest test-jmx->clj (testing "it works recursively on maps" (let [some-map {:foo (jmx/raw-read "java.lang:type=Memory" :HeapMemoryUsage)}] (is (map? (:foo (jmx/jmx->clj some-map)))))) (testing "it leaves everything else untouched" (is (= "foo" (jmx/jmx->clj "foo"))))) (deftest test-composite-data->map (let [data (jmx/raw-read "java.lang:type=Memory" :HeapMemoryUsage) prox (jmx/composite-data->map data)] (testing "returns a map with keyword keys" (is (= (set [:committed :init :max :used]) (set (keys prox))))))) (deftest test-tabular-data->map (let [raw-props (jmx/raw-read "java.lang:type=Runtime" :SystemProperties) props (jmx/tabular-data->map raw-props)] (are [k] (contains? props k) :java.class.path :path.separator))) (deftest test-creating-attribute-infos (let [infos (jmx/map->attribute-infos [[:a 1] [:b 2]]) info (first infos)] (testing "generates the right class" (is (= (class (into-array MBeanAttributeInfo [])) (class infos)))) (testing "generates the right instance data" (are [result expr] (= result expr) "a" (.getName info) "a" (.getDescription info))))) (deftest various-beans-are-readable (testing "that all java.lang beans can be read without error" (doseq [mb (jmx/mbean-names "*:*")] (is (map? (jmx/mbean mb)) mb)))) (deftest test-jmx-url (testing "creates default url" (is (= "service:jmx:rmi:///jndi/rmi://localhost:3000/jmxrmi" (jmx/jmx-url)))) (testing "creates custom url" (is (= "service:jmx:rmi:///jndi/rmi://example.com:4000/jmxrmi" (jmx/jmx-url {:host "example.com" :port 4000})))) (testing "creates custom jndi path" (is (= "service:jmx:rmi:///jndi/rmi://example.com:4000/jmxconnector" (jmx/jmx-url {:host "example.com" :port 4000 :jndi-path "jmxconnector"}))))) ;; ---------------------------------------------------------------------- ;; tests for clojure.contrib.jmx.Bean. (deftest dynamic-mbean-from-compiled-class (let [mbean-name "clojure.contrib.test_contrib.test_jmx:name=Foo"] (jmx/register-mbean (Bean. (ref {:string-attribute "a-string"})) mbean-name) (are [result expr] (= result expr) "a-string" (jmx/read mbean-name :string-attribute) {:string-attribute "a-string"} (jmx/mbean mbean-name) ))) (deftest test-getAttribute (doseq [reftype [ref atom agent]] (let [state (reftype {:a 1 :b 2}) bean (Bean. state)] (testing (str "accessing values from a " (class state)) (are [result expr] (= result expr) 1 (.getAttribute bean "a")))))) (deftest test-bean-info (let [state (ref {:a 1 :b 2}) bean (Bean. state) info (.getMBeanInfo bean)] (testing "accessing info" (are [result expr] (= result expr) "clojure.contrib.jmx.Bean" (.getClassName info))))) (deftest test-getAttributes (let [bean (Bean. (ref {:r 5 :d 4})) atts (.getAttributes bean (into-array ["r" "d"]))] (are [x y] (= x y) AttributeList (class atts) [5 4] (seq atts)))) (deftest test-guess-attribute-typename (are [x y] (= x (jmx/guess-attribute-typename y)) ; "long" 10 "boolean" false "java.lang.String" "foo" "long" (Long/valueOf (long 10)))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_json.clj000066400000000000000000000125541161102570000266520ustar00rootroot00000000000000(ns clojure.contrib.test-json (:use clojure.test clojure.contrib.json)) (deftest can-read-from-pushback-reader (let [s (java.io.PushbackReader. (java.io.StringReader. "42"))] (is (= 42 (read-json s))))) (deftest can-read-from-reader (let [s (java.io.StringReader. "42")] (is (= 42 (read-json s))))) (deftest can-read-numbers (is (= 42 (read-json "42"))) (is (= -3 (read-json "-3"))) (is (= 3.14159 (read-json "3.14159"))) (is (= 6.022e23 (read-json "6.022e23")))) (deftest can-read-null (is (= nil (read-json "null")))) (deftest can-read-strings (is (= "Hello, World!" (read-json "\"Hello, World!\"")))) (deftest handles-escaped-slashes-in-strings (is (= "/foo/bar" (read-json "\"\\/foo\\/bar\"")))) (deftest handles-unicode-escapes (is (= " \u0beb " (read-json "\" \\u0bEb \"")))) (deftest handles-escaped-whitespace (is (= "foo\nbar" (read-json "\"foo\\nbar\""))) (is (= "foo\rbar" (read-json "\"foo\\rbar\""))) (is (= "foo\tbar" (read-json "\"foo\\tbar\"")))) (deftest can-read-booleans (is (= true (read-json "true"))) (is (= false (read-json "false")))) (deftest can-ignore-whitespace (is (= nil (read-json "\r\n null")))) (deftest can-read-arrays (is (= [1 2 3] (read-json "[1,2,3]"))) (is (= ["Ole" "Lena"] (read-json "[\"Ole\", \r\n \"Lena\"]")))) (deftest can-read-objects (is (= {:a 1, :b 2} (read-json "{\"a\": 1, \"b\": 2}")))) (deftest can-read-nested-structures (is (= {:a [1 2 {:b [3 "four"]} 5.5]} (read-json "{\"a\":[1,2,{\"b\":[3,\"four\"]},5.5]}")))) (deftest disallows-non-string-keys (is (thrown? Exception (read-json "{26:\"z\"")))) (deftest disallows-barewords (is (thrown? Exception (read-json " foo ")))) (deftest disallows-unclosed-arrays (is (thrown? Exception (read-json "[1, 2, ")))) (deftest disallows-unclosed-objects (is (thrown? Exception (read-json "{\"a\":1, ")))) (deftest can-get-string-keys (is (= {"a" [1 2 {"b" [3 "four"]} 5.5]} (read-json "{\"a\":[1,2,{\"b\":[3,\"four\"]},5.5]}" false true nil)))) (declare *pass1-string*) (deftest pass1-test (let [input (read-json *pass1-string* false true nil)] (is (= "JSON Test Pattern pass1" (first input))) (is (= "array with 1 element" (get-in input [1 "object with 1 member" 0]))) (is (= 1234567890 (get-in input [8 "integer"]))) (is (= "rosebud" (last input))))) ; from http://www.json.org/JSON_checker/test/pass1.json (def *pass1-string* "[ \"JSON Test Pattern pass1\", {\"object with 1 member\":[\"array with 1 element\"]}, {}, [], -42, true, false, null, { \"integer\": 1234567890, \"real\": -9876.543210, \"e\": 0.123456789e-12, \"E\": 1.234567890E+34, \"\": 23456789012E66, \"zero\": 0, \"one\": 1, \"space\": \" \", \"quote\": \"\\\"\", \"backslash\": \"\\\\\", \"controls\": \"\\b\\f\\n\\r\\t\", \"slash\": \"/ & \\/\", \"alpha\": \"abcdefghijklmnopqrstuvwyz\", \"ALPHA\": \"ABCDEFGHIJKLMNOPQRSTUVWYZ\", \"digit\": \"0123456789\", \"0123456789\": \"digit\", \"special\": \"`1~!@#$%^&*()_+-={':[,]}|;.?\", \"hex\": \"\\u0123\\u4567\\u89AB\\uCDEF\\uabcd\\uef4A\", \"true\": true, \"false\": false, \"null\": null, \"array\":[ ], \"object\":{ }, \"address\": \"50 St. James Street\", \"url\": \"http://www.JSON.org/\", \"comment\": \"// /* */\": \" \", \" s p a c e d \" :[1,2 , 3 , 4 , 5 , 6 ,7 ],\"compact\":[1,2,3,4,5,6,7], \"jsontext\": \"{\\\"object with 1 member\\\":[\\\"array with 1 element\\\"]}\", \"quotes\": \"" \\u0022 %22 0x22 034 "\", \"\\/\\\\\\\"\\uCAFE\\uBABE\\uAB98\\uFCDE\\ubcda\\uef4A\\b\\f\\n\\r\\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?\" : \"A key can be any string\" }, 0.5 ,98.6 , 99.44 , 1066, 1e1, 0.1e1, 1e-1, 1e00,2e+00,2e-00 ,\"rosebud\"]") (deftest can-print-json-strings (is (= "\"Hello, World!\"" (json-str "Hello, World!"))) (is (= "\"\\\"Embedded\\\" Quotes\"" (json-str "\"Embedded\" Quotes")))) (deftest can-print-unicode (is (= "\"\\u1234\\u4567\"" (json-str "\u1234\u4567")))) (deftest can-print-json-null (is (= "null" (json-str nil)))) (deftest can-print-json-arrays (is (= "[1,2,3]" (json-str [1 2 3]))) (is (= "[1,2,3]" (json-str (list 1 2 3)))) (is (= "[1,2,3]" (json-str (sorted-set 1 2 3)))) (is (= "[1,2,3]" (json-str (seq [1 2 3]))))) (deftest can-print-java-arrays (is (= "[1,2,3]" (json-str (into-array [1 2 3]))))) (deftest can-print-empty-arrays (is (= "[]" (json-str []))) (is (= "[]" (json-str (list)))) (is (= "[]" (json-str #{})))) (deftest can-print-json-objects (is (= "{\"a\":1,\"b\":2}" (json-str (sorted-map :a 1 :b 2))))) (deftest object-keys-must-be-strings (is (= "{\"1\":1,\"2\":2") (json-str (sorted-map 1 1 2 2)))) (deftest can-print-empty-objects (is (= "{}" (json-str {})))) (deftest accept-sequence-of-nils (is (= "[null,null,null]" (json-str [nil nil nil])))) (deftest error-on-nil-keys (is (thrown? Exception (json-str {nil 1})))) (deftest characters-in-symbols-are-escaped (is (= "\"foo\\u1b1b\"" (json-str (symbol "foo\u1b1b"))))) ;;; Pretty-printer (deftest pretty-printing (let [x (read-json *pass1-string* false)] (is (= x (read-json (with-out-str (pprint-json x)) false))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_lazy_seqs.clj000066400000000000000000000014471161102570000277120ustar00rootroot00000000000000(ns clojure.contrib.test-lazy-seqs (:use clojure.test clojure.contrib.lazy-seqs)) (deftest test-fibs (is (= [0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986 102334155 165580141 267914296 433494437 701408733 1134903170 1836311903 2971215073 4807526976 7778742049] (take 50 (fibs))))) (deftest test-powers-of-2 (is (= [1 2 4 8 16 32 64 128 256 512] (take 10 (powers-of-2))))) (deftest test-primes (is (= [2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229] (take 50 primes)))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_load_all.clj000066400000000000000000000033171161102570000274450ustar00rootroot00000000000000;;; test_load_all.clj - loads all contrib libraries for testing purposes ;; by Stuart Halloway, http://blog.thinkrelevance.com ;; Copyright (c) Stuart Halloway, 2009. 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. ;; This is only intended to check that the libraries will load without ;; errors, not that they work correctly. ;; The code includes several design choices I don't love, but find ;; tolerable in a test-only lib: ;; ;; * namespaces that blow up to document deprecation ;; * using directory paths to find contrib ;; * using a macro to reflectively write tests ;; ;; I *am* happy that code that won't even load now breaks the build. (ns clojure.contrib.test-load-all (:use clojure.test clojure.contrib.find-namespaces)) (def deprecated-contrib-namespaces '[clojure.contrib.javadoc]) (defn loadable-contrib-namespaces "Contrib namespaces that can be loaded (everything except deprecated nses that throw on load.)" [] (apply disj (into #{} (find-namespaces-in-dir (java.io.File. "src/main"))) deprecated-contrib-namespaces)) (defn emit-test-load [] `(do ~@(map (fn [ns] `(deftest ~(symbol (str "test-loading-" (.replace (str ns) "." "-"))) (require :reload '~ns))) (loadable-contrib-namespaces)))) (defmacro test-load [] (emit-test-load)) (test-load) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_macro_utils.clj000066400000000000000000000044521161102570000302200ustar00rootroot00000000000000;; Test routines for macro_utils.clj ;; by Konrad Hinsen ;; last updated May 6, 2009 ;; Copyright (c) Konrad Hinsen, 2008. 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.contrib.test-macro-utils (:use [clojure.test :only (deftest is are run-tests use-fixtures)] [clojure.contrib.macro-utils :only (macrolet symbol-macrolet defsymbolmacro with-symbol-macros mexpand-1 mexpand mexpand-all)] [clojure.contrib.monads :only (with-monad domonad)])) (use-fixtures :each (fn [f] (binding [*ns* (the-ns 'clojure.contrib.test-macro-utils)] (f)))) (deftest macrolet-test (is (= (macroexpand-1 '(macrolet [(foo [form] `(~form ~form))] (foo x))) '(do (x x))))) (deftest symbol-macrolet-test (is (= (macroexpand-1 '(symbol-macrolet [x xx y yy] (exp [a y] (x y)))) '(do (exp [a yy] (xx yy))))) (is (= (macroexpand-1 '(symbol-macrolet [def foo] (def def def))) '(do (def def foo)))) (is (= (macroexpand-1 '(symbol-macrolet [x foo z bar] (let [a x b y x b] [a b x z]))) '(do (let* [a foo b y x b] [a b x bar])))) (is (= (macroexpand-1 '(symbol-macrolet [x foo z bar] (fn ([x y] [x y z]) ([x y z] [x y z])))) '(do (fn* ([x y] [x y bar]) ([x y z] [x y z]))))) (is (= (macroexpand-1 '(symbol-macrolet [x foo z bar] (fn f ([x y] [x y z]) ([x y z] [x y z])))) '(do (fn* f ([x y] [x y bar]) ([x y z] [x y z]))))) (is (= (nth (second (macroexpand-1 '(symbol-macrolet [x xx y yy z zz] (domonad m [a x b y x z] [a b x z])))) 2) '(do (m-bind xx (fn* ([a] (m-bind yy (fn* ([b] (m-bind zz (fn* ([x] (m-result [a b x zz])))))))))))))) (deftest symbol-test (defsymbolmacro sum-2-3 (plus 2 3)) (is (= (macroexpand '(with-symbol-macros (+ 1 sum-2-3))) '(do (+ 1 (plus 2 3))))) (is (= (macroexpand '(macrolet [(plus [a b] `(+ ~a ~b))] (+ 1 sum-2-3))) '(do (+ 1 (clojure.core/+ 2 3))))) (ns-unmap *ns* 'sum-2-3)) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_math.clj000066400000000000000000000056511161102570000266320ustar00rootroot00000000000000(ns clojure.contrib.test-math (:use clojure.test clojure.contrib.math)) (deftest test-expt (are [x y] (= x y) (expt 2 3) 8 (expt (expt 2 16) 2) (expt 2 32) (expt 4/3 2) 16/9 (expt 2 -10) 1/1024 (expt 0.5M 2) 0.25M (expt 5 4.2) (Math/pow 5 4.2) (expt 5.3 4) (Math/pow 5.3 4))) (deftest test-abs (are [x y] (= x y) (abs -2) 2 (abs 0) 0 (abs 5) 5 (abs 123456789123456789) 123456789123456789 (abs -123456789123456789) 123456789123456789 (abs 5/3) 5/3 (abs -4/3) 4/3 (abs 4.3M) 4.3M (abs -4.3M) 4.3M (abs 2.8) 2.8 (abs -2.8) 2.8)) (deftest test-gcd (are [x y] (= x y) (gcd 4 3) 1 (gcd 24 12) 12 (gcd 24 27) 3 (gcd 1 0) 1 (gcd 0 1) 1 (gcd 0 0) 0) (is (thrown? IllegalArgumentException (gcd nil 0))) (is (thrown? IllegalArgumentException (gcd 0 nil))) (is (thrown? IllegalArgumentException (gcd 7.0 0)))) (deftest test-lcm (are [x y] (= x y) (lcm 2 3) 6 (lcm 3 2) 6 (lcm -2 3) 6 (lcm 2 -3) 6 (lcm -2 -3) 6 (lcm 4 10) 20 (lcm 1 0) 0 (lcm 0 1) 0 (lcm 0 0)) (is (thrown? IllegalArgumentException (lcm nil 0))) (is (thrown? IllegalArgumentException (lcm 0 nil))) (is (thrown? IllegalArgumentException (lcm 7.0 0)))) (deftest test-floor (are [x y] (== x y) (floor 6) 6 (floor -6) -6 (floor 123456789123456789) 123456789123456789 (floor -123456789123456789) -123456789123456789 (floor 4/3) 1 (floor -4/3) -2 (floor 4.3M) 4 (floor -4.3M) -5 (floor 4.3) 4.0 (floor -4.3) -5.0)) (deftest test-ceil (are [x y] (== x y) (ceil 6) 6 (ceil -6) -6 (ceil 123456789123456789) 123456789123456789 (ceil -123456789123456789) -123456789123456789 (ceil 4/3) 2 (ceil -4/3) -1 (ceil 4.3M) 5 (ceil -4.3M) -4 (ceil 4.3) 5.0 (ceil -4.3) -4.0)) (deftest test-round (are [x y] (== x y) (round 6) 6 (round -6) -6 (round 123456789123456789) 123456789123456789 (round -123456789123456789) -123456789123456789 (round 4/3) 1 (round 5/3) 2 (round 5/2) 3 (round -4/3) -1 (round -5/3) -2 (round -5/2) -2 (round 4.3M) 4 (round 4.7M) 5 (round -4.3M) -4 (round -4.7M) -5 (round 4.5M) 5 (round -4.5M) -4 (round 4.3) 4 (round 4.7) 5 (round -4.3) -4 (round -4.7) -5 (round 4.5) 5 (round -4.5) -4)) (deftest test-sqrt (are [x y] (= x y) (sqrt 9) 3 (sqrt 16/9) 4/3 (sqrt 0.25M) 0.5M (sqrt 2) (Math/sqrt 2))) (deftest test-exact-integer-sqrt (are [x y] (= x y) (exact-integer-sqrt 15) [3 6] (exact-integer-sqrt (inc (expt 2 32))) [(expt 2 16) 1] (exact-integer-sqrt 1000000000000) [1000000 0])) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_miglayout.clj000066400000000000000000000101351161102570000277040ustar00rootroot00000000000000;; Copyright (c) Stephen C. Gilardi. 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. ;; ;; clojure.contrib.miglayout.test ;; ;; Test/example for clojure.contrib.miglayout ;; ;; scgilardi (gmail) ;; Created 5 October 2008 (ns clojure.contrib.test-miglayout (:import (javax.swing JButton JFrame JLabel JList JPanel JScrollPane JTabbedPane JTextField JSeparator)) (:use clojure.contrib.miglayout)) (def tests) (defn run-test [index] (let [panel ((tests index) (JPanel.))] (println index (components panel)) (doto (JFrame. (format "MigLayout Test %d" index)) (.add panel) (.pack) (.setVisible true)))) (defn label "Returns a swing label" [text] (JLabel. text)) (defn text-field "Returns a swing text field" ([] (text-field 10)) ([width] (JTextField. width))) (defn sep "Returns a swing separator" [] (JSeparator.)) (def tests [ (fn test0 [panel] (miglayout panel (label "Hello") (label "World") {:gap :unrelated} (text-field) :wrap (label "Bonus!") (JButton. "Bang it") {:wmin :button :grow :x :span 2} :center)) ;; test1 and test2 are based on code from ;; http://www.devx.com/java/Article/38017/1954 ;; constraints as strings exclusively (fn test1 [panel] (miglayout panel :column "[right]" (label "General") "split, span" (sep) "growx, wrap" (label "Company") "gap 10" (text-field "") "span, growx" (label "Contact") "gap 10" (text-field "") "span, growx, wrap" (label "Propeller") "split, span, gaptop 10" (sep) "growx, wrap, gaptop 10" (label "PTI/kW") "gapx 10, gapy 15" (text-field) (label "Power/kW") "gap 10" (text-field) "wrap" (label "R/mm") "gap 10" (text-field) (label "D/mm") "gap 10" (text-field))) ;; the same constraints as strings, keywords, vectors, and maps (fn test2 [panel] (miglayout panel :column "[right]" (label "General") "split, span" (sep) :growx :wrap (label "Company") [:gap 10] (text-field "") :span :growx (label "Contact") [:gap 10] (text-field "") :span :growx :wrap (label "Propeller") :split :span [:gaptop 10] (sep) :growx :wrap [:gaptop 10] (label "PTI/kW") {:gapx 10 :gapy 15} (text-field) (label "Power/kW") [:gap 10] (text-field) :wrap (label "R/mm") [:gap 10] (text-field) (label "D/mm") [:gap 10] (text-field))) ;; the same constraints using symbols to name groups of constraints (fn test3 [panel] (let [g [:gap 10] gt [:gaptop 10] gxs #{:growx :span} gxw #{:growx :wrap} gxy {:gapx 10 :gapy 15} right "[right]" ss #{:split :span} w :wrap] (miglayout panel :column right (label "General") ss (sep) gxw (label "Company") g (text-field "") gxs (label "Contact") g (text-field "") gxs (label "Propeller") ss gt (sep) gxw g (label "PTI/kW") gxy (text-field) (label "Power/kW") g (text-field) w (label "R/mm") g (text-field) (label "D/mm") g (text-field)))) (fn test4 [panel] (miglayout panel (label "First Name") (text-field) {:id :firstname} (label "Surname") [:gap :unrelated] (text-field) {:id :surname} :wrap (label "Address") (text-field) {:id :address} :span :grow)) ]) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_mock.clj000066400000000000000000000120011161102570000266150ustar00rootroot00000000000000(ns clojure.contrib.test-mock (:use clojure.test) (:require [clojure.contrib.mock :as mock])) ; Used as dummy dependency functions (defn fn1 {:dynamic true} [x] :ignore) (defn fn2 {:dynamic true} [x y] :ignore) (defn fn3 {:dynamic true} ([x] :ignore) ([x y z] :ignore)) (defn fn4 {:dynamic true} [x y & r] :ignore) ;functions created using fn directly lack the argslist meta data (def #^{:dynamic true} deffed-differently (fn [x] :ignore)) (defmacro assert-called [fn-name called? & body] `(let [called-status?# (atom false)] (binding [~fn-name (fn [& args#] (reset! called-status?# true))] ~@body) (is (= ~called? @called-status?#)))) (deftest test-convenience (testing "once" (is (false? (mock/once 0))) (is (false? (mock/once 123))) (is (true? (mock/once 1)))) (testing "never" (is (false? (mock/never 4))) (is (true? (mock/never 0)))) (testing "more-than" (is (false? ((mock/more-than 5) 3))) (is (true? ((mock/more-than 5) 9)))) (testing "less-than" (is (true? ((mock/less-than 5) 3))) (is (false? ((mock/less-than 5) 9)))) (testing "between" (is (true? ((mock/between 5 8) 6))) (is (false? ((mock/between 5 8) 5))))) (deftest test-returns (is (= {:returns 5} (mock/returns 5))) (is (= {:other-key "test" :returns nil} (mock/returns nil {:other-key "test"})))) (deftest test-has-args (let [ex (:has-args (mock/has-args [1]))] (is (fn? ex)) (is (ex 'fn1 1)) (is (ex 'fn1 1 5 6)) (assert-called mock/unexpected-args true (ex 'fn1 5))) (is (contains? (mock/has-args [] {:pre-existing-key "test"}) :pre-existing-key)) (is (true? (((mock/has-args [5]) :has-args)'fn1 5)))) (deftest test-has-matching-signature (assert-called mock/no-matching-function-signature true (mock/has-matching-signature? 'clojure.contrib.test-mock/fn2 [1])) (assert-called mock/no-matching-function-signature true (mock/has-matching-signature? 'clojure.contrib.test-mock/fn3 [1 3])) (assert-called mock/no-matching-function-signature false (mock/has-matching-signature? 'clojure.contrib.test-mock/fn3 [1 3 5])) (assert-called mock/no-matching-function-signature false (mock/has-matching-signature? 'clojure.contrib.test-mock/fn4 [1 3 5 7 9])) (assert-called mock/no-matching-function-signature false (mock/has-matching-signature? 'clojure.contrib.test-mock/fn4 [1 3])) (assert-called mock/no-matching-function-signature true (mock/has-matching-signature? 'clojure.contrib.test-mock/fn4 [1])) (assert-called mock/no-matching-function-signature false (mock/has-matching-signature? 'clojure.contrib.test-mock/deffed-differently [1]))) (deftest test-times (is (fn? ((mock/times #(= 1 %)) :times))) (is (contains? (mock/times #(= 1 %) {:existing-key "test"}) :existing-key))) (deftest test-make-mock (testing "invalid arguments" (is (thrown? IllegalArgumentException (mock/make-mock [5])))) (testing "valid counter and unevaluated returns" (let [[mock counter count-checker] (mock/make-mock 'fn1 (mock/returns 5 (mock/times 1)))] (is (fn? mock)) (is (= 0 @counter)) (is (= 5 (mock :ignore-me))) (is (= 1 @counter)))) (testing "returns as expected" (let [[mock] (mock/make-mock 'fn1 (mock/returns 5))] (is (= 5 (mock :ignore)))) (let [[mock] (mock/make-mock 'fn1 (mock/returns #(* 2 %)))] (is (= 10 ((mock :ignore) 5)) ":returns a function should not automatically evaluate it."))) (testing "calls replacement-fn and returns the result" (let [[mock] (mock/make-mock 'fn1 (mock/calls #(* 3 %)))] (is (= 15 (mock 5)))) (let [[mock] (mock/make-mock 'fn1 (mock/calls #(* 2 %) (mock/returns 3)))] (is (= 10 (mock 5))))) (testing "argument validation" (let [[mock] (mock/make-mock 'fn1 (mock/has-args [#(= 5 %)]))] (assert-called mock/unexpected-args true (mock "test")) (is (nil? (mock 5)))))) (deftest test-make-count-checker (let [checker (mock/make-count-checker 5 5)] (assert-called mock/incorrect-invocation-count false (checker 'fn1 5)) (assert-called mock/incorrect-invocation-count true (checker 'fn1 3)))) (deftest test-validate-counts (assert-called mock/incorrect-invocation-count false (mock/validate-counts (list [(fn []) (atom 0) (mock/make-count-checker #(< % 6) '#(< % 6)) 'fn1]))) (assert-called mock/incorrect-invocation-count true (mock/validate-counts (list [(fn []) (atom 0) (mock/make-count-checker 4 4) 'fn1])))) (deftest test-expect-macro (let [under-test (fn [x] (fn1 x))] (is (true? (mock/expect [fn1 (mock/times 1 (mock/has-args [#(= 3 %)]))] (under-test 3)))) (assert-called mock/unexpected-args true (mock/expect [fn1 (mock/times 1 (mock/has-args [#(= 4 %)]))] (under-test 3)))) (let [under-test (fn [] (fn2 (fn1 1) 3))] (is (true? (mock/expect [fn1 (mock/times 1 (mock/has-args [#(= 1 %)] (mock/returns 2))) fn2 (mock/times 1 (mock/has-args [#(= 2 %) #(= 3 %)] (mock/returns 5)))] (under-test))))))clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_monads.clj000066400000000000000000000054171161102570000271620ustar00rootroot00000000000000;; Test routines for monads.clj ;; by Konrad Hinsen ;; last updated March 28, 2009 ;; Copyright (c) Konrad Hinsen, 2008. 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.contrib.test-monads (:use [clojure.test :only (deftest is are run-tests)] [clojure.contrib.monads :only (with-monad domonad m-lift m-seq m-chain sequence-m maybe-m state-m maybe-t sequence-t)])) (deftest sequence-monad (with-monad sequence-m (are [a b] (= a b) (domonad [x (range 3) y (range 2)] (+ x y)) '(0 1 1 2 2 3) (domonad [x (range 5) y (range (+ 1 x)) :when (= (+ x y) 2)] (list x y)) '((1 1) (2 0)) ((m-lift 2 #(list %1 %2)) (range 3) (range 2)) '((0 0) (0 1) (1 0) (1 1) (2 0) (2 1)) (m-seq (replicate 3 (range 2))) '((0 0 0) (0 0 1) (0 1 0) (0 1 1) (1 0 0) (1 0 1) (1 1 0) (1 1 1)) ((m-chain (replicate 3 range)) 5) '(0 0 0 1 0 0 1 0 1 2) (m-plus (range 3) (range 2)) '(0 1 2 0 1)))) (deftest maybe-monad (with-monad maybe-m (let [m+ (m-lift 2 +) mdiv (fn [x y] (domonad [a x b y :when (not (zero? b))] (/ a b)))] (are [a b] (= a b) (m+ (m-result 1) (m-result 3)) (m-result 4) (mdiv (m-result 1) (m-result 3)) (m-result (/ 1 3)) (m+ 1 (mdiv (m-result 1) (m-result 0))) m-zero (m-plus m-zero (m-result 1) m-zero (m-result 2)) (m-result 1))))) (deftest seq-maybe-monad (with-monad (maybe-t sequence-m) (letfn [(pairs [xs] ((m-lift 2 #(list %1 %2)) xs xs))] (are [a b] (= a b) ((m-lift 1 inc) (for [n (range 10)] (when (odd? n) n))) '(nil 2 nil 4 nil 6 nil 8 nil 10) (pairs (for [n (range 5)] (when (odd? n) n))) '(nil nil (1 1) nil (1 3) nil nil nil (3 1) nil (3 3) nil nil))))) (deftest state-maybe-monad (with-monad (maybe-t state-m) (is (= (for [[a b c d] (list [1 2 3 4] [nil 2 3 4] [ 1 nil 3 4] [nil nil 3 4] [1 2 nil nil])] (let [f (domonad [x (m-plus (m-result a) (m-result b)) y (m-plus (m-result c) (m-result d))] (+ x y))] (f :state))) (list [4 :state] [5 :state] [4 :state] [nil :state] [nil :state]))))) (deftest state-seq-monad (with-monad (sequence-t state-m) (is (= (let [[a b c d] [1 2 10 20] f (domonad [x (m-plus (m-result a) (m-result b)) y (m-plus (m-result c) (m-result d))] (+ x y))] (f :state))) (list [(list 11 21 12 22) :state])))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_profile.clj000066400000000000000000000004361161102570000273350ustar00rootroot00000000000000(ns clojure.contrib.test-profile (:use clojure.test clojure.contrib.profile)) (deftest test-print-summary (testing "doesn't blow up with no data (assembla #31)" (is (= "Name mean min max count sum\n" (with-out-str (print-summary {})))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_properties.clj000066400000000000000000000050461161102570000300730ustar00rootroot00000000000000(ns clojure.contrib.test-properties (:refer-clojure :exclude (spit)) (:use clojure.test clojure.contrib.properties [clojure.contrib.io :only (spit)]) (:import (java.util Properties) (java.io File))) (deftest test-get-system-property (testing "works the same with keywords, symbols, and strings" (is (= (get-system-property "java.home") (get-system-property 'java.home))) (is (= (get-system-property "java.home") (get-system-property :java.home)))) (testing "treats second arg as default" (is (= "default" (get-system-property "testing.test-system-property" "default")))) (testing "returns nil for missing properties" (is (nil? (get-system-property "testing.test-system-property"))))) (deftest test-set-system-properties (testing "set and then unset a property using keywords" (let [propname :clojure.contrib.java.test-set-system-properties] (is (nil? (get-system-property propname))) (set-system-properties {propname :foo}) (is (= "foo") (get-system-property propname)) (set-system-properties {propname nil}) (is (nil? (get-system-property propname)))))) (deftest test-with-system-properties (let [propname :clojure.contrib.java.test-with-system-properties] (testing "sets a property only for the duration of a block" (is (= "foo" (with-system-properties {propname "foo"} (get-system-property propname)))) (is (nil? (get-system-property propname))))) (testing "leaves other properties alone" ; TODO: write this test better, using a properties -> map function (let [propname :clojure.contrib.java.test-with-system-properties propcount (count (System/getProperties))] (with-system-properties {propname "foo"} (is (= (inc propcount) (count (System/getProperties))))) (is (= propcount (count (System/getProperties))))))) (deftest test-as-properties (let [expected (doto (Properties.) (.setProperty "a" "b") (.setProperty "c" "d"))] (testing "with a map" (is (= expected (as-properties {:a "b" :c "d"})))) (testing "with a sequence of pairs" (is (= expected (as-properties [[:a :b] [:c :d]])))))) (deftest test-read-properties (let [f (File/createTempFile "test" "properties")] (spit f "a=b\nc=d") (is (= {"a" "b" "c" "d"} (read-properties f))))) (deftest test-write-properties (let [f (File/createTempFile "test" "properties")] (write-properties [['a 'b] ['c 'd]] f) (is (= {"a" "b" "c" "d"} (read-properties f))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_prxml.clj000066400000000000000000000005111161102570000270310ustar00rootroot00000000000000(ns clojure.contrib.test-prxml (:use clojure.test clojure.contrib.prxml)) (deftest prxml-basic (is (= "

Hello, World!

" (with-out-str (prxml [:p "Hello, World!"]))))) (deftest prxml-escaping (is (= "foo<bar" (with-out-str (prxml [:a {:href "foo&bar"} "foo= ? AND grade <= ?") min max] (doseq [rec res] (println rec))))) (defn db-grade-a "Print rows describing all grade a fruit (grade between 90 and 100)" [] (db-grade-range 90 100)) (defn db-get-tables "Demonstrate getting table info" [] (sql/with-connection db (into [] (resultset-seq (-> (sql/connection) (.getMetaData) (.getTables nil nil nil (into-array ["TABLE" "VIEW"]))))))) (defn db-exception "Demonstrate rolling back a partially completed transaction on exception" [] (sql/with-connection db (sql/transaction (sql/insert-values :fruit [:name :appearance] ["Grape" "yummy"] ["Pear" "bruised"]) ;; at this point the insert-values call is complete, but the transaction ;; is not. the exception will cause it to roll back leaving the database ;; untouched. (throw (Exception. "sql/test exception"))))) (defn db-sql-exception "Demonstrate an sql exception" [] (sql/with-connection db (sql/transaction (sql/insert-values :fruit [:name :appearance] ["Grape" "yummy"] ["Pear" "bruised"] ["Apple" "strange" "whoops"])))) (defn db-batchupdate-exception "Demonstrate a batch update exception" [] (sql/with-connection db (sql/transaction (sql/do-commands "DROP TABLE fruit" "DROP TABLE fruit")))) (defn db-rollback "Demonstrate a rollback-only trasaction" [] (sql/with-connection db (sql/transaction (prn "is-rollback-only" (sql/is-rollback-only)) (sql/set-rollback-only) (sql/insert-values :fruit [:name :appearance] ["Grape" "yummy"] ["Pear" "bruised"]) (prn "is-rollback-only" (sql/is-rollback-only)) (sql/with-query-results res ["SELECT * FROM fruit"] (doseq [rec res] (println rec)))) (prn) (sql/with-query-results res ["SELECT * FROM fruit"] (doseq [rec res] (println rec))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_string.clj000066400000000000000000000064401161102570000272040ustar00rootroot00000000000000(ns clojure.contrib.test-string (:require [clojure.contrib.string :as s]) (:use clojure.test)) (deftest t-codepoints (is (= (list 102 111 111 65536 98 97 114) (s/codepoints "foo\uD800\uDC00bar")) "Handles Unicode supplementary characters")) (deftest t-escape (is (= "<foo&bar>" (s/escape {\& "&" \< "<" \> ">"} ""))) (is (= " \\\"foo\\\" " (s/escape {\" "\\\""} " \"foo\" " ))) (is (= "faabor" (s/escape {\a \o, \o \a} "foobar")))) (deftest t-blank (is (s/blank? nil)) (is (s/blank? "")) (is (s/blank? " ")) (is (s/blank? " \t \n \r ")) (is (not (s/blank? " foo ")))) (deftest t-take (is (= "foo" (s/take 3 "foobar"))) (is (= "foobar" (s/take 7 "foobar"))) (is (= "" (s/take 0 "foo")))) (deftest t-drop (is (= "bar" (s/drop 3 "foobar"))) (is (= "" (s/drop 9 "foobar"))) (is (= "foobar" (s/drop 0 "foobar")))) (deftest t-butlast (is (= "foob" (s/butlast 2 "foobar"))) (is (= "" (s/butlast 9 "foobar"))) (is (= "foobar" (s/butlast 0 "foobar")))) (deftest t-tail (is (= "ar" (s/tail 2 "foobar"))) (is (= "foobar" (s/tail 9 "foobar"))) (is (= "" (s/tail 0 "foobar")))) (deftest t-repeat (is (= "foofoofoo" (s/repeat 3 "foo")))) (deftest t-reverse (is (= "tab" (s/reverse "bat")))) (deftest t-replace (is (= "faabar" (s/replace-char \o \a "foobar"))) (is (= "barbarbar" (s/replace-str "foo" "bar" "foobarfoo"))) (is (= "FOObarFOO" (s/replace-by #"foo" s/upper-case "foobarfoo")))) (deftest t-replace-first (is (= "barbarfoo" (s/replace-first-re #"foo" "bar" "foobarfoo"))) (is (= "FOObarfoo" (s/replace-first-by #"foo" s/upper-case "foobarfoo")))) (deftest t-partition (is (= (list "" "abc" "123" "def") (s/partition #"[a-z]+" "abc123def")))) (deftest t-join (is (= "1,2,3" (s/join \, [1 2 3]))) (is (= "" (s/join \, []))) (is (= "1 and-a 2 and-a 3" (s/join " and-a " [1 2 3])))) (deftest t-chop (is (= "fo" (s/chop "foo"))) (is (= "") (s/chop "f")) (is (= "") (s/chop ""))) (deftest t-chomp (is (= "foo" (s/chomp "foo\n"))) (is (= "foo" (s/chomp "foo\r\n"))) (is (= "foo" (s/chomp "foo"))) (is (= "" (s/chomp "")))) (deftest t-swap-case (is (= "fOO!bAR" (s/swap-case "Foo!Bar"))) (is (= "" (s/swap-case "")))) (deftest t-capitalize (is (= "Foobar" (s/capitalize "foobar"))) (is (= "Foobar" (s/capitalize "FOOBAR")))) (deftest t-ltrim (is (= "foo " (s/ltrim " foo "))) (is (= "" (s/ltrim " ")))) (deftest t-rtrim (is (= " foo" (s/rtrim " foo "))) (is (= "" (s/rtrim " ")))) (deftest t-split-lines (is (= (list "one" "two" "three") (s/split-lines "one\ntwo\r\nthree"))) (is (= (list "foo") (s/split-lines "foo")))) (deftest t-upper-case (is (= "FOOBAR" (s/upper-case "Foobar")))) (deftest t-lower-case (is (= "foobar" (s/lower-case "FooBar")))) (deftest t-trim (is (= "foo" (s/trim " foo \r\n")))) (deftest t-substring (is (s/substring? "foo" "foobar")) (is (not (s/substring? "baz" "foobar")))) (deftest t-get (is (= \o (s/get "foo" 1)))) (deftest t-as-str (testing "keyword to string" (is (= "foo") (s/as-str :foo))) (testing "symbol to string" (is (= "foo") (s/as-str 'foo))) (testing "string to string" (is (= "foo") (s/as-str "foo"))) (testing "stringifying non-namish things" (is (= "42") (s/as-str 42)))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_strint.clj000066400000000000000000000033351161102570000272210ustar00rootroot00000000000000; Copyright (c) Stuart Halloway, 2010-. 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.contrib.test-strint (:use clojure.test) (:use [clojure.contrib strint with-ns])) (def silent-read (with-ns 'clojure.contrib.strint silent-read)) (def interpolate (with-ns 'clojure.contrib.strint interpolate)) (deftest test-silent-read (testing "reading a valid form returns [read form, rest of string]" (is (= [[1] "[2]"] (silent-read "[1][2]")))) (testing "reading an invalid form returns nil" (is (= nil (silent-read "["))))) (deftest test-interpolate (testing "a plain old string" (is (= ["a plain old string"] (interpolate "a plain old string")))) (testing "some value replacement forms" (is (= '["" foo " and " bar ""] (interpolate "~{foo} and ~{bar}")))) (testing "some fn-calling forms" (is (= '["" (+ 1 2) " and " (vector 3) ""] (interpolate "~(+ 1 2) and ~(vector 3)"))))) (deftest test-<< (testing "docstring examples" (let [v 30.5 m {:a [1 2 3]}] (is (= "This trial required 30.5ml of solution." (<< "This trial required ~{v}ml of solution."))) (is (= "There are 30 days in November." (<< "There are ~(int v) days in November."))) (is (= "The total for your order is $6." (<< "The total for your order is $~(->> m :a (apply +)).")))))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_trace.clj000066400000000000000000000010421161102570000267650ustar00rootroot00000000000000(ns clojure.contrib.test-trace (:use clojure.test clojure.contrib.trace)) (deftrace call-myself [n] (when-not (< n 1) (call-myself (dec n)))) (deftest test-tracing-a-function-that-calls-itself (let [output (with-out-str (call-myself 1))] (is (re-find #"^TRACE t\d+: (call-myself 1)\nTRACE t\d+: | (call-myself 0)\nTRACE t\d+: | => nil\nTRACE t\d+: => nil$" output)))) ;(deftest dotrace-on-core ; (let [output (with-out-str (dotrace [mod] (mod 11 5)))] ; (is (re-find #"\(mod 11 5\)" output)))) clojure-contrib_1.2.0.orig/src/test/clojure/clojure/contrib/test_with_ns.clj000066400000000000000000000013141161102570000273440ustar00rootroot00000000000000(ns clojure.contrib.test-with-ns (:use clojure.test clojure.contrib.with-ns)) (deftest test-namespace-gets-removed (let [all-ns-names (fn [] (map #(.name %) (all-ns)))] (testing "unexceptional return" (let [ns-name (with-temp-ns (ns-name *ns*))] (is (not (some #{ns-name} (all-ns-names)))))) (testing "when an exception is thrown" (let [ns-name-str (try (with-temp-ns (throw (RuntimeException. (str (ns-name *ns*))))) (catch clojure.lang.Compiler$CompilerException e (-> e .getCause .getMessage)))] (is (re-find #"^sym.*$" ns-name-str)) (is (not (some #{(symbol ns-name-str)} (all-ns-names))))))))