# HG changeset patch # User Steve Losh # Date 1541116015 14400 # Node ID f4ede9fed310d1c1de3d4c372d4e0f3ed6d71f99 # Parent c025fc91d497690af582f24ce6003852fa717172 Expunge Clojure diff -r c025fc91d497 -r f4ede9fed310 .hgignore --- 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 diff -r c025fc91d497 -r f4ede9fed310 .lispwords --- /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) diff -r c025fc91d497 -r f4ede9fed310 LICENSE.markdown --- /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. diff -r c025fc91d497 -r f4ede9fed310 Makefile --- /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 diff -r c025fc91d497 -r f4ede9fed310 README.markdown --- 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. diff -r c025fc91d497 -r f4ede9fed310 package.lisp --- /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)) diff -r c025fc91d497 -r f4ede9fed310 project.clj --- 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"]]) diff -r c025fc91d497 -r f4ede9fed310 rosalind.asd --- /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 " + :maintainer "Steve Losh " + + :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"))))) + diff -r c025fc91d497 -r f4ede9fed310 src/problems.lisp --- /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) + + diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p001.clj --- 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")) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p002.clj --- 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")) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p003.clj --- 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"))) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p004.clj --- 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")) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p005.clj --- 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"))) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p006.clj --- 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")) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p007.clj --- 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")) diff -r c025fc91d497 -r f4ede9fed310 src/rosalind/p008.clj --- 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")) diff -r c025fc91d497 -r f4ede9fed310 src/utils.lisp --- /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))) diff -r c025fc91d497 -r f4ede9fed310 vendor/make-quickutils.lisp --- /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") diff -r c025fc91d497 -r f4ede9fed310 vendor/quickutils-package.lisp --- /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) + diff -r c025fc91d497 -r f4ede9fed310 vendor/quickutils.lisp --- /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 ;;;;