# HG changeset patch # User Steve Losh # Date 1541207300 14400 # Node ID bd06f66ba88f4c8abf88dbe7b828483ac161ad02 # Parent 0ea8cfbf45ce347cdf67113d8e483c92fa9cedb1 More problems diff -r 0ea8cfbf45ce -r bd06f66ba88f .lispwords --- 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) diff -r 0ea8cfbf45ce -r bd06f66ba88f rosalind.asd --- 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"))))))) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/dna.lisp --- 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") diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/fib.lisp --- /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) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/fibd.lisp --- /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) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/iev.lisp --- /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) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/iprb.lisp --- /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) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/perm.lisp --- /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) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/prot.lisp --- /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) diff -r 0ea8cfbf45ce -r bd06f66ba88f src/problems/subs.lisp --- /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) + diff -r 0ea8cfbf45ce -r bd06f66ba88f src/utils.lisp --- 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)))) diff -r 0ea8cfbf45ce -r bd06f66ba88f vendor/make-quickutils.lisp --- 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 ) diff -r 0ea8cfbf45ce -r bd06f66ba88f vendor/quickutils.lisp --- 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 ;;;;