;;;----------------------------- (setf nested '("this" "that" "the" "other") (setf nested '("this" "that" ("the" "other"))) ;;;----------------------------- (setf tune '("The" "Star-Spangled" "Banner")) |
;;;----------------------------- (setf a '("quick" "brown" "fox") ;;;----------------------------- (setf a '("Why" "are" "you" "teasing" "me?")) ;;;----------------------------- (setf lines (regex-replace-all (create-scanner "^\\s*(.+)" :multi-line-mode t ) " The boy stood on the burning deck, It was as hot as glass. " "\\1")) ;;;----------------------------- ;;; You don't really need an explicit call to the CL equivalent of ;;; Perl's die(). Its behavior is the same by default (it does put ;;; you into the CL debugger, but that's not a bad thing). You could, ;;; alternatively, handle this error with HANDLER-BIND or HANLDER-CASE ;;; if you wanted to be more precisely like the Perl version. (let ((bigarray '())) (with-open-file (data "mydatafile") (loop for line = (read-line data nil nil) while line do (push (string-right-trim #(#\Newline #\Return) line) bigarray)))) ;;;----------------------------- (setf banner "The Mines of Moria") ;;;----------------------------- (setf name "Gandalf") (setf banner (format nil "Speak ~A and enter!" name)) (setf banner "Speak $name and welcome!") ;;;----------------------------- (setf his-host "www.perl.com") #+sbcl (setf host-info (with-output-to-string (output) (sb-ext:run-program "nslookup" `(,his-host) :search t :output output))) ;; There's no equivalent to Perl's qx ;;;----------------------------- (setf banner '("Costs" "only" "$4.95")) (setf banner (split " " "Costs only $4.95")) ;;;----------------------------- (setf brax '(#\( #\) #\< #\> #\{ #\} #\[ #\])) (setf rings '("Nenya" "Narya" "Vilya")) (setf tags '("LI" "TABLE" "TR" "TD" "A" "IMG" "H1" "P")) (setf sample '("The" "vertical" "bar" "(|)" "looks" "and" "behaves" "like" "a" "pipe.")) ;;;----------------------------- ;; No equivalent in CL (would just be the same as above) ;;;----------------------------- ;; No equivalent in CL (would just be the same as above) ;;;----------------------------- |
;;;----------------------------- (defun commify-series (list) (case (length list) (0 "") (1 (car list)) (2 (format nil "~{~A~^ and ~}" list)) (t (concatenate 'string (format nil "~{~A~^, ~}" (butlast list)) (format nil " and ~A" (car (last list))))))) ;;;----------------------------- (let ((array '("red" "yellow" "green"))) (format t "I have ~{~A~} marbles.~%" array) (format t "I have ~{~A~^ ~} marbles.~%" array)) ;;I have redyellowgreen marbles. ;;I have red yellow green marbles. ;;;----------------------------- ;; download the following standalone program ;;;; commify_series - show proper comma insertion in list output (defparameter *lists* '(("just one thing") ("Mutt" "Jeff") ("Peter" "Paul" "Mary") ("To our parents" "Mother Theresa" "God") ("pastrami" "ham and cheese" "peanut butter and jelly" "tuna") ("recycle tired, old phrases" "ponder big, happy thoughts") ("recycle tired, old phrases" "ponder big, happy thoughts" "sleep and dream peacefully"))) (defun commify_series (list) (let ((sepchar (if (find-if #'(lambda (string) (find #\, string)) list) "; " ", "))) (case (length list) (0 "") (1 (car list)) (2 (format nil "~{~a~^ and ~}" list)) (t (concatenate 'string (format nil "~{~}" (concatenate 'string "~a~^" sepchar) (butlast list)) (format nil " and ~a" (car (last list)))))))) (mapc #'(lambda (list) (format t "The list is: ~a.~%" (commify_series list))) *lists*) ;;;----------------------------- |
;;;----------------------------- ;; grow or shrink MY-ARRAY (assuming it was created with :ADJUSTABLE ;; set to T) (adjust-array my-array (1+ new-last-element-index-number)) ;;;----------------------------- ;; There's no auto-creation of array elements. ;;;----------------------------- (defparameter *people* (make-array 4 :initial-contents '("Crosby" "Stills" "Nash" "Young") :adjustable t)) (defun what-about-that-array () (format t "The array now has ~D elements The index of the last element is ~D Element #3 is ~A~%" (length *people*) (1- (length *people*)) (aref *people* 3))) (what-about-that-array) ;;;----------------------------- ;;The array now has 4 elements ;;The index of the last element is 3 ;;Element #3 is Young ;;;----------------------------- (adjust-array *people* (1- (length *people*))) (what-about-that-array) ;;;----------------------------- ;; Evaluating WHAT-ABOUT-THAT-ARRAY now results in an error because ;; there is no 3rd element, and, unlike Perl, CL doesn't just return ;; the empty string in that case. ;;;----------------------------- (adjust-array *people* 10001) (what-about-that-array) ;;;----------------------------- ;;The array now has 10001 elements ;;The index of the last element is 9999 ;;Element #3 is 0 ;;;----------------------------- (setf (aref *people* 10000) nil) ;;;----------------------------- |
;;;----------------------------- (dolist (item list) ;; do something with ITEM ) ;;;----------------------------- (dolist (user bad-users) (complain user)) ;;;----------------------------- (dolist (var (sort (loop for x being the hash-keys of axl collect x) #'<)) (format t "~A=~A~%" var (gethash var ENV))) ;;;----------------------------- (dolist (user all-users) (let ((disk-space (get-usage user))) (when (> disk-space +max-quota+) (complain user)))) ;;;----------------------------- #+sbcl (dolist (line (split "\\n" (with-output-to-string (output) (sb-ext:run-program "who" nil :search t :output output)))) (when (scan "tchrist" line) (format t "~A~%" line))) ;;;----------------------------- (loop for line = (read-line fh nil :eof nil) ; LINE is set to the line just read until (eq line :eof) do (dolist (chunk (split "\\s+" ; LINE is split on whitespace ; then CHUNK is set to each chunk in turn (chomp line))) ; LINE has a trailing \n removed, if it had one (format t "~A" ; CHUNK is printed (reverse chunk)))) ; the characters in CHUNK are reversed ;;;----------------------------- (map nil #'(lambda (item) (format t "i = ~A~%" item)) my-array) ;;;----------------------------- (setf my-array #(1 2 3)) (map-into my-array #'(lambda (item) (decf item)) my-array) my-array ;; #(0 1 2) ;; multiply everything in a and b by seven (setf a #(.5 3) b #(0 1)) (map-into a #'(lambda (item) (* item 7)) a) (map-into b #'(lambda (item) (* item 7)) b) (format t "~{~A~^ ~} ~{~A~^ ~}~%" (coerce a 'list) (coerce b 'list)) ;; 3.5 21 0 7 ;;;----------------------------- ;; The following macro is mostly like Perl's foreach, in the sense ;; that you can pass in as many references to sequences or "scalars" ;; as you want and it will iterate over them and allow you to modify ;; them. Unlike the Perl code, it sets the variable IT to each ;; element rather than $_. Also, you have to just pass in the hash ;; table directly, not a flattened list of hash keys. (defmacro perl-foreach ((&rest refs) &body body) (let* ((gensyms (loop repeat (length refs) collect (gensym)))) (list* 'let (mapcar #'list gensyms refs) (loop for ref in refs and indirect-ref in gensyms collect `(typecase ,indirect-ref (hash-table (maphash #'(lambda (key value) (declare (ignore value)) (symbol-macrolet ((it (gethash key ,indirect-ref))) ,@body)) ,indirect-ref)) ((and (or vector list) (not string)) (map-into ,indirect-ref #'(lambda (it) ,@body it) ,indirect-ref)) (t (symbol-macrolet ((it ,ref)) ,@body))))))) ;; trim whitespace in the scalar, the list, the array, and all the ;; values in the hash (perl-foreach (scalar my-list my-array my-hash) (setf it (regex-replace "^\\s+" it "")) (setf it (regex-replace "\\s+$" it ""))) ;;;----------------------------- ;; The Perl code in this subsection is Perl-specific (demonstrating ;; the shorthand syntax for "foreach"). ;;;----------------------------- |
;;;----------------------------- ;; iterate over elements of array in ARRAYREF (but if you intend to ;; modify the elemnts, it will only modify non-"scalar" elements such ;; as lists, structures, etc). (map 'array #'(lambda (item) ;; do something with ITEM ) arrayref) ;; or you can use LOOP (loop for item across arrayref do ;; do something with ITEM ) ;; to modify the array contents (even if they're "scalars" like ;; numbers) (map-into arrayref #'(lambda (item) ;; do something with ITEM ) arrayref) ;; or you can use ITER (iter (for i index-of-vector arrayref) ;; do something with (aref arrayref i) ) ;; As a side note, for lists you could also do the following (won't ;; allow modifying "scalar" elements of the list). (dolist (item list) ;; do something with ITEM ) ;;;----------------------------- (defparameter *fruits* #("Apple" "Blackberry")) (setf fruit-ref *fruits*) (loop for fruit across fruit-ref do (format t "~A tastes good in a pie.~%" fruit)) ;;Apple tastes good in a pie. ;;Blackberry tastes good in a pie. ;;;----------------------------- (loop for i below (length fruit-ref) do (format t "~A tastes good in a pie.~%" (svref fruit-ref i))) ;;;----------------------------- (setf (gethash :felines *namelist*) *rogue-cats*) (dolist (cat (gethash :felines *namelist*)) (format t "~A purrs hypnotically..~%" cat)) (format t "--More--~%You are controlled.~%") ;;;----------------------------- (loop for i below (length (gethash :felines *namelist*)) do (format t "~A purrs hypnotically..~%" (elt (gethash :felines *namelist*) i))) ;;;----------------------------- |
;;;----------------------------- (defparameter *seen* (make-hash-table :test 'equal)) (defparameter *uniq* '()) (dolist (item my-list) (unless (gethash item *seen*) ;; if we are here, we have not seen it before (setf (gethash item *seen*) 1) (push item *uniq*))) ;;;----------------------------- (clrhash *seen*) (dolist (item my-list) (when (= (incf (gethash item *seen* 0)) 1) (push item *uniq*))) ;;;----------------------------- (clrhash *seen*) (dolist (item my-list) (when (= (incf (gethash item *seen* 0)) 1) (some-func item))) ;;;----------------------------- (clrhash *seen*) (dolist (item my-list) (incf (gethash item *seen* 0))) (setf *uniq* (loop for k being the hash-keys of *seen* collect k)) ;;;----------------------------- (clrhash *seen*) (setf *uniq* (perl-grep my-list (= 1 (incf (gethash it *seen* 0))))) ;;;----------------------------- ;; generate a list of users logged in, removing duplicates (defparameter *ucnt* (make-hash-table :test 'equal)) (defmacro dostream ((var stream) &body body) "Like DOLIST except iterates over the lines of STREAM. Does not close STREAM." (let ((s (gensym "stream-")) (eof (gensym "eof-"))) `(let ((,s ,stream)) (do ((,var (read-line ,s nil ',eof nil) (read-line ,s nil ',eof nil))) ((eql ,var ',eof)) ,@body)))) #+sbcl (with-open-stream (s (process-output (sb-ext:run-program "who" nil :search t :output :stream :wait nil))) (dostream (who s) ;; kill from first space till end-of-line, yielding username (setf who (regex-replace "\\s.*$" who "")) (incf (gethash who *ucnt* 0)))) ; record the presence of this user ;; extract and print unique keys (defparameter *users* (sort (loop for k being the hash-keys of *ucnt* collect k) #'string=)) (format t "users logged in: ~{~A~^ ~}~%" *users*) ;;;----------------------------- |
;;;----------------------------- ;; assume A and B are already loaded (defparameter *seen* (make-hash-table :test 'equal)) ; lookup table to test membership of B (defparameter *a-only* '()) ; answer ;; build lookup table (loop for item in b do (setf (gethash item *seen*) 1)) ;; find only elements in A and not in B (dolist (item a) (unless (gethash item *seen*) ;; it's not in SEEN, so add to *A-ONLY* (push item *a-only*))) ;;;----------------------------- ;; The Perl example here isn't substantially different from the above ;; in CL. ;;;----------------------------- (dolist (item a) (unless (gethash item *seen*) (push item *a-only*)) (setf (gethash item *seen*) 1)) ; mark as seen ;;;----------------------------- (setf (gethash "key1" my-hash) 1) (setf (gethash "key2" my-hash) 2) ;;;----------------------------- (loop for key in '("key1" "key2") and value in '(1 2) do (setf (gethash key my-hash) value)) ;;;----------------------------- (loop for key in b do (setf (gethash key my-hash) nil)) ;;;----------------------------- (loop for key in b do (setf (gethash key my-hash) (loop repeat (length b) collect 1))) ;;;----------------------------- |
;;;----------------------------- (defparameter *a* '(1 3 5 6 7 8)) (defparameter *b* '(2 3 5 7 9)) (defvar *union*) (defvar *isect*) (defvar *diff*) (defparameter *union-hash* (make-hash-table)) (defparameter *isect-hash* (make-hash-table)) (defparameter *count* (make-hash-table)) ;;;----------------------------- ;; don't actually do this, use instead the built-ins shown at the end (dolist (e *a*) (setf (gethash e *union-hash*) 1)) (dolist (e *b*) (when (gethash e *union-hash*) (setf (gethash e *isect-hash*) 1)) (setf (gethash e *union-hash*) 1)) (setf *union* (loop for k being the hash-keys of *union-hash* collect k)) (setf *isect* (loop for k being the hash-keys of *isect-hash* collect k)) ;; or you could use the built ins (setf *union* (union *a* *b*)) (setf *isect* (intersection *a* *b*)) ;;;----------------------------- (perl-foreach (*a* *b*) (and (prog1 (gethash it *union-hash*) (incf (gethash it *union-hash* 0))) (incf (gethash it *isect-hash* 0)))) (setf *union* (hash-keys *union-hash*)) ; HASH-KEYS defined in Appendix (setf *isect* (hash-keys *isect-hash*)) ;;;----------------------------- (perl-foreach (*a* *b*) (incf (gethash it *count* 0))) (loop for e being the hash-keys of *count* using (hash-value count) do (push e *union*) (case count (2 (push e *isect*)) (t (push e *diff*)))) ;;;----------------------------- ;; Without writing a special macro, there'd be no obvious difference ;; from the previous example. ;;;----------------------------- |
;;;----------------------------- ;; push (setf array1 (append array1 array2)) ;;;----------------------------- (setf array1 `(,@array1 ,@array2)) ;;----------------------------- (let ((members '("Time" "Flies")) (initiates '("An" "Arrow"))) (setf members (append members initiates)) ;; members is now ("Time" "Flies" "An" "Arrow") ;;;----------------------------- (setf members `(,@(subseq members 0 2) "Like" ,@initiates)) (format t "~{~a~^ ~}~%" members) (setf members `("Fruit" ,@(subseq members 1))) (setf members `(,@(subseq members 0 (- (length members) 2)) "A" "Banana")) (format t "~{~a~^ ~}~%" members)) ;;;----------------------------- ;;Time Flies Like An Arrow ;;Fruit Flies Like A Banana ;;;----------------------------- |
;;;----------------------------- ;; reverse ARRAY into REVERSED (setf reversed (reverse *array*)) ;;----------------------------- (do ((i (1- (array-dimension *array* 0)) (1- i))) ((minusp i)) ;; do something with (aref array i) ) ;;;----------------------------- ;; two-step: sort then reverse ;; SORT is destructive, hence STABLE-SORT (setf ascending (stable-sort users 'string-lessp)) (setf descending (reverse ascending)) ;; one-step: sort with reverse comparison (setf descending (reverse (stable-sort users 'string-lessp))) ;;;----------------------------- |
;;;----------------------------- ;; Removing N elements from front of MY-ARRAY requires 2 steps in CL. (setf front (subseq my-array 0 n)) (setf my-array (subseq my-array n)) ;; We can write a macro to mimic Perl's behavior, however. (defmacro perl-splice (sequence-place &optional (offset 0) length replacement-sequence) (let* ((seq (gensym "SEQUENCE-PLACE-")) (off-arg (gensym "OFFSET-ARG-")) (off (gensym "OFFSET-")) (len (gensym "LENGTH-")) (end (gensym "END-")) (rep (gensym "REPLACEMENT-SEQUENCE-")) (left-part (list `(subseq ,seq 0 ,off))) (right-part (when length (list `(subseq ,seq ,end))))) `(let* ((,seq ,sequence-place) (,off-arg ,offset) (,off (if (minusp ,off-arg) (+ (length ,seq) ,off-arg) ,off-arg)) (,len ,length) (,end (when ,len (if (minusp ,len) (+ (length ,seq) ,len) (+ ,off ,len)))) (,rep ,replacement-sequence)) (prog1 (subseq ,seq ,off ,end) (when (or ,rep (not (eql ,off ,end))) (setf ,sequence-place (concatenate (typecase ,seq (cons 'list) (t 'vector)) ,@left-part ,rep ,@right-part))))))) ;; Now the syntax is almost exactly the same. (setf front (perl-splice my-array 0 n)) (setf end (perl-splice my-array 0 (- n))) ;;;----------------------------- (defmacro shift2 (sequence) `(perl-splice ,sequence 0 2)) (defmacro pop2 (sequence) `(perl-splice ,sequence -2)) ;;;----------------------------- (defparameter *friends* '(Peter Paul Mary Jim Tim)) (destructuring-bind (this that) (shift2 *friends*) ;; THIS contains PETER, THAT has PAUL, and ;; *FRIENDS* has MARY, JIM, and TIM ) (defparameter *beverages* #(Dew Jolt Cola Sprite Fresca)) (let ((pair (pop2 *beverages*))) ;; (aref pair 0) contains Sprite, (aref pair 1) has Fresca, ;; and *beverages* has #(DEW JOLT COLA) ) ;;;----------------------------- (setf (aref line 5) my-list) (setf got (pop2 (aref line 5))) ;;;----------------------------- |
;;;----------------------------- (let ((match (find item *sequence*))) (cond (match ;; do something with MATCH ) (t ;; unfound ))) ;;;----------------------------- (let ((match-idx (position item *sequence*))) (cond (match-idx ;; found in (elt *sequence* match-idx) (any sequence) ;; or (svref *sequence* match-idx) if you know it's a vector ) (t ;; unfound ))) ;;;----------------------------- (defstruct employee name category) ; just to make example work (format t "Highest paid engineer is: ~A~%" (employee-name (find 'engineer *employees* :key 'employee-category :from-end t))) ;;;----------------------------- ;; Don't do this, just intended how one could match the Perl example. (let ((i (loop for idx below (length *array*) ;; do (when criterion ;; put criterion here (return idx))))) (if (< i (length *array*)) (progn ;; found and I is the index ) (progn ;; not found ))) ;;;----------------------------- |
;;;----------------------------- (setf matching (find-if-not #'test list)) ;;----------------------------- (let ((matching '())) (dolist (item list) (when (test item) (push item matching)))) ;;;----------------------------- (setf bigs (remove-if-not #'(lambda (num) (> num 1000000)) nums)) (setf pigs (loop for user being the hash-keys of users using (hash-value uid) when (> uid 1e7) collect user)) ;;;----------------------------- #+sbcl (remove-if-not #'(lambda (line) (scan "^gnat " line)) (split #\Newline (with-output-to-string (output) (sb-ext:run-program "who" nil :search t :output output)q))) ;;;----------------------------- ;;; Assumes DEFSTRUCT or DEFCLASS of EMPLOYEE with a POSITION slot. (setf engineers (remove "Engineer" employees :key #'employee-position :test-not 'string=)) ;;----------------------------- (setf secondary-assistance (remove-if-not #'(lambda (applicant) (and (>= (applicant-income applicant) 26000) (< (applicant-income applicant) 30000))) applicants)) ;;;----------------------------- |
;;;----------------------------- (setf sorted (stable-sort unsorted '<)) ;;;----------------------------- ;; PIDS is an unsorted list of process IDs (dolist (pid (stable-sort pids '<)) (format t "~A~%" pid)) (format t "Select a process ID to kill:~%") (let ((pid (read))) (etypecase pid (integer (sb-posix:kill pid sb-posix:sigterm) (sleep 2) (ignore-errors (sb-posix:kill pid sb-posix:sigkill))))) ;;;----------------------------- (setf descending (stable-sort unsorted '>)) (defpackage :sort-subs (:use cl)) (in-package :sort-subs) (defun revnum (a b) (< b a)) (defpackage :other-pack (:use cl)) (in-package :other-pack) (defparameter *all* (stable-sort #(4 19 8 3) 'sort-subs::revnum)) ;;;----------------------------- (setf *all* (stable-sort #(4 19 8 3) '>)) (in-package :cl-user) ;;;----------------------------- |
;;; There is nothing special about sorting a list by computable field in Common ;;; Lisp. One just need to pass an appropriate `KEY' function to `SORT'. (defvar *sample-list* '((1 -1 0.1 "one") (2 -2 0.2 "two") (3 -3 0.3 "three"))) ;;; Just keep in mind that, `SORT' works destructively. (That's why we use ;;; `COPY-LIST' in the below expression.) (sort (copy-list *sample-list*) #'< :key #'first) ; => ((1 -1 0.1 "one") ; (2 -2 0.2 "two") ; (3 -3 0.3 "three")) (sort (copy-list *sample-list*) #'string< :key #'fourth) ; => ((1 -1 0.1 "one") ; (3 -3 0.3 "three") ; (2 -2 0.2 "two")) (sort (copy-list *sample-list*) #'< :key (lambda (list) (* (second list) (third list)))) ; => ((3 -3 0.3 "three") ; (2 -2 0.2 "two") ; (1 -1 0.1 "one")) |
;;;----------------------------- ;;; The following aren't efficient on long lists (setf circular `(,@(last circular) ,@(nbutlast circular))) ; the last shall be first (setf circular `(,@(cdr circular) ,(car circular))) ; and vice versa ;;;----------------------------- ;;; There is probably a less ugly way to do this (defmacro grab-and-rotate (list) `(prog1 (car ,list) (setf ,list `(,@(cdr ,list) ,(car ,list))))) (let ((processes '(1 2 3 4 5))) (loop (let ((process (grab-and-rotate processes))) (format t "Handling process ~A~%" process) (sleep 1)))) ;;;----------------------------- |
;;;----------------------------- (defun fisher-yates-shuffle (vector) "Randomly shuffle elements of VECTOR." (loop for i from (1- (length vector)) downto 1 for j = (random i) unless (= i j) do (rotatef (aref vector i) (aref vector j))) vector) (fisher-yates-shuffle vector) ; permutes VECTOR in place ;;;----------------------------- (defun shuffle (vector) "Return a fresh permuted copy of VECTOR." (let* ((n-permutations (factorial (length vector))) (permutation (nth-permutation (random n-permutations) (length vector)))) (map 'vector (lambda (i) (aref vector i)) permutation))) ;;; (defun naive-shuffle (vector) (loop with n = (length vector) for i from 0 below n for j = (random n) do (rotatef (aref vector i) (aref vector j))) vector) |
(defun print-matrix (matrix column-len) (format t (format nil "~~{~~{~~@[~~~DA~~^ ~~]~~}~~%~~}" column-len) matrix)) (defun pop-matrix-column (matrix) (when matrix (let ((elt (caar matrix))) (setf (car matrix) (cdar matrix)) (cons elt (pop-matrix-column (cdr matrix)))))) (defun transpose-matrix (matrix) (when (car matrix) (cons (pop-matrix-column matrix) (transpose-matrix matrix)))) (defun parse-matrix-row (string &key count) (when string (ppcre:split "\\s+" string :limit count))) (defun parse-matrix (stream) (let ((first-row (parse-matrix-row (read-line stream nil nil)))) (when first-row (let* ((n-columns (length first-row)) (matrix (cons first-row (loop for row = (parse-matrix-row (read-line stream nil nil) :count n-columns) while row collect row))) (column-len (reduce #'max matrix :key (lambda (vals) (reduce #'max vals :key #'length))))) (print-matrix (transpose-matrix matrix) column-len))))) (with-input-from-string (in "awk cp ed login mount rmdir sum basename csh egrep ls mt sed sync cat date fgrep mail mv sh tar chgrp dd grep mkdir ps sort touch chmod df kill mknod pwd stty vi chown echo ln more rm su") (parse-matrix in)) ; => awk basename cat chgrp chmod chown ; cp csh date dd df echo ; ed egrep fgrep grep kill ln ; login ls mail mkdir mknod more ; mount mt mv ps pwd rm ; rmdir sed sh sort stty su ; sum sync tar touch vi |
;;; A naive `FACTORIAL' implementation. (defun factorial (n) (if (< n 2) 1 (* n (factorial (1- n))))) ;;; A tail-recursive derivative of the above `FACTORIAL' implementation. (defun tco-factorial (n) (labels ((iter (m acc) (if (< n m) acc (iter (1+ m) (* m acc))))) (iter 1 1))) (tco-factorial (expt 2 8)) ; => 857817775342842654119082271681232625157781520279485619859655650377269452553 ; 147589377440291360451408450375885342336584306157196834693696475322289288497 ; 426025679637332563368786442675207626794560187968867971521143307702077526646 ; 451464709187326100832876325702818980773671781454170250523018608495319068138 ; 257481070252817559459476987034665712738139286205234756808218860701203611083 ; 152093501947437109101726968262861606263662435022840944191408424615936000000 ; 000000000000000000000000000000000000000000000000000000000 (defun permutations (items &key test &aux (test (or test #'eql))) (if (null items) '(()) (mapcan (lambda (item) (mapcar (lambda (permutation) (cons item permutation)) (permutations (remove item items :test test) :test test))) items))) (permutations '("man" "bites" "dog") :test #'string-equal) ; => (("man" "bites" "dog") ; ("man" "dog" "bites") ; ("bites" "man" "dog") ; ("bites" "dog" "man") ; ("dog" "man" "bites") ; ("dog" "bites" "man")) |