From nsiivola at common-lisp.net Thu Sep 23 13:59:52 2010 From: nsiivola at common-lisp.net (Nikodemus Siivola) Date: Thu, 23 Sep 2010 09:59:52 -0400 Subject: [alexandria.git] updated branch master: f5df120 Support case-sensitive lisps. Message-ID: The branch master has been updated: via f5df120eff98c753d238a64c2db19c9665bc50c5 (commit) from a5d7ec2a97cc0b0f45a17298d781665fd6d19bb8 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f5df120eff98c753d238a64c2db19c9665bc50c5 Author: Andreas Fuchs Date: Thu Sep 23 06:38:03 2010 -0700 Support case-sensitive lisps. * Alter `format-symbol` to accept a string designator as the format control. * Use uninterned symbols as format control for type names in type.lisp to get the correct names in case-sensitive lisps. ----------------------------------------------------------------------- Summary of changes: symbols.lisp | 12 ++++++------ types.lisp | 10 +++++----- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/symbols.lisp b/symbols.lisp index 44c0d71..e612afc 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -21,12 +21,12 @@ Example: (declaim (inline format-symbol)) (defun format-symbol (package control &rest arguments) - "Constructs a string by applying ARGUMENTS to CONTROL as if by FORMAT, and -then creates a symbol named by that string. If PACKAGE is NIL, returns an -uninterned symbol, if package is T, returns a symbol interned in the current -package, and otherwise returns a symbol interned in the package designated by -PACKAGE." - (maybe-intern (apply #'format nil control arguments) package)) + "Constructs a string by applying ARGUMENTS to string designator +CONTROL as if by FORMAT, and then creates a symbol named by that +string. If PACKAGE is NIL, returns an uninterned symbol, if package is +T, returns a symbol interned in the current package, and otherwise +returns a symbol interned in the package designated by PACKAGE." + (maybe-intern (apply #'format nil (string control) arguments) package)) (defun make-keyword (name) "Interns the string designated by NAME in the KEYWORD package." diff --git a/types.lisp b/types.lisp index dd354f3..b806c0d 100644 --- a/types.lisp +++ b/types.lisp @@ -24,7 +24,7 @@ ARRAY-DIMENSION-LIMIT." (push result subtype-names) result)) (make-predicate-name (sybtype-name) - (let ((result (format-symbol :alexandria "~A-P" + (let ((result (format-symbol :alexandria '#:~A-p (symbol-name sybtype-name)))) (push result predicate-names) result)) @@ -34,10 +34,10 @@ ARRAY-DIMENSION-LIMIT." type (if (equal range-beg ''*) inf (ensure-car range-beg)) (if (equal range-end ''*) inf (ensure-car range-end)))))) - (let* ((negative-name (make-subtype-name "NEGATIVE-~A")) - (non-positive-name (make-subtype-name "NON-POSITIVE-~A")) - (non-negative-name (make-subtype-name "NON-NEGATIVE-~A")) - (positive-name (make-subtype-name "POSITIVE-~A")) + (let* ((negative-name (make-subtype-name '#:negative-~A)) + (non-positive-name (make-subtype-name '#:non-positive-~A)) + (non-negative-name (make-subtype-name '#:non-negative-~A)) + (positive-name (make-subtype-name '#:positive-~A)) (negative-p-name (make-predicate-name negative-name)) (non-positive-p-name (make-predicate-name non-positive-name)) (non-negative-p-name (make-predicate-name non-negative-name)) -- Alexandria hooks/post-receive From nsiivola at common-lisp.net Thu Sep 23 15:30:55 2010 From: nsiivola at common-lisp.net (Nikodemus Siivola) Date: Thu, 23 Sep 2010 11:30:55 -0400 Subject: [alexandria.git] updated branch master: 6ddf676 new: DESTRUCTURING-CASE, -CCASE, and -ECASE Message-ID: The branch master has been updated: via 6ddf67679735379135dbb85042a65257571fce0b (commit) via 0c6f41f5cdf5bb33111d3b21c7daae50fc636456 (commit) from f5df120eff98c753d238a64c2db19c9665bc50c5 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 6ddf67679735379135dbb85042a65257571fce0b Author: Nikodemus Siivola Date: Thu Sep 23 18:22:28 2010 +0300 new: DESTRUCTURING-CASE, -CCASE, and -ECASE I've been wondering about adding these for a fair while now, but they _are_ nice when writing eg. certain kinds of macros, commit 0c6f41f5cdf5bb33111d3b21c7daae50fc636456 Author: Nikodemus Siivola Date: Thu Sep 23 18:20:35 2010 +0300 added .gitignore -files ----------------------------------------------------------------------- Summary of changes: .gitignore | 4 +++ doc/.gitignore | 3 ++ macros.lisp | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 3 ++ 4 files changed, 84 insertions(+), 0 deletions(-) create mode 100644 .gitignore create mode 100644 doc/.gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e832e94 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +*.fasl +*~ +\#* +*.patch diff --git a/doc/.gitignore b/doc/.gitignore new file mode 100644 index 0000000..f22577b --- /dev/null +++ b/doc/.gitignore @@ -0,0 +1,3 @@ +alexandria +include + diff --git a/macros.lisp b/macros.lisp index 75ff3f4..4450435 100644 --- a/macros.lisp +++ b/macros.lisp @@ -230,3 +230,77 @@ Signals a PROGRAM-ERROR is the lambda-list is malformed." (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list))))))) (values (nreverse required) (nreverse optional) rest (nreverse keys) allow-other-keys (nreverse aux)))) + +;;;; DESTRUCTURING-*CASE + +(defun expand-destructuring-case (key clauses case) + (once-only (key) + `(if (typep ,key 'cons) + (,case (car ,key) + ,@(mapcar (lambda (clause) + (destructuring-bind ((keys . lambda-list) &body body) clause + `(,keys + (destructuring-bind ,lambda-list (cdr ,key) + , at body)))) + clauses)) + (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) + +(defmacro destructuring-case (keyform &body clauses) + "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND. +KEYFORM must evaluate to a CONS. + +Clauses are of the form: + + ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) + +The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE, +is selected, and FORMs are then executed with CDR of KEY is destructured and +bound by the DESTRUCTURING-LAMBDA-LIST. + +Example: + + (defun dcase (x) + (destructuring-case x + ((:foo a b) + (format nil \"foo: ~S, ~S\" a b)) + ((:bar &key a b) + (format nil \"bar, ~S, ~S\" a b)) + (((:alt1 :alt2) a) + (format nil \"alt: ~S\" a)) + ((t &rest rest) + (format nil \"unknown: ~S\" rest)))) + + (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" + (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" + (dcase (list :alt1 1)) ; => \"alt: 1\" + (dcase (list :alt2 2)) ; => \"alt: 2\" + (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" + + (defun decase (x) + (destructuring-case x + ((:foo a b) + (format nil \"foo: ~S, ~S\" a b)) + ((:bar &key a b) + (format nil \"bar, ~S, ~S\" a b)) + (((:alt1 :alt2) a) + (format nil \"alt: ~S\" a)))) + + (decase (list :foo 1 2)) ; => \"foo: 1, 2\" + (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" + (decase (list :alt1 1)) ; => \"alt: 1\" + (decase (list :alt2 2)) ; => \"alt: 2\" + (decase (list :quux 1 2 3)) ; =| error +" + (expand-destructuring-case keyform clauses 'case)) + +(defmacro destructuring-ccase (keyform &body clauses) + (expand-destructuring-case keyform clauses 'ccase)) + +(defmacro destructuring-ecase (keyform &body clauses) + (expand-destructuring-case keyform clauses 'ecase)) + +(dolist (name '(destructuring-ccase destructuring-ecase)) + (setf (documentation name 'function) (documentation 'destructuring-case 'function))) + + + diff --git a/package.lisp b/package.lisp index b5ce17b..57c3526 100644 --- a/package.lisp +++ b/package.lisp @@ -233,4 +233,7 @@ #:symbolicate #:assoc-value #:rassoc-value + #:destructuring-case + #:destructuring-ccase + #:destructuring-ecase )) -- Alexandria hooks/post-receive From nsiivola at common-lisp.net Thu Sep 23 15:32:29 2010 From: nsiivola at common-lisp.net (Nikodemus Siivola) Date: Thu, 23 Sep 2010 11:32:29 -0400 Subject: [alexandria.git] updated branch master: 4ed03a2 DESTRUCTURING-CASE & friends in the manual Message-ID: The branch master has been updated: via 4ed03a2e72eea8453e21b54fadb9910c5002bc3f (commit) from 6ddf67679735379135dbb85042a65257571fce0b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 4ed03a2e72eea8453e21b54fadb9910c5002bc3f Author: Nikodemus Siivola Date: Thu Sep 23 18:32:06 2010 +0300 DESTRUCTURING-CASE & friends in the manual ----------------------------------------------------------------------- Summary of changes: doc/alexandria.texinfo | 1 + 1 files changed, 1 insertions(+), 0 deletions(-) diff --git a/doc/alexandria.texinfo b/doc/alexandria.texinfo index 0158525..792139c 100644 --- a/doc/alexandria.texinfo +++ b/doc/alexandria.texinfo @@ -114,6 +114,7 @@ terms and conditions: @chapter Data and Control Flow @include include/macro-alexandria-define-constant.texinfo + at include include/macro-alexandria-destructuring-case.texinfo @include include/macro-alexandria-ensure-functionf.texinfo @include include/macro-alexandria-multiple-value-prog2.texinfo @include include/macro-alexandria-named-lambda.texinfo -- Alexandria hooks/post-receive From nsiivola at common-lisp.net Thu Sep 23 15:42:04 2010 From: nsiivola at common-lisp.net (Nikodemus Siivola) Date: Thu, 23 Sep 2010 11:42:04 -0400 Subject: [alexandria.git] updated branch master: e6d5005 optimizations to BINOMIAL-COEFFICIENT and COUNT-PERMUATIONS Message-ID: The branch master has been updated: via e6d5005b43bc3bb70db40df7c103dc637b0dde39 (commit) from 4ed03a2e72eea8453e21b54fadb9910c5002bc3f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit e6d5005b43bc3bb70db40df7c103dc637b0dde39 Author: Nikodemus Siivola Date: Thu Sep 23 18:41:57 2010 +0300 optimizations to BINOMIAL-COEFFICIENT and COUNT-PERMUATIONS Patch by Gustavo on alexandria-devel. Also add tests. ----------------------------------------------------------------------- Summary of changes: numbers.lisp | 14 +++++++++----- tests.lisp | 18 ++++++++++++++++++ 2 files changed, 27 insertions(+), 5 deletions(-) diff --git a/numbers.lisp b/numbers.lisp index bf6ef0b..0fa29a4 100644 --- a/numbers.lisp +++ b/numbers.lisp @@ -210,6 +210,10 @@ greater then K." (if (or (zerop k) (= n k)) 1 (let ((n-k (- n k))) + ;; Swaps K and N-K if K < N-K because the algorithm + ;; below is faster for bigger K and smaller N-K + (when (< k n-k) + (rotatef k n-k)) (if (= 1 n-k) n ;; General case, avoid computing the 1x...xK twice: @@ -231,8 +235,8 @@ greater then K." (defun count-permutations (n &optional (k n)) "Number of K element permutations for a sequence of N objects. -R defaults to N" - ;; FIXME: Use %multiply-range and take care of 1 and 2, plus - ;; check types. - (/ (factorial n) - (factorial (- n k)))) +K defaults to N" + (check-type n (integer 0)) + (check-type k (integer 0)) + (assert (>= n k)) + (%multiply-range (1+ (- n k)) n)) diff --git a/tests.lisp b/tests.lisp index c139568..b9e2277 100644 --- a/tests.lisp +++ b/tests.lisp @@ -1712,3 +1712,21 @@ (1 2 3) nil nil) + +(deftest count-permutations.1 + (values (count-permutations 31 7) + (count-permutations 1 1) + (count-permutations 2 1) + (count-permutations 2 2) + (count-permutations 3 2) + (count-permutations 3 1)) + 13253058000 + 1 + 2 + 2 + 6 + 3) + +(deftest binomial-coefficient.1 + (alexandria:binomial-coefficient 1239 139) + 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154) -- Alexandria hooks/post-receive