--- a/.lispwords Thu Nov 01 21:59:30 2018 -0400
+++ b/.lispwords Fri Nov 02 21:08:20 2018 -0400
@@ -1,1 +1,3 @@
+(1 codon-case)
+(1 labels-memoized)
(4 define-problem)
--- a/rosalind.asd Thu Nov 01 21:59:30 2018 -0400
+++ b/rosalind.asd Fri Nov 02 21:08:20 2018 -0400
@@ -11,9 +11,10 @@
:depends-on (
:1am
+ :alexandria
:iterate
:losh
- :alexandria
+ :str
)
@@ -29,5 +30,12 @@
(:file "rna")
(:file "revc")
(:file "gc")
- (:file "hamm")))))))
+ (:file "hamm")
+ (:file "prot")
+ (:file "perm")
+ (:file "fib")
+ (:file "subs")
+ (:file "iprb")
+ (:file "iev")
+ (:file "fibd")))))))
--- a/src/problems/dna.lisp Thu Nov 01 21:59:30 2018 -0400
+++ b/src/problems/dna.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -21,4 +21,4 @@
(gethash #\G results 0)
(gethash #\T results 0))))
-(problem-dna "AT")
+;; (problem-dna "AT")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/fib.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,70 @@
+(in-package :rosalind)
+
+;; A sequence is an ordered collection of objects (usually numbers), which are
+;; allowed to repeat. Sequences can be finite or infinite. Two examples are the
+;; finite sequence (π,−2–√,0,π) and the infinite sequence of odd numbers
+;; (1,3,5,7,9,…). We use the notation an to represent the n-th term of
+;; a sequence.
+;;
+;; A recurrence relation is a way of defining the terms of a sequence with
+;; respect to the values of previous terms. In the case of Fibonacci's rabbits
+;; from the introduction, any given month will contain the rabbits that were
+;; alive the previous month, plus any new offspring. A key observation is that
+;; the number of offspring in any month is equal to the number of rabbits that
+;; were alive two months prior. As a result, if Fn represents the number of
+;; rabbit pairs alive after the n-th month, then we obtain the Fibonacci
+;; sequence having terms Fn that are defined by the recurrence relation
+;; Fn=Fn−1+Fn−2 (with F1=F2=1 to initiate the sequence). Although the sequence
+;; bears Fibonacci's name, it was known to Indian mathematicians over two
+;; millennia ago.
+;;
+;; When finding the n-th term of a sequence defined by a recurrence relation, we
+;; can simply use the recurrence relation to generate terms for progressively
+;; larger values of n. This problem introduces us to the computational technique
+;; of dynamic programming, which successively builds up solutions by using the
+;; answers to smaller cases.
+;;
+;; Given: Positive integers n≤40 and k≤5
+;;
+;; Return: The total number of rabbit pairs that will be present after n months,
+;; if we begin with 1 pair and in each generation, every pair of
+;; reproduction-age rabbits produces a litter of k rabbit pairs (instead of only
+;; 1 pair).
+
+(define-problem fib (data stream)
+ "5 3"
+ "19"
+ (let ((months (read data))
+ (litter-size (read data)))
+ ;; The problem description is written incorrectly. They say "total number
+ ;; of rabbit pairs … after n months", but if we list out the values for
+ ;; their sample parameters, we can see their answer is wrong:
+ ;;
+ ;; MONTHS | BREEDING | TOTAL
+ ;; ELAPSED | PAIRS | PAIRS
+ ;; ---------------------------
+ ;; 0 | 0 | 1
+ ;; 1 | 1 | 1
+ ;; 2 | 1 | 4
+ ;; 3 | 4 | 7
+ ;; 4 | 7 | 19 <-- their answer
+ ;; 5 | 19 | 40 <-- actual answer
+ ;;
+ ;; Their problem is they're treating the Fibonacci numbers Fₙ as "number
+ ;; of rabbits after n months", but really Fₙ means "number of rabbits at
+ ;; the beginning of the nth (ordinal) month". This can even be seen in
+ ;; their own diagram at the top of the page -- months 1 and 2 both have
+ ;; 1 pair each. If we start in month 1, and let 2 months elapse, we end up
+ ;; at F₃, not F₂.
+ ;;
+ ;; So we'll just decrement months by one. Sigh.
+ (iterate
+ (with breeding = 0)
+ (with total = 1)
+ (repeat (1- months))
+ (psetf breeding total
+ total (+ total (* breeding litter-size)))
+ (finally (return total)))))
+
+;; (problem-fib "5 3")
+;; (solve fib)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/fibd.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,53 @@
+(in-package :rosalind)
+
+;; Recall the definition of the Fibonacci numbers from “Rabbits and Recurrence
+;; Relations”, which followed the recurrence relation Fn=Fn−1+Fn−2 and assumed
+;; that each pair of rabbits reaches maturity in one month and produces
+;; a single pair of offspring (one male, one female) each subsequent month.
+;;
+;; Our aim is to somehow modify this recurrence relation to achieve a dynamic
+;; programming solution in the case that all rabbits die out after a fixed
+;; number of months. See Figure 4 for a depiction of a rabbit tree in which
+;; rabbits live for three months (meaning that they reproduce only twice before
+;; dying).
+;;
+;; Given: Positive integers n≤100 and m≤20.
+;;
+;; Return: The total number of pairs of rabbits that will remain after the n-th
+;; month if all rabbits live for m months.
+
+(define-problem fibd (data stream)
+ "6 3"
+ "4"
+ (iterate
+ (with months = (read data))
+ (with lifespan = (read data))
+
+ (with population = (make-array 16 :adjustable t :fill-pointer 1 :initial-element nil))
+ (with births = (make-array 16 :adjustable t :fill-pointer 1 :initial-element nil))
+
+ ;; the hand of god reaches down and creates a baby rabbit from the dust
+ (initially (vector-push-extend 1 population)
+ (vector-push-extend 1 births))
+
+ (for month :from 2 :to months)
+
+ (labels ((ref (array index)
+ (if (plusp index)
+ (aref array index)
+ 0))
+ (breeding (month)
+ (- (ref population (- month 1))
+ (deaths month)))
+ (births (month)
+ (breeding (- month 1)))
+ (deaths (month)
+ (ref births (- month lifespan)))
+ (population (month)
+ (+ (breeding month)
+ (births month))))
+ (vector-push-extend (returning-final (population month)) population)
+ (vector-push-extend (births month) births))))
+
+;; (problem-fibd "6 3")
+;; (solve fibd)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/iev.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,56 @@
+(in-package :rosalind)
+
+;; For a random variable X taking integer values between 1 and n, the expected
+;; value of X is E(X)=∑nk=1k×Pr(X=k). The expected value offers us a way of
+;; taking the long-term average of a random variable over a large number of
+;; trials.
+;;
+;; As a motivating example, let X be the number on a six-sided die. Over a large
+;; number of rolls, we should expect to obtain an average of 3.5 on the die
+;; (even though it's not possible to roll a 3.5). The formula for expected value
+;; confirms that E(X)=∑6k=1k×Pr(X=k)=3.5.
+;;
+;; More generally, a random variable for which every one of a number of equally
+;; spaced outcomes has the same probability is called a uniform random variable
+;; (in the die example, this "equal spacing" is equal to 1). We can generalize
+;; our die example to find that if X is a uniform random variable with minimum
+;; possible value a and maximum possible value b, then E(X)=a+b2. You may also
+;; wish to verify that for the dice example, if Y is the random variable
+;; associated with the outcome of a second die roll, then E(X+Y)=7.
+;;
+;; Given: Six nonnegative integers, each of which does not exceed 20,000. The
+;; integers correspond to the number of couples in a population possessing each
+;; genotype pairing for a given factor. In order, the six given integers
+;; represent the number of couples having the following genotypes:
+;;
+;; AA-AA
+;; AA-Aa
+;; AA-aa
+;; Aa-Aa
+;; Aa-aa
+;; aa-aa
+;;
+;; Return: The expected number of offspring displaying the dominant phenotype in
+;; the next generation, under the assumption that every couple has exactly two
+;; offspring.
+
+(define-problem iev (data stream)
+ "1 0 0 1 0 1"
+ "3.5"
+ (let* ((dd (read data))
+ (dh (read data))
+ (dr (read data))
+ (hh (read data))
+ (hr (read data))
+ (rr (read data)))
+ (format nil "~,4F"
+ ;; It's just a weighted average…
+ (* 2 (+ (* dd 1)
+ (* dh 1)
+ (* dr 1)
+ (* hh 3/4)
+ (* hr 1/2)
+ (* rr 0))))))
+
+;; (problem-iev)
+;; (solve iev)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/iprb.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,71 @@
+(in-package :rosalind)
+
+;; Probability is the mathematical study of randomly occurring phenomena. We
+;; will model such a phenomenon with a random variable, which is simply
+;; a variable that can take a number of different distinct outcomes depending on
+;; the result of an underlying random process.
+;;
+;; For example, say that we have a bag containing 3 red balls and 2 blue balls.
+;; If we let X represent the random variable corresponding to the color of
+;; a drawn ball, then the probability of each of the two outcomes is given by
+;; Pr(X=red)=35 and Pr(X=blue)=25
+;;
+;; Random variables can be combined to yield new random variables. Returning to
+;; the ball example, let Y model the color of a second ball drawn from the bag
+;; (without replacing the first ball). The probability of Y being red depends on
+;; whether the first ball was red or blue. To represent all outcomes of X and Y,
+;; we therefore use a probability tree diagram. This branching diagram
+;; represents all possible individual probabilities for X and Y, with outcomes
+;; at the endpoints ("leaves") of the tree. The probability of any outcome is
+;; given by the product of probabilities along the path from the beginning of
+;; the tree; see Figure 2 for an illustrative example.
+;;
+;; An event is simply a collection of outcomes. Because outcomes are distinct,
+;; the probability of an event can be written as the sum of the probabilities of
+;; its constituent outcomes. For our colored ball example, let A be the event "Y
+;; is blue." Pr(A) is equal to the sum of the probabilities of two different
+;; outcomes: Pr(X=blue and Y=blue)+Pr(X=red and Y=blue), or 310+110=25 (see
+;; Figure 2 above).
+;;
+;; Given: Three positive integers k, m, and n, representing a population
+;; containing k+m+n organisms: k individuals are homozygous dominant for
+;; a factor, m are heterozygous, and n are homozygous recessive.
+;;
+;; Return: The probability that two randomly selected mating organisms will
+;; produce an individual possessing a dominant allele (and thus displaying the
+;; dominant phenotype). Assume that any two organisms can mate.
+
+(define-problem iprb (data stream)
+ "2 2 2"
+ "0.78333"
+ (let* ((d (read data))
+ (h (read data))
+ (r (read data))
+ (n (+ d h r)))
+ ;; We could expand this all into a giant equation and cancel it out, but
+ ;; let's just let the computer do the busywork.
+ (flet ((p-same (x also-x)
+ (declare (ignore also-x))
+ ;; P({X X}) = X/N * (X-1)/(N-1)
+ ;; = X(X-1) / N(N-1)
+ ;; = X²-X / N²-N
+ (/ (- (* x x) x)
+ (- (* n n) n)))
+ (p-diff (x y)
+ ;; P({X Y}) = P(X, Y) + P(Y, X)
+ ;; = X/N * Y/N-1 + Y/N * X/N-1
+ ;; = XY/N(N-1) + YX/N(N-1)
+ ;; = 2XY/N(N-1)
+ ;; = 2XY/N²-N
+ (/ (* 2 x y)
+ (- (* n n) n))))
+ (format nil "~,5F"
+ (+ (* (p-same d d) 1) ;; AA AA
+ (* (p-diff d h) 1) ;; AA Aa
+ (* (p-diff d r) 1) ;; AA aa
+ (* (p-same h h) 3/4) ;; Aa Aa
+ (* (p-diff h r) 1/2) ;; Aa aa
+ (* (p-same r r) 0)))))) ;; aa aa
+
+;; (problem-iprb)
+;; (solve iprb)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/perm.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,34 @@
+(in-package :rosalind)
+
+;; A permutation of length n is an ordering of the positive integers {1,2,…,n}.
+;; For example, π=(5,3,2,1,4) is a permutation of length 5.
+;;
+;; Given: A positive integer n≤7
+;;
+;; Return: The total number of permutations of length n, followed by a list of
+;; all such permutations (in any order).
+
+(defparameter *input-perm* "3")
+
+(defparameter *output-perm* "6
+1 2 3
+1 3 2
+2 1 3
+2 3 1
+3 1 2
+3 2 1")
+
+
+(define-problem perm (data string)
+ *input-perm*
+ *output-perm*
+ (let* ((n (parse-integer data))
+ (count (factorial n))
+ (perms (permutations (alexandria:iota n :start 1))))
+ (format nil "~D~%~{~A~^~%~}"
+ count
+ ;; sort to ensure consistent output for the unit test
+ (sort (mapcar (curry #'str:join " ") perms) #'string<))))
+
+;; (problem-perm "3")
+;; (solve perm)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/prot.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,22 @@
+(in-package :rosalind)
+
+;; The 20 commonly occurring amino acids are abbreviated by using 20 letters
+;; from the English alphabet (all letters except for B, J, O, U, X, and Z).
+;; Protein strings are constructed from these 20 symbols. Henceforth, the term
+;; genetic string will incorporate protein strings along with DNA strings and
+;; RNA strings.
+;;
+;; The RNA codon table dictates the details regarding the encoding of specific
+;; codons into the amino acid alphabet.
+;;
+;; Given: An RNA string s corresponding to a strand of mRNA (of length at most
+;; 10 kbp).
+;;
+;; Return: The protein string encoded by s.
+
+(define-problem prot (data string)
+ "AUGGCCAUGGCGCCCAGAACUGAGAUCAAUAGUACCCGUAUUAACGGGUGA"
+ "MAMAPRTEINSTRING"
+ (translate data))
+
+;; (solve prot)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/subs.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -0,0 +1,43 @@
+(in-package :rosalind)
+
+;; Given two strings s and t, t is a substring of s if t is contained as
+;; a contiguous collection of symbols in s (as a result, t must be no longer
+;; than s).
+;;
+;; The position of a symbol in a string is the total number of symbols found to
+;; its left, including itself (e.g., the positions of all occurrences of 'U' in
+;; "AUGCUUCAGAAAGGUCUUACG" are 2, 5, 6, 15, 17, and 18). The symbol at position
+;; i of s is denoted by s[i].
+;;
+;; A substring of s can be represented as s[j:k], where j and k represent the
+;; starting and ending positions of the substring in s; for example, if
+;; s = "AUGCUUCAGAAAGGUCUUACG", then s[2:5] = "UGCU".
+;;
+;; The location of a substring s[j:k] is its beginning position j; note that
+;; t will have multiple locations in s if it occurs more than once as
+;; a substring of s (see the Sample below).
+;;
+;; Given: Two DNA strings s and t (each of length at most 1 kbp).
+;;
+;; Return: All locations of t as a substring of s.
+
+(defparameter *input-subs* "GATATATGCATATACTT
+ATAT")
+
+(defparameter *output-subs* "2 4 10")
+
+
+(define-problem subs (data stream)
+ *input-subs*
+ *output-subs*
+ (let ((haystack (read-line data))
+ (needle (read-line data)))
+ (iterate
+ (for pos :seed -1 :then (search needle haystack :start2 (1+ pos)))
+ (while pos)
+ (collect (1+ pos) :into result)
+ (finally (return (str:join " " result))))))
+
+;; (problem-subs)
+(solve subs)
+
--- a/src/utils.lisp Thu Nov 01 21:59:30 2018 -0400
+++ b/src/utils.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -57,6 +57,130 @@
sequence2)
result))
+(defun factorial (x)
+ (check-type x (integer 0))
+ (iterate (for i :from 1 :to x)
+ (multiplying i)))
+
+(defun permutations (items)
+ (gathering (alexandria:map-permutations #'gather items)))
+
+
+;;;; Iterate ------------------------------------------------------------------
+(defmacro-driver (FOR var SEED seed THEN then)
+ "Bind `var` to `seed` initially, then to `then` on every iteration.
+
+ This differs from `(FOR … FIRST … THEN …)` and `(FOR … INITIALLY … THEN …)`
+ because `then` is evaluated on every iteration, *including* the first.
+
+ Example:
+
+ (iterate
+ (repeat 3)
+ (for x :first 0 :then (1+ x))
+ (for y :initially 0 :then (1+ y))
+ (for z :seed 0 :then (1+ z))
+ (collect (list x y z)))
+ ; =>
+ ((0 0 1)
+ (1 1 2)
+ (2 2 3))
+
+ "
+ (let ((kwd (if generate 'generate 'for)))
+ `(progn
+ (,kwd ,var :next ,then)
+ (initially (setf ,var ,seed)))))
+
+(defmacro returning-final (form)
+ "Evaluate `form` each iteration and return its final value from the `iterate`.
+
+ Example:
+
+ (iterate
+ (for i :from 1 :to 4)
+ (collect (returning-final i) :into l)
+ (print l))
+ ; =>
+ (1)
+ (1 2)
+ (1 2 3)
+ (1 2 3 4)
+ 4
+
+ "
+ (with-gensyms (result)
+ `(progn
+ (with ,result)
+ (finally (return ,result))
+ (setf ,result ,form))))
+
+
+;;;; Translation --------------------------------------------------------------
+(defmacro codon-case ((vector index) &rest clauses)
+ ;; Compiles a giant list of clauses into a tree of ECASEs.
+ ;;
+ ;; Each codon will have at most 3 ECASEs to pass through. Each ECASE has at
+ ;; most four options, so in the worst case we end up with 3 * 4 = 12
+ ;; comparisons instead of 64.
+ ;;
+ ;; If we ever convert bases to vectors of (unsigned-byte 2)s we could
+ ;; potentially use a lookup table here, e.g.:
+ ;;
+ ;; (aref +amino-acids+ (+ x (ash y 2) (ash z 4)))
+ (alexandria:once-only (vector index)
+ (alexandria:with-gensyms (x y z)
+ `(let ((,x (aref ,vector ,index))
+ (,y (aref ,vector (+ ,index 1)))
+ (,z (aref ,vector (+ ,index 2))))
+ ,(labels ((strip (clauses)
+ (if (= 1 (length (caar clauses)))
+ (cadar clauses)
+ (iterate (for (head body) :in clauses)
+ (collect (list (subseq head 1) body)))))
+ (split (clauses)
+ (-<> clauses
+ (group-by (rcurry #'aref 0) <> :key #'first)
+ (iterate (for (k v) :in-hashtable <>)
+ (collect (list k (strip v)))))))
+ (recursively ((clauses (split clauses))
+ (codons (list x y z))
+ (i 0))
+ `(ecase ,(first codons)
+ ,@(iterate (for (k remaining) :in clauses)
+ (collect `(,k ,(if (atom remaining)
+ remaining
+ (recur (split remaining)
+ (rest codons)
+ (1+ i)))))))))))))
+
+(defun codon-to-protein (vector index)
+ "Return the amino acid encoded by the codon in `vector` at `index`."
+ (codon-case (vector index)
+ ("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)))
+
+(defun translate (rna &key (start 0))
+ "Translate a string of RNA bases into a protein string of amino acids."
+ (iterate (for i :from (search "AUG" rna :start2 start) :by 3)
+ (for protein = (codon-to-protein rna i))
+ (while protein)
+ (collect protein :result-type 'string)))
+
;;;; File Formats -------------------------------------------------------------
(defmacro-driver (FOR vars IN-FASTA source)
@@ -97,7 +221,7 @@
(defmacro define-problem (name (arg type) sample-input sample-output &body body)
(let ((symbol (symb 'problem- name)))
`(progn
- (defun ,symbol (,arg)
+ (defun ,symbol (&optional (,arg ,sample-input))
(setf ,arg ,(ecase type
(string `(ensure-string ,arg))
(stream `(ensure-stream ,arg))))
--- a/vendor/make-quickutils.lisp Thu Nov 01 21:59:30 2018 -0400
+++ b/vendor/make-quickutils.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -8,6 +8,7 @@
:curry
:rcurry
:with-gensyms
+ :once-only
:symb
)
--- a/vendor/quickutils.lisp Thu Nov 01 21:59:30 2018 -0400
+++ b/vendor/quickutils.lisp Fri Nov 02 21:08:20 2018 -0400
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :RCURRY :WITH-GENSYMS :SYMB) :ensure-package T :package "ROSALIND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :RCURRY :WITH-GENSYMS :ONCE-ONLY :SYMB) :ensure-package T :package "ROSALIND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "ROSALIND.QUICKUTILS")
@@ -16,7 +16,7 @@
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :CURRY :RCURRY
:STRING-DESIGNATOR :WITH-GENSYMS
- :MKSTR :SYMB))))
+ :ONCE-ONLY :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`,
@@ -144,6 +144,45 @@
`(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)))))
+
+
(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.
@@ -161,6 +200,6 @@
(values (intern (apply #'mkstr args))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose curry rcurry with-gensyms with-unique-names symb)))
+ (export '(compose curry rcurry with-gensyms with-unique-names once-only symb)))
;;;; END OF quickutils.lisp ;;;;