# HG changeset patch # User Steve Losh # Date 1545001303 18000 # Node ID b1baea60c24f542f3430f0d81a884c7374da4faa # Parent 5d71b5f0dfb5589f7b64846cb5201aba2a8030d9# Parent 1d0852c279f76e87ce6b848ea4ee8ff1896de4eb Merge. diff -r 1d0852c279f7 -r b1baea60c24f .lispwords --- a/.lispwords Sat Dec 15 16:56:57 2018 -0500 +++ b/.lispwords Sun Dec 16 18:01:43 2018 -0500 @@ -1,3 +1,5 @@ (1 codon-case) (1 labels-memoized) (4 define-problem) +(1 do-sum Σ) +(1 do-product Π) diff -r 1d0852c279f7 -r b1baea60c24f rosalind.asd --- a/rosalind.asd Sat Dec 15 16:56:57 2018 -0500 +++ b/rosalind.asd Sun Dec 16 18:01:43 2018 -0500 @@ -24,6 +24,8 @@ :1am :alexandria :cl-digraph + :cl-ppcre + :drakma :iterate :losh :str diff -r 1d0852c279f7 -r b1baea60c24f src/problems/grph.lisp --- a/src/problems/grph.lisp Sat Dec 15 16:56:57 2018 -0500 +++ b/src/problems/grph.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -1,6 +1,7 @@ (in-package :rosalind) -(defparameter *input-grph* ">Rosalind_0498 +(defparameter *input-grph* + ">Rosalind_0498 AAATAAA >Rosalind_2391 AAATTTT @@ -11,8 +12,9 @@ >Rosalind_5013 GGGTGGG") -(defparameter *output-grph* "Rosalind_0498 Rosalind_2391 -Rosalind_0498 Rosalind_0442 +(defparameter *output-grph* + "Rosalind_0498 Rosalind_0442 +Rosalind_0498 Rosalind_2391 Rosalind_2391 Rosalind_2323 ") @@ -48,9 +50,10 @@ data) ;; (ql:quickload :cl-digraph.dot) ;; (digraph.dot:draw graph) - (with-output-to-string (s) - (iterate (for (l . r) :in (digraph:edges graph)) - (format s "~A ~A~%" l r))))) + (-<> (iterate (for (l . r) :in (digraph:edges graph)) + (collect (format nil "~A ~A~%" l r))) + (sort <> #'string<) + (str:join nil <>)))) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/lexf.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/problems/lexf.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -0,0 +1,42 @@ +(in-package :rosalind) + +(defparameter *input-lexf* + "A C G T +2") + +(defparameter *output-lexf* + "AA +AC +AG +AT +CA +CC +CG +CT +GA +GC +GG +GT +TA +TC +TG +TT +") + + +(define-problem lexf (data stream) + *input-lexf* + *output-lexf* + (let* ((alphabet (sort (remove #\space (read-line data)) #'char<)) + (n (read data)) + (string (make-string n))) + (with-output-to-string (s) + (recursively ((n n) + (i 0)) + (if (zerop n) + (progn (write-string string s) + (terpri s)) + (map nil (lambda (ch) + (setf (aref string i) ch) + (recur (1- n) (1+ i))) + alphabet)))))) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/lgis.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/problems/lgis.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -0,0 +1,132 @@ +(in-package :rosalind) + +(defparameter *input-lgis* + "5 +5 1 4 2 3") + +(defparameter *output-lgis* + "1 2 3 +5 4 3") + + +;; There's an nlog(n) algorithm described at Wikipedia: +;; https://en.wikipedia.org/wiki/Longest_increasing_subsequence#Efficient_algorithms +;; +;; Unfortunately it's pretty painful to read because they insist on using some +;; strange programming language that uses indentation for control flow but +;; doesn't have .length on arrays, doesn't have adjustable vectors, etc. What +;; even is this language? And of course they use one-letter names for +;; everything, because fuck you. At least they describe the contents of each +;; auxiliary array precisely. That's nice. +;; +;; Before we start: let's define the term "tail" to mean the final element of +;; a subsequence. +;; +;; Let's also pretend we're dealing with the < predicate instead of an arbitrary +;; one for this description, just to make things a little easier to talk about. +;; +;; We set up two arrays before we start: +;; +;; * TAIL-INDEXES: An array that contains indexes of tails. To be more precise: +;; TAIL-INDEXES[n] contains the index of the *minimum* tail for a subsequence +;; of length N. +;; * PREDECESSORS: PREDECESSORS[i] stores the index of the predecessor of +;; SEQ[i] in the resulting subsequence. +;; +;; As an example (entries marked with _ are irrelevant, and we'll use characters +;; as values for clarity): +;; +;; SEQUENCE [a, d, c, b] +;; (indexes) 0 1 2 3 +;; +;; TAIL-INDEXES [_, 0, 2] +;; PREDECESSORS [NIL, _, _, 0] +;; RESULT [a, b] +;; +;; A few things to notice: +;; +;; * TAIL-INDEXES[0] is garbage, because a subsequence of length zero doesn't +;; *have* a tail. We could do 1- everywhere to save a word but come on. +;; * TAIL-INDEXES[1] is 0, the index of the tail of the subsequence of length 1 is 0 (a). +;; * TAIL-INDEXES[2] is 3, the index of the tail of the subsequence of length 2 is 3 (b). +;; * TAIL-INDEXES only has elements 0 (garbage), 1, and 2, because the longest +;; increasing subsequence is only 2 elements long. We have extendable vectors +;; in Lisp, let's use them instead of doing all the bookkeeping by hand. +;; * PREDECESSORS[3] is 0, because in the final result the predecessor of SEQ[3] (b) is SEQ[0] (a). +;; * PREDECESSORS[0] is NIL, because in the final result SEQ[0] (a) is the first element. +;; +;; Essentially the algorithm goes like this: +;; +;; * Handle the first element by hand. +;; * Iterate over the sequence: +;; * Bisect TAIL-INDEXES at each iteration to find where the next element fits. +;; * Update or extend TAIL-INDEXES with each successive element. +;; * Extend PREDECESSORS to record the tail index before to the one we just used. +;; * Once we've filled in the arrays, we can walk through PREDECESSORS, starting +;; at the final tail index. + +(defun longest-monotonic-subsequence + (sequence predicate &key (result-type 'list)) + "Return the longest monotonic subsequence of `sequence`. + + `predicate` must be a comparison predicate like `<` or `>=`. + + If there are multiple longest sequences, an arbitrary one is returned + + Examples: + + (longest-monotonic-subsequence '() #'<) ; => () + (longest-monotonic-subsequence '(1) #'<) ; => (1) + (longest-monotonic-subsequence '(2 1) #'<) ; => (1) or (2) + (longest-monotonic-subsequence '(1 2) #'<) ; => (1 2) + (longest-monotonic-subsequence '(2 1) #'>) ; => (2 1) + (longest-monotonic-subsequence '(3 1 1 2) #'<) ; => (1 2) + (longest-monotonic-subsequence '(3 1 1 2) #'<=) ; => (1 1 2) + (longest-monotonic-subsequence '(3 1 1 2) #'>=) ; => (3 1 1) + (longest-monotonic-subsequence \"hello, world!\" #'char< + :result-type 'string) + ; => \"helor\" + + " + (let* ((sequence (coerce sequence 'vector)) + (n (length sequence)) + (tail-indexes (make-array (1+ n) :fill-pointer 1)) + (predecessors (make-array n :fill-pointer 0))) + (coerce + (if (zerop n) + (list) ; just bail early on this edge case + (progn + ;; Element 0 is always the first tail. + (vector-push-extend 0 tail-indexes) + (vector-push-extend nil predecessors) + (iterate + (for value :in-vector sequence :with-index i :from 1) + (for (values nil tail-index) = + (bisect-right predicate tail-indexes value + :start 1 ; ignore the garbage + :key (curry #'aref sequence))) ; deref when bisecting + (if tail-index + (progn + ;; Found a more minimal tail for existing subseq + (setf (aref tail-indexes tail-index) i) + (vector-push-extend (aref tail-indexes (1- tail-index)) + predecessors)) + (progn + ;; Found the largest tail so far, extend our subseqs + (vector-push-extend (vector-last tail-indexes) predecessors) + (vector-push-extend i tail-indexes)))) + (iterate + (for i :first (vector-last tail-indexes) :then (aref predecessors i)) + (while i) + (collect (aref sequence i) :at :beginning)))) + result-type))) + + +(define-problem lgis (data stream) + *input-lgis* + *output-lgis* + (let* ((size (read data)) + (elements (gimme size (read data)))) + (with-output-to-string (s) + (format s "~{~D~^ ~}~%" (longest-monotonic-subsequence elements #'<)) + (format s "~{~D~^ ~}" (longest-monotonic-subsequence elements #'>))))) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/lia.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/problems/lia.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -0,0 +1,109 @@ +(in-package :rosalind) + +;; When a heterozygous organism mates, its offspring have a 50% chance to be +;; heterozygous themselves, *regardless of what the other mate happens to be*: +;; +;; A a A a A a +;; A AA Aa A AA Aa a aA aa +;; A AA Aa a Aa aa a aA aa +;; +;; Because everyone breeds with an Aa Bb mate, we don't need to worry about +;; tracking populations along the way. Every child has a 1/2 chance of being +;; Aa, and likewise a 1/2 chance of being Bb. +;; +;; Because A's and B's are independent, this means there's a 1/2 * 1/2 = 1/4 +;; chance of any given child being Aa Bb. + +(defmacro do-sum ((var from to) &body body) + "Sum `body` with `var` iterating over `[from, to]`. + + It's just Σ: + + to + === + \ + > body + / + === + n = from + + " + (once-only (to) + (with-gensyms (result) + `(do ((,var ,from (1+ ,var)) + (,result 0)) + ((> ,var ,to) ,result) + (incf ,result (progn ,@body)))))) + +(defmacro do-product ((var from to) &body body) + "Multiply `body` with `var` iterating over `[from, to]`. + + It's just Π: + + to + ===== + | | + | | body + | | + n = from + + " + (once-only (to) + (with-gensyms (result) + `(do ((,var ,from (1+ ,var)) + (,result 1)) + ((> ,var ,to) ,result) + (setf ,result (* ,result (progn ,@body))))))) + + +(defmacro Σ (bindings &body body) ;; lol + `(do-sum ,bindings ,@body)) + +(defmacro Π (bindings &body body) ;; lol + `(do-product ,bindings ,@body)) + + +(defun binomial-coefficient (n k) + "Return `n` choose `k`." + ;; https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula + (Π (i 1 k) + (/ (- (1+ n) i) i))) + +(defun bernoulli-exactly (successes trials success-probability) + "Return the probability of exactly `successes` in `trials` Bernoulli trials. + + Returns the probability of getting exactly `n` successes out of `trials` + Bernoulli trials with `success-probability`. + + " + ;; For a group of N trials with success/failure probabilities s/f, any given + ;; ordering of exactly S successes and F failures will have probability: + ;; + ;; s * s * s * … * f * f * f + ;; + ;; There are N choose S possible orderings (or N choose F, it doesn't matter), + ;; so we just sum up the probabilities of all of them. + (let ((failures (- trials successes)) + (failure-probability (- 1 success-probability))) + (* (binomial-coefficient trials successes) + (expt success-probability successes) + (expt failure-probability failures)))) + +(defun bernoulli-at-least (successes trials success-probability) + "Return the probability of at least `successes` in `trials` Bernoulli trials. + + Returns the probability of getting at least `n` successes out of `trials` + Bernoulli trials with `success-probability`. + + " + ;; P(≥S) = P(=S) + P(=S+1) + … + P(N) + (Σ (n successes trials) + (bernoulli-exactly n trials success-probability))) + +(define-problem lia (data stream) + "2 1" + "0.684" + (let* ((generations (read data)) + (target (read data)) + (population (expt 2 generations))) + (format nil "~,3F" (bernoulli-at-least target population 1/4)))) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/mprt.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/problems/mprt.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -0,0 +1,68 @@ +(in-package :rosalind) + +;; This was pretty simple, except for discovering that cl-ppcre's all-matches +;; function skips overlapping matches. Otherwise we just convert the motif to +;; a regex and handle grabbing the data from Uniprot (which is straightforward +;; but can be slow). + +(defparameter *input-mprt* + "A2Z669 +B5ZC00 +P07204_TRBM_HUMAN +P20840_SAG1_YEAST") + +(defparameter *output-mprt* + "B5ZC00 +85 118 142 306 395 +P07204_TRBM_HUMAN +47 115 116 382 409 +P20840_SAG1_YEAST +79 109 135 248 306 348 364 402 485 501 614 +") + +(defparameter *motif-n-glycosylation* "N{P}[ST]{P}") + +(defun motif-to-regex (motif) + "Turn a protein motif shorthand into a PPCRE scanner." + (-<> motif + ;; All we have to do is turn {X} into [^X] and compile. + (ppcre:regex-replace-all "[{]" <> "[^") + (substitute #\] #\} <>) + ppcre:create-scanner)) + +(defun all-matches-dammit (regex target-string) + "Return a list of start and end positions of all matches of `regex` on `target-string`. + + Unlike `ppcre:all-matches` this will return ALL matches, even if they're + overlapping. Example: + + (all-matches-dammit \"a..\" \"aabc\") + ; => + ; (0 3 1 4) + + (ppcre:all-matches \"a..\" \"aabc\") + ; => + ; (0 3) ; dammit + + " + ;; cl-ppcre + (iterate + (with i = 0) + (for (values start end) = (ppcre:scan regex target-string :start i)) + (while start) + (collect start) + (collect end) + (setf i (1+ start)))) + + +(define-problem mprt (data stream) + *input-mprt* + *output-mprt* + (with-output-to-string (s) + (iterate + (with n-glycosylation = (motif-to-regex *motif-n-glycosylation*)) + (for id :in-stream data :using #'read-line) + (for (nil . protein) = (uniprot id)) + (for matches = (all-matches-dammit n-glycosylation protein)) + (when matches + (format s "~A~%~{~D~*~^ ~}~%" id (mapcar #'1+ matches)))))) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/orf.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/problems/orf.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -0,0 +1,34 @@ +(in-package :rosalind) + +(defparameter *input-orf* + ">Rosalind_99 +AGCCATGTAGCTAACTCAGGTTACATGGGGATGACCCCGCGACTTGGATTAGAGTCTCTTTTGGAATAAGCCTGAATGATCCGAGTAGCATCTCAG") + +(defparameter *output-orf* + "M +MTPRLGLESLLE +MGMTPRLGLESLLE +MLLGSFRLIPKETLIQVAGSSPCNLS") + + +(defun translate-all (rna) + "Return all possible proteins that can be translated from `rna`." + (iterate + (for start :first 0 :then (1+ protein-start)) + (for (values protein protein-start) = (translate rna :start start)) + (while protein) + (collect protein))) + +(define-problem orf (data stream) + *input-orf* + *output-orf* + (let* ((dna (cdr (first (read-fasta-into-alist data)))) + (rna1 (transcribe dna)) + (rna2 (transcribe (reverse-complement dna)))) + (-<> (append (translate-all rna1) + (translate-all rna2)) + (remove-duplicates <> :test #'string=) + (sort <> #'< :key #'length) + (format nil "~{~A~^~%~}" <>)))) + + diff -r 1d0852c279f7 -r b1baea60c24f src/problems/prot.lisp --- a/src/problems/prot.lisp Sat Dec 15 16:56:57 2018 -0500 +++ b/src/problems/prot.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -58,11 +58,29 @@ ("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))) + "Translate a string of RNA bases into a protein string of amino acids. + + `rna` will be searched (beginning at `start`) for a start codon and + translation will proceed from there. If no start codon occurs after `start` + then `nil` will be returned. + + Once a start codon has been found, translation proceeds to the next stop + codon. If no stop codon is present, `nil` will be returned. + + Otherwise two values are returned: the protein string and the index into `rna` + where it started. + + " + (when-let ((start (search "AUG" rna :start2 start))) + (values + (iterate (with limit = (- (length rna) 3)) + (for i :from start :by 3) + (when (> i limit) + (return-from translate (values nil nil))) + (for protein = (codon-to-protein rna i)) + (while protein) + (collect protein :result-type 'string)) + start))) (define-problem prot (data string) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/revc.lisp --- a/src/problems/revc.lisp Sat Dec 15 16:56:57 2018 -0500 +++ b/src/problems/revc.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -28,7 +28,7 @@ ;; polarized ends, with one end being called 3′ and the other being 5′, but I'm ;; not 100% sure. -(defun reverse-complement (dna) +(defun nreverse-complement (dna) (flet ((dna-complement (base) (case base (#\A #\T) @@ -38,9 +38,12 @@ (map-into dna #'dna-complement dna) (nreverse dna))) +(defun reverse-complement (dna) + (nreverse-complement (copy-seq dna))) + (define-problem revc (data string) "AAAACCCGGT" "ACCGGGTTTT" "Return the reverse complement of `data`." - (reverse-complement (delete #\newline data))) + (nreverse-complement (delete #\newline data))) diff -r 1d0852c279f7 -r b1baea60c24f src/problems/revp.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/problems/revp.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -0,0 +1,51 @@ +(in-package :rosalind) + +;; The problem explanation provided a clever trick: you can cut the comparison +;; size in half by comparing the first half of the string to the reverse +;; complement of the second half, instead of comparing the entire thing. +;; +;; AAC GTT +;; CAA complement +;; AAC reverse +;; AAC=AAC palindrome! + +(defparameter *input-revp* + ">Rosalind_24 +TCAATGCATGCGGGTCTATATGCAT") + +(defparameter *output-revp* + "4 6 +5 4 +6 6 +7 4 +17 4 +18 4 +20 6 +21 4 +") + + +(defun reverse-palindrome-p (dna start length) + (let ((mid (+ start (truncate length 2))) + (end (+ start length))) + (unless (> end (length dna)) + (string= dna + (reverse-complement (subseq dna mid end)) + :start1 start + :end1 mid)))) + +(defun reverse-palindrome-length (dna start) + (iterate (for i :from 12 :downto 4 :by 2) + (finding i :such-that (reverse-palindrome-p dna start i)))) + +(define-problem revp (data stream) + *input-revp* + *output-revp* + (with-output-to-string (s) + (iterate + (with dna = (cdr (first (read-fasta-into-alist data)))) + (for i :index-of-vector dna) + (when-let ((l (reverse-palindrome-length dna i))) + (format s "~D ~D~%" (1+ i) l))))) + + diff -r 1d0852c279f7 -r b1baea60c24f src/utils.lisp --- a/src/utils.lisp Sat Dec 15 16:56:57 2018 -0500 +++ b/src/utils.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -225,6 +225,27 @@ (collect (cons label data)))) +;;;; Uniprot ------------------------------------------------------------------ +(defvar *uniprot-cache* (make-hash-table :test #'equal)) + +(defmacro get-cached (key cache expr) + (once-only (key cache) + (with-gensyms (value) + `(if-found (,value (gethash ,key ,cache)) + ,value + (setf (gethash ,key ,cache) ,expr))))) + +(defun uniprot-url (id) + (format nil "http://www.uniprot.org/uniprot/~A.fasta" id)) + +(defun uniprot (id) + (get-cached id *uniprot-cache* + (-<> (uniprot-url id) + drakma:http-request + read-fasta-into-alist + first))) + + ;;;; Testing ------------------------------------------------------------------ (defmacro define-test (problem input output &optional (test 'string=)) `(test ,(symb 'test- problem) diff -r 1d0852c279f7 -r b1baea60c24f vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Sat Dec 15 16:56:57 2018 -0500 +++ b/vendor/make-quickutils.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -6,10 +6,11 @@ :compose :curry + :ensure-gethash + :once-only :rcurry + :symb :with-gensyms - :once-only - :symb ) :package "ROSALIND.QUICKUTILS") diff -r 1d0852c279f7 -r b1baea60c24f vendor/quickutils.lisp --- a/vendor/quickutils.lisp Sat Dec 15 16:56:57 2018 -0500 +++ b/vendor/quickutils.lisp Sun Dec 16 18:01:43 2018 -0500 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :RCURRY :WITH-GENSYMS :ONCE-ONLY :SYMB) :ensure-package T :package "ROSALIND.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-GETHASH :ONCE-ONLY :RCURRY :SYMB :WITH-GENSYMS) :ensure-package T :package "ROSALIND.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "ROSALIND.QUICKUTILS") @@ -14,9 +14,9 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION - :COMPOSE :CURRY :RCURRY - :STRING-DESIGNATOR :WITH-GENSYMS - :ONCE-ONLY :MKSTR :SYMB)))) + :COMPOSE :CURRY :ENSURE-GETHASH + :ONCE-ONLY :RCURRY :MKSTR :SYMB + :STRING-DESIGNATOR :WITH-GENSYMS)))) (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`, @@ -90,6 +90,55 @@ (apply ,fun ,@curries more))))) + (defmacro ensure-gethash (key hash-table &optional default) + "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` +under key before returning it. Secondary return value is true if key was +already in the table." + `(multiple-value-bind (value ok) (gethash ,key ,hash-table) + (if ok + (values value ok) + (values (setf (gethash ,key ,hash-table) ,default) nil)))) + + + (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 rcurry (function &rest arguments) "Returns a function that applies the arguments it is called with and `arguments` to `function`." @@ -100,6 +149,23 @@ (multiple-value-call fn (values-list more) (values-list arguments))))) + (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)))) + + (deftype string-designator () "A string designator type. A string designator is either a string, a symbol, or a character." @@ -143,63 +209,8 @@ 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))))) - - - (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 once-only symb))) + (export '(compose curry ensure-gethash once-only rcurry symb with-gensyms + with-unique-names))) ;;;; END OF quickutils.lisp ;;;;