--- a/.hgignore Mon Nov 12 13:02:38 2012 -0500
+++ b/.hgignore Thu Nov 01 19:46:55 2018 -0400
@@ -1,11 +1,4 @@
-syntax:glob
-target/
-lib/
-classes/
-checkouts/
-pom.xml
-*.jar
-*.class
-.lein-deps-sum
-.lein-failures
-.lein-plugins
+syntax: glob
+
+scratch.lisp
+lisp.prof
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,1 @@
+(4 define-problem)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,19 @@
+Copyright (c) 2018 Steve Losh and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,8 @@
+.PHONY: vendor
+
+
+# Vendor ----------------------------------------------------------------------
+vendor/quickutils.lisp: vendor/make-quickutils.lisp
+ cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
+
+vendor: vendor/quickutils.lisp
--- a/README.markdown Mon Nov 12 13:02:38 2012 -0500
+++ b/README.markdown Thu Nov 01 19:46:55 2018 -0400
@@ -1,9 +1,1 @@
-# Rosalind
-
-My Clojure solutions to [Rosalind][] problems.
-
-[Rosalind]: http://rosalind.info
-
-## License
-
-MIT/X11
+My solutions to Rosalind problems.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,9 @@
+(defpackage :rosalind
+ (:use
+ :cl
+ :iterate
+ :losh
+ :rosalind.quickutils)
+ (:import-from :1am :is)
+ (:shadowing-import-from :1am :test)
+ (:export :run-tests))
--- a/project.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(defproject rosalind "0.1.0-SNAPSHOT"
- :description "FIXME: write description"
- :url "http://example.com/FIXME"
- :license {:name "Eclipse Public License"
- :url "http://www.eclipse.org/legal/epl-v10.html"}
- :dependencies [[org.clojure/clojure "1.4.0"]
- [the/parsatron "0.0.3"]
- [org.clojure/math.combinatorics "0.0.3"]
- [roul "0.2.0"]])
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/rosalind.asd Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,27 @@
+(asdf:defsystem :rosalind
+ :name "rosalind"
+ :description "Rosalind solutions."
+
+ :author "Steve Losh <steve@stevelosh.com>"
+ :maintainer "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT"
+ :version "0.0.1"
+
+ :depends-on (
+
+ :1am
+ :iterate
+ :losh
+
+ )
+
+ :serial t
+ :components ((:module "vendor" :serial t
+ :components ((:file "quickutils-package")
+ (:file "quickutils")))
+ (:file "package")
+ (:module "src" :serial t
+ :components ((:file "utils")
+ (:file "problems")))))
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems.lisp Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,99 @@
+(in-package :rosalind)
+
+;;;; Testing ------------------------------------------------------------------
+(defmacro define-test (problem input output &optional (test 'string=))
+ `(test ,(symb 'test- problem)
+ (is (,test ,output (,problem ,input)))))
+
+(defun run-tests ()
+ (1am:run))
+
+
+;;;; Problems -----------------------------------------------------------------
+(defmacro define-problem
+ ((number name) args sample-input sample-output &body body)
+ (let ((symbol (symb 'problem- number)))
+ `(progn
+ (defun ,symbol ,args ,@body)
+ (setf (get ',symbol 'rosalind-name) ,(string-downcase name))
+ (define-test ,symbol ,sample-input ,sample-output)
+ ',symbol)))
+
+
+(define-problem (1 dna) (data)
+ "AGCTTTTCATTCTGACTGCAACGGGCAATATGTCTCTGTGTGGATTAAAAAAAGAGTGTCTGATAGCAGC"
+ "20 12 17 21"
+ ;; A string is simply an ordered collection of symbols selected from some
+ ;; alphabet and formed into a word; the length of a string is the number of
+ ;; symbols that it contains.
+ ;;
+ ;; An example of a length 21 DNA string (whose alphabet contains the symbols
+ ;; 'A', 'C', 'G', and 'T') is "ATGCTTCAGAAAGGTCTTACG."
+ ;;
+ ;; Given: A DNA string s of length at most 1000 nt.
+ ;; Return: Four integers (separated by spaces) counting the respective number
+ ;; of times that the symbols 'A', 'C', 'G', and 'T' occur in s.
+ (let ((results (frequencies data)))
+ (format nil "~D ~D ~D ~D"
+ (gethash #\A results)
+ (gethash #\C results)
+ (gethash #\G results)
+ (gethash #\T results))))
+
+(define-problem (2 rna) (data)
+ "GATGGAACTTGACTACGTAAATT"
+ "GAUGGAACUUGACUACGUAAAUU"
+ ;; An RNA string is a string formed from the alphabet containing 'A', 'C',
+ ;; 'G', and 'U'.
+ ;;
+ ;; Given a DNA string t corresponding to a coding strand, its transcribed RNA
+ ;; string u is formed by replacing all occurrences of 'T' in t with 'U' in u.
+ ;;
+ ;; Given: A DNA string t having length at most 1000 nt.
+ ;;
+ ;; Return: The transcribed RNA string of t.
+ (substitute #\U #\T data))
+
+(define-problem (3 revc) (data)
+ "AAAACCCGGT"
+ "ACCGGGTTTT"
+ ;; In DNA strings, symbols 'A' and 'T' are complements of each other, as are
+ ;; 'C' and 'G'.
+ ;;
+ ;; The reverse complement of a DNA string s is the string sc formed by
+ ;; reversing the symbols of s, then taking the complement of each symbol
+ ;; (e.g., the reverse complement of "GTCA" is "TGAC").
+ ;;
+ ;; Given: A DNA string s of length at most 1000 bp.
+ ;;
+ ;; Return: The reverse complement sc of s.
+ (copyf data)
+ (flet ((dna-complement (base)
+ (case base
+ (#\A #\T)
+ (#\T #\A)
+ (#\G #\C)
+ (#\C #\G)
+ (t base)))) ; newline etc
+ (map-into data #'dna-complement data)
+ (nreverse data)))
+
+
+;;;; Solutions ----------------------------------------------------------------
+(defun read-problem-data (problem)
+ (-<> (get problem 'rosalind-name)
+ (format nil "~~/Downloads/rosalind_~A.txt" <>)
+ read-file-into-string))
+
+(defun solve% (problem)
+ (pbcopy (funcall problem (read-problem-data problem))))
+
+(defmacro solve (problem)
+ `(solve% ',problem))
+
+
+;; (problem-3 "AAAACCCGGT")
+
+;; (solve problem-3)
+
+
--- a/src/rosalind/p001.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,9 +0,0 @@
-(ns rosalind.p001
- (:require [clojure.string :refer [join]]))
-
-(defn solve [s]
- (println (join " " (map (frequencies s) "ACGT"))))
-
-(solve "AGCTTTTCATTCTGACTGCAACGGGCAATATGTCTCTGTGTGGATTAAAAAAAGAGTGTCTGATAGCAGC")
-
-(solve (slurp "/Users/sjl/Downloads/rosalind_dna.txt"))
--- a/src/rosalind/p002.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,11 +0,0 @@
-(ns rosalind.p002
- (:refer-clojure :exclude [replace])
- (:require [clojure.string :refer [replace]]))
-
-
-(defn solve [s]
- (replace s "T" "U"))
-
-(solve "GATGGAACTTGACTACGTAAATT")
-
-(solve (slurp "/Users/sjl/Downloads/rosalind_rna.txt"))
--- a/src/rosalind/p003.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-(ns rosalind.p003
- (:require [clojure.string :refer [join]]))
-
-(def nucleotide-complement
- {\A \T
- \C \G
- \T \A
- \G \C})
-
-
-(defn solve [s]
- (join "" (map nucleotide-complement (reverse s))))
-
-(solve "AAAACCCGGT")
-
-(print (solve (slurp "/Users/sjl/Downloads/rosalind_revc.txt")))
--- a/src/rosalind/p004.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,63 +0,0 @@
-(ns rosalind.p004
- (:refer-clojure :exclude [char])
- (:require [the.parsatron :refer [defparser many1 always run string digit char
- eof let->> token between]]))
-
-(defparser number []
- (let->> [ds (many1 (digit))]
- (always (apply str ds))))
-
-(defparser dna-line []
- (let->> [nts (many1 (token #{\G \T \C \A}))
- _ (char \newline)]
- (always (apply str nts))))
-
-(defparser dna []
- (let->> [ntls (many1 (dna-line))]
- (always (apply str ntls))))
-
-(defparser header []
- (between (string ">Rosalind_") (char \newline)
- (number)))
-
-(defparser chunk []
- (let->> [id (header)
- content (dna)]
- (always [id content])))
-
-(defparser file []
- (let->> [chunks (many1 (chunk))
- _ (eof)
- ]
- (always chunks)))
-
-(defn parse [s]
- (run (file) s))
-
-(def sample
-">Rosalind_6404
-CCTGCGGAAGATCGGCACTAGAATAGCCAGAACCGTTTCTCTGAGGCTTCCGGCCTTCCC
-TCCCACTAATAATTCTGAGG
->Rosalind_5959
-CCATCGGTAGCGCATCCTTAGTCCAATTAAGTCCCTATCCAGGCGCTCCGCCGAAGGTCT
-ATATCCATTTGTCAGCAGACACGC
->Rosalind_0808
-CCACCCTCGTGGTATGGCTAGGCATTCAGGAACCGGAGAACGCTTCAGACCAGCCCGGAC
-TGGGAACCTGCGGGCAGTAGGTGGAAT
-"
-)
-
-(defn gc-content [dna]
- (float (/ (count (filter #{\G \C} dna))
- (count dna))))
-
-(defn solve [s]
- (let [[id gcc] (last (sort-by second
- (map (juxt first (comp gc-content second))
- (parse s))))]
- (println (str "Rosalind_" id))
- (println (str (* 100 gcc) "%"))))
-
-(solve sample)
-
-(solve (slurp "/Users/sjl/Downloads/rosalind_gc.txt"))
--- a/src/rosalind/p005.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,17 +0,0 @@
-(ns rosalind.p005
- (:require [clojure.string :refer [split-lines trim]]))
-
-(defn hamming [s t]
- (count (filter identity (map not= s t))))
-
-(def sample
-"GAGCCTACTAACGGGAT
-CATCGTAATGACGGCCT")
-
-(defn solve [s]
- (println (apply hamming
- (-> s trim split-lines))))
-
-(solve sample)
-
-(print (solve (slurp "/Users/sjl/Downloads/rosalind_hamm.txt")))
--- a/src/rosalind/p006.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(ns rosalind.p006
- (:require [clojure.math.combinatorics :refer [permutations]]
- [clojure.string :refer [join trim]]))
-
-(def sample "3")
-
-(defn solve [s]
- (let [ps (permutations (range 1 (inc (Long/parseLong (trim s)))))]
- (println (count ps))
- (dorun (map #(println (join " " %)) ps))))
-
-(solve sample)
-
-(solve (slurp "/Users/sjl/Downloads/rosalind_perm.txt"))
--- a/src/rosalind/p007.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
-(ns rosalind.p007
- (:require [clojure.string :as s]))
-
-(def sample "0.23 0.31 0.75")
-
-(defn content-probs [gcc]
- (let [gc (/ gcc 2)
- at (/ (- 1 gcc) 2)]
- {:g gc
- :c gc
- :a at
- :t at}))
-
-(defn chance-of-twice [prob]
- (* prob prob))
-
-(defn solve [s]
- (let [gccs (map #(Float/parseFloat %)
- (s/split (s/trim s) #"\s+"))]
- (println (s/join " "
- (for [gcc gccs]
- (reduce + (map chance-of-twice
- (vals (content-probs gcc)))))))))
-
-(solve sample)
-
-(solve (slurp "/Users/sjl/Downloads/rosalind_prob.txt"))
--- a/src/rosalind/p008.clj Mon Nov 12 13:02:38 2012 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,84 +0,0 @@
-(ns rosalind.p008
- (:require [clojure.string :as s]))
-
-
-(def sample "AUGGCCAUGGCGCCCAGAACUGAGAUCAAUAGUACCCGUAUUAACGGGUGA")
-
-(def acid
- {"UUU" \F
- "CUU" \L
- "AUU" \I
- "GUU" \V
- "UUC" \F
- "CUC" \L
- "AUC" \I
- "GUC" \V
- "UUA" \L
- "CUA" \L
- "AUA" \I
- "GUA" \V
- "UUG" \L
- "CUG" \L
- "AUG" \M
- "GUG" \V
- "UCU" \S
- "CCU" \P
- "ACU" \T
- "GCU" \A
- "UCC" \S
- "CCC" \P
- "ACC" \T
- "GCC" \A
- "UCA" \S
- "CCA" \P
- "ACA" \T
- "GCA" \A
- "UCG" \S
- "CCG" \P
- "ACG" \T
- "GCG" \A
- "UAU" \Y
- "CAU" \H
- "AAU" \N
- "GAU" \D
- "UAC" \Y
- "CAC" \H
- "AAC" \N
- "GAC" \D
- "UAA" nil
- "CAA" \Q
- "AAA" \K
- "GAA" \E
- "UAG" nil
- "CAG" \Q
- "AAG" \K
- "GAG" \E
- "UGU" \C
- "CGU" \R
- "AGU" \S
- "GGU" \G
- "UGC" \C
- "CGC" \R
- "AGC" \S
- "GGC" \G
- "UGA" nil
- "CGA" \R
- "AGA" \R
- "GGA" \G
- "UGG" \W
- "CGG" \R
- "AGG" \R
- "GGG" \G})
-
-
-(defn solve [s]
- (println (->> s
- s/trim
- (partition 3)
- (map s/join)
- (map acid)
- s/join)))
-
-(solve sample)
-
-(solve (slurp "/Users/sjl/Downloads/rosalind_prot.txt"))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/utils.lisp Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,27 @@
+(in-package :rosalind)
+
+
+(defun sh (command input)
+ (declare (ignorable command input))
+ #+sbcl
+ (sb-ext:run-program (first command) (rest command)
+ :search t
+ :input (make-string-input-stream input))
+ #+ccl
+ (ccl:run-program (first command) (rest command)
+ :input (make-string-input-stream input))
+ #+abcl
+ (let ((p (system:run-program (first command) (rest command)
+ :input :stream
+ :output t
+ :wait nil)))
+ (write-string input (system:process-input p))
+ (close (system:process-input p)))
+ #-(or sbcl ccl abcl)
+ (error "Not implemented for this Lisp implementation, sorry"))
+
+(defun pbcopy (string)
+ (values string (sh '("pbcopy") string)))
+
+(defmacro copyf (sequence)
+ `(setf ,sequence (copy-seq ,sequence)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,15 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+ "quickutils.lisp"
+ :utilities '(
+
+ :compose
+ :curry
+ :rcurry
+ :with-gensyms
+ :read-file-into-string
+ :symb
+
+ )
+ :package "ROSALIND.QUICKUTILS")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils-package.lisp Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,12 @@
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "EULER.QUICKUTILS")
+ (defpackage "EULER.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "EULER.QUICKUTILS")
+
+;; need to define this here so sbcl will shut the hell up about it being
+;; undefined when compiling quickutils.lisp. computers are trash.
+(defparameter *utilities* nil)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp Thu Nov 01 19:46:55 2018 -0400
@@ -0,0 +1,260 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :RCURRY :WITH-GENSYMS :READ-FILE-INTO-STRING :SYMB) :ensure-package T :package "ROSALIND.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "ROSALIND.QUICKUTILS")
+ (defpackage "ROSALIND.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "ROSALIND.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+ :COMPOSE :CURRY :RCURRY
+ :STRING-DESIGNATOR :WITH-GENSYMS
+ :ONCE-ONLY :WITH-OPEN-FILE*
+ :WITH-INPUT-FROM-FILE
+ :READ-FILE-INTO-STRING :MKSTR :SYMB))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-gensym-list (length &optional (x "G"))
+ "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+ (let ((g (if (typep x '(integer 0)) x (string x))))
+ (loop repeat length
+ collect (gensym g))))
+ ) ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; To propagate return type and allow the compiler to eliminate the IF when
+ ;;; it is known if the argument is function or not.
+ (declaim (inline ensure-function))
+
+ (declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+ (defun ensure-function (function-designator)
+ "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+ ) ; eval-when
+
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
+ (defun curry (function &rest arguments)
+ "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+ (define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,fun ,@curries more)))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
+
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
+
+
+ (defmacro once-only (specs &body forms)
+ "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+
+ (defmacro with-open-file* ((stream filespec &key direction element-type
+ if-exists if-does-not-exist external-format)
+ &body body)
+ "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
+the default value specified for `open`."
+ (once-only (direction element-type if-exists if-does-not-exist external-format)
+ `(with-open-stream
+ (,stream (apply #'open ,filespec
+ (append
+ (when ,direction
+ (list :direction ,direction))
+ (when ,element-type
+ (list :element-type ,element-type))
+ (when ,if-exists
+ (list :if-exists ,if-exists))
+ (when ,if-does-not-exist
+ (list :if-does-not-exist ,if-does-not-exist))
+ (when ,external-format
+ (list :external-format ,external-format)))))
+ ,@body)))
+
+
+ (defmacro with-input-from-file ((stream-name file-name &rest args
+ &key (direction nil direction-p)
+ &allow-other-keys)
+ &body body)
+ "Evaluate `body` with `stream-name` to an input stream on the file
+`file-name`. `args` is sent as is to the call to `open` except `external-format`,
+which is only sent to `with-open-file` when it's not `nil`."
+ (declare (ignore direction))
+ (when direction-p
+ (error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE."))
+ `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+ ,@body))
+
+
+ (defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+ "Return the contents of the file denoted by `pathname` as a fresh string.
+
+The `external-format` parameter will be passed directly to `with-open-file`
+unless it's `nil`, which means the system default."
+ (with-input-from-file
+ (file-stream pathname :external-format external-format)
+ (let ((*print-pretty* nil))
+ (with-output-to-string (datum)
+ (let ((buffer (make-array buffer-size :element-type 'character)))
+ (loop
+ :for bytes-read = (read-sequence buffer file-stream)
+ :do (write-sequence buffer datum :start 0 :end bytes-read)
+ :while (= bytes-read buffer-size)))))))
+
+
+ (defun mkstr (&rest args)
+ "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+ (with-output-to-string (s)
+ (dolist (a args) (princ a s))))
+
+
+ (defun symb (&rest args)
+ "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+ (values (intern (apply #'mkstr args))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(compose curry rcurry with-gensyms with-unique-names
+ read-file-into-string symb)))
+
+;;;; END OF quickutils.lisp ;;;;